packages feed

grisette 0.4.1.0 → 0.13.0.1

raw patch · 425 files changed

This diff is very large; some files are shown as “too large to diff”. Download the raw patch for the complete diff.

Files

CHANGELOG.md view
@@ -3,61 +3,535 @@ All notable changes to this project will be documented in this file.  The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),-and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html).+and this project adheres to+[Semantic Versioning](https://semver.org/spec/v2.0.0.html). +## [0.13.0.0] -- 2025-07-03++### Added++- Added missing instances for `ArithException`.+  ([#292](https://github.com/lsrcz/grisette/pull/292))+- [Breaking] Added `Integral` instances for `SymInteger`, `SymIntN`, and+  `SymWordN`. Also make `(/)`, `recip` and `logBase` no longer throw errors for+  `SymAlgReal`. These functions are "unsafe" and should be used with caution as+  they expose undefined behavior for some inputs.+  ([#293](https://github.com/lsrcz/grisette/pull/293))+- Added `MergingIndex` type class for types that can be used as indices in a+  'SortedStrategy'. ([#294](https://github.com/lsrcz/grisette/pull/294))+- Added `makeGrisetteADT` and `makeGrisetteBasicADT` for easier use of ADTs with+  Grisette. ([#295](https://github.com/lsrcz/grisette/pull/295),+  [#303](https://github.com/lsrcz/grisette/pull/303))+- Added `Concrete` type class to tag the types guaranteed to be fully concrete.+  ([#296](https://github.com/lsrcz/grisette/pull/296))+- Added `SymBoolKey`/`UnionKey` types that is an alias for `AsKey SymBool` and+  `AsKey1 Union`, respectively.+  ([#301](https://github.com/lsrcz/grisette/pull/301))++### Changed++- Removed `Show` constraints for merging indices.+  ([#294](https://github.com/lsrcz/grisette/pull/294))+- [Breaking] Removed `Hashable` instances for `SymBool`, and also, `Eq` now+  errors when called. Added `AsKey` wrapper to recover the original behavior.+  ([#299](https://github.com/lsrcz/grisette/pull/299))+- Make `GetData` now accept one parameter instead of two so that `GetData mode`+  can be used as a type in a context where we want a monad. The `BaseMonad` is+  now a type alias of `GetData`.+  ([#302](https://github.com/lsrcz/grisette/pull/302))+- [Breaking] Renamed `PlainUnion` to `UnionView`.+  ([#302](https://github.com/lsrcz/grisette/pull/302))+- Implemented `UnionView` for `Identity`.+  ([#302](https://github.com/lsrcz/grisette/pull/302))+- Added unified versions of `simpleMerge` and `onUnion` that uses `UnionView`.+  ([#302](https://github.com/lsrcz/grisette/pull/302))++## [0.12.0.0] -- 2025-04-12++### Added++- Added derivation of `Mergeable` instances using `NoStrategy`.+  ([#269](https://github.com/lsrcz/grisette/pull/269))+- Added `filterExactNumArgs` and `filterLeqNumArgs` for filtering classes that+  accepts type constructors with exactly or at most $n$ arguments. Added more+  list of classes. ([#269](https://github.com/lsrcz/grisette/pull/269))+- Added derivation for `Mergeable` using `NoStrategy`.+  ([#270](https://github.com/lsrcz/grisette/pull/270))+- Added derivation for cereal and binary serializations.+  ([#271](https://github.com/lsrcz/grisette/pull/271))+- Added unconstrained positions for derivation.+  ([#273](https://github.com/lsrcz/grisette/pull/273))+- Added `AsMetadata` type class and `Metadata` pattern for embedding and+  extracting values from metadata represented as an S-expression.+  ([#277](https://github.com/lsrcz/grisette/pull/277))+- Improved `SupportedNonFuncPrim` and `BasicSymPrim` constraints.+  ([#278](https://github.com/lsrcz/grisette/pull/278))+- Provided better patterns for term analysis.+  ([#280](https://github.com/lsrcz/grisette/pull/280))+- Added `PPrint` instances for `SomeTerm` and `Term`.+  ([#281](https://github.com/lsrcz/grisette/pull/281))+- Types with `SimpleMergeable` instances now have default `ITEOp` instances.+  ([#290](https://github.com/lsrcz/grisette/pull/290))++### Changed++- Derivation of `PPrint` no longer relies on `OverloadedStrings` extension.+  ([#268](https://github.com/lsrcz/grisette/pull/268))+- The `choose*Fresh` functions will not try its best to minimize the size of the+  guards. ([#283](https://github.com/lsrcz/grisette/pull/283))+- `EvalModeConvertible` is now reflexive.+  ([#284](https://github.com/lsrcz/grisette/pull/284))+- [Breaking] Renamed `deriveGADT` to `derive`.+  ([#286](https://github.com/lsrcz/grisette/pull/286))++### Fixed++- Fixed the derivation for empty data types.+  ([#272](https://github.com/lsrcz/grisette/pull/272))++## [0.11.0.0] -- 2024-12-29++### Added++- Added `deriveGADT` for deriving all relevant instances for GADTs.+  ([#267](https://github.com/lsrcz/grisette/pull/267))+- Added `EvalModeConvertible` for a unified constraint for the evaluation modes+  that can be converted to each other with `ToCon` and `ToSym`.+  ([#267](https://github.com/lsrcz/grisette/pull/267))++### Changed++- [Breaking] We no longer support direct `toCon` from a union to a single value+  or `toSym` from a single value to a union. These should now be done through+  `mrgToSym`, `toUnionSym`, and `unionToCon`.+  ([#267](https://github.com/lsrcz/grisette/pull/267))+- [Breaking] Changed the `EvalMode` tag for `Con` to `C` and `Sym` to `S`.+  ([#267](https://github.com/lsrcz/grisette/pull/267))++### Fixed++- Fixed some missing constraints for unified interfaces.+  ([#267](https://github.com/lsrcz/grisette/pull/267))+- Fixed badly staged types in the lifting of terms.+  ([#267](https://github.com/lsrcz/grisette/pull/267))+- Fixed the `Read` instance for bit-vectors on GHC 9.12.+  ([#267](https://github.com/lsrcz/grisette/pull/267))++### Removed++- Removed old template-haskell-based derivation mechanism.+  ([#267](https://github.com/lsrcz/grisette/pull/267))++## [0.10.0.0] -- 2024-12-11++### Added++- `SomeBV` now allows being used under conditionals even if no bit-width is+  specified. ([#261](https://github.com/lsrcz/grisette/pull/261))+- Added interface to smart constructor generation with decapitalized names.+  ([#263](https://github.com/lsrcz/grisette/pull/263))+- Added `SymPrim` constraints for symbolic primitive types.+  ([#264](https://github.com/lsrcz/grisette/pull/264))+- Added initial support for type class derivation for GADTs.+  ([#265](https://github.com/lsrcz/grisette/pull/265))++### Changed++- [Breaking] Improved the `SymFiniteBits` interface.+  ([#262](https://github.com/lsrcz/grisette/pull/262))+- [Breaking] Changed the smart constructor generation Template Haskell procedure+  name to `makeSmartCtorWith`, `makePrefixedSmartCtorWith`,+  `makeNamedSmartCtor`, and `makeSmartCtor`.+  ([#263](https://github.com/lsrcz/grisette/pull/263))+- [Breaking] Renamed the evaluation mode tags `Con` and `Sym` to `C` and `S`.+  ([#264](https://github.com/lsrcz/grisette/pull/264))++## [0.9.0.0] -- 2024-11-07++### Added++- Added missing instances for concrete general and tabular functions.+  ([#249](https://github.com/lsrcz/grisette/pull/249))+- Added eval mode constraint on demand.+  ([#250](https://github.com/lsrcz/grisette/pull/250))+- Added support for uninterpreted functions in unified interfaces.+  ([#250](https://github.com/lsrcz/grisette/pull/250))+- Added instances for concrete `Ratio` type.+  ([#251](https://github.com/lsrcz/grisette/pull/251))+- Added serialization for the core constructs.+  ([#253](https://github.com/lsrcz/grisette/pull/253))+- Added partial evaluation for distinct.+  ([#254](https://github.com/lsrcz/grisette/pull/254))++### Changed++- [Breaking] Moved the constraints for the general and tabular functions and+  simplified their instances declaration.+  ([#249](https://github.com/lsrcz/grisette/pull/249))+- [Breaking] Renamed `EvalMode` to `EvalModeAll`, renamed `MonadWithMode` to+  `MonadEvalModeAll`. ([#250](https://github.com/lsrcz/grisette/pull/250))+- Improved parallel symbolic evaluation performance.+  ([#252](https://github.com/lsrcz/grisette/pull/252))+- [Breaking] Changed the metadata for identifiers from existential arguments to+  s-expressions. ([#253](https://github.com/lsrcz/grisette/pull/253))+- [Breaking] Changed the solving/cegis results from maintaining the exception+  themselves to maintaining a textual representation of them.+  ([#253](https://github.com/lsrcz/grisette/pull/253))+- [Breaking] Changed the 'VerifierResult' type for CEGIS to allow it report that+  the verifier cannot find a counter example.+  ([#257](https://github.com/lsrcz/grisette/pull/257))++### Fixed++- Fixed memory leak within the term cache.+  ([#252](https://github.com/lsrcz/grisette/pull/252))+- Fixed printing of bv terms.+  ([#255](https://github.com/lsrcz/grisette/pull/255))+- Fixed solverGenericCEGIS and make it also return the last failing cex.+  ([#256](https://github.com/lsrcz/grisette/pull/256))+- `solverGenericCEGIS` will only rerun possible verifiers now. This will improve+  overall verification performance.+  ([#258](https://github.com/lsrcz/grisette/pull/258))+- Fixed a **critical** bug in the lowering/evalSym/extractSym where the+  intermediate states are not properly memoized.+  ([#259](https://github.com/lsrcz/grisette/pull/259))++## [0.8.0.0] -- 2024-08-13++### Added++- Added pretty printer for models.+  ([#225](https://github.com/lsrcz/grisette/pull/225))+- Added support for algebraic reals (`AlgReal` and `SymAlgReal`).+  ([#228](https://github.com/lsrcz/grisette/pull/228),+  [#229](https://github.com/lsrcz/grisette/pull/229))+- Added support for quantifiers.+  ([#230](https://github.com/lsrcz/grisette/pull/230))+- Added `SafeFdiv`, `SafeLogBase`, `DivOr`, `FdivOr`, and `LogBaseOr`.+  ([#228](https://github.com/lsrcz/grisette/pull/228),+  [#231](https://github.com/lsrcz/grisette/pull/231))+- Added bitcast from and to `Bool`, `IntN`, `WordN`, `FP` and their symbolic+  counterparts when appropriate.+  ([#232](https://github.com/lsrcz/grisette/pull/232))+- Add `SymFromIntegral`. ([#233](https://github.com/lsrcz/grisette/pull/233))+- Add operations for concrete floating point numbers. Add IEEE754-2019+  `fpMinimum`, `fpMinimumNumber`, `fpMaximum`, and `fpMaximumNumber` operations.+  ([#235](https://github.com/lsrcz/grisette/pull/235))+- Add conversion from and to floating points.+  ([#236](https://github.com/lsrcz/grisette/pull/236))+- Add `SymFiniteBits`. ([#237](https://github.com/lsrcz/grisette/pull/237))+- Add unified instances for all provided operations, including `FP` and+  `AlgReal`. ([#239](https://github.com/lsrcz/grisette/pull/239),+  [#240](https://github.com/lsrcz/grisette/pull/240),+  [#243](https://github.com/lsrcz/grisette/pull/243))+- Allow the use of number literals for `SomeBV`.+  ([#245](https://github.com/lsrcz/grisette/pull/245))+- Add `symDistinct`. ([#246](https://github.com/lsrcz/grisette/pull/246),+  [#247](https://github.com/lsrcz/grisette/pull/247))++### Fixed++- Fixed model parsing for floating points.+  ([#227](https://github.com/lsrcz/grisette/pull/227))+- Allowed `mkUnifiedConstructor` to be used with types without modes or args.+  ([#242](https://github.com/lsrcz/grisette/pull/242))++### Changed++- [Breaking] Changed the operand order for `liftPFormatPrec2` and+  `liftPFormatList2`. ([#225](https://github.com/lsrcz/grisette/pull/225))+- [Breaking] Changed the term representation with a compile-time tag for its+  kind (`AnyKind` for all symbols and `ConstantKind` for symbols other than+  uninterpreted functions). This also affects the 'ExtractSym'. A new+  `extractSymMaybe` will regard this tag if not all symbols can be casted to+  that tag. `extractSym` will always succeed, returning a set with `AnyKind`.+  ([#230](https://github.com/lsrcz/grisette/pull/230))+- [Breaking] `SafeDivision` renamed to `SafeDiv`.+  ([#231](https://github.com/lsrcz/grisette/pull/231))+- Refined the template-haskell-based derivation mechanism.+  ([#238](https://github.com/lsrcz/grisette/pull/238))+- [Breaking] `GetData` is made injective by giving `Identity` wrapped type for+  concrete evaluation instead of the type itself.+  ([#242](https://github.com/lsrcz/grisette/pull/242))+- Changed pprint for `Identity` to not to print the constructor.+  ([#242](https://github.com/lsrcz/grisette/pull/242))+- Make `ToSym` requires the target type to be `Mergeable`. This enable us to+  merge the results for converting from `Union a` to `Union b` again.+  ([#244](https://github.com/lsrcz/grisette/pull/244))++### Removed++- Removed `fpMin` and `fpMax`, which is removed in IEEE754-2019.+  ([#235](https://github.com/lsrcz/grisette/pull/235))+- Dropped support for post-evaluation approximation.+  ([#241](https://github.com/lsrcz/grisette/pull/241))++## [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`.+  ([#203](https://github.com/lsrcz/grisette/pull/203))+- Added pretty printing for hashset and hashmaps.+  ([#205](https://github.com/lsrcz/grisette/pull/205))+- Added support for refinement of solutions in CEGIS algorithm.+  ([#206](https://github.com/lsrcz/grisette/pull/206))+- Added generation of globally unique identifier with `uniqueIdentifier`.+  ([#206](https://github.com/lsrcz/grisette/pull/206))+- Added support for arbitrary precision floating point theory.+  ([#207](https://github.com/lsrcz/grisette/pull/207))++### Fixed++- `withSolver` now forcifully terminate the solver when exiting the scope.+  ([#199](https://github.com/lsrcz/grisette/pull/199))+- Fixed pretty printing for monad transformers.+  ([#205](https://github.com/lsrcz/grisette/pull/205))++### Changed++- [Breaking] Equality test for `SomeBV` with different bit widths will now+  return false rather than crash.+  ([#200](https://github.com/lsrcz/grisette/pull/200))+- [Breaking] More intuitive CEGIS interface.+  ([#201](https://github.com/lsrcz/grisette/pull/201))+- [Breaking] Changed the low-level solver interface.+  ([#206](https://github.com/lsrcz/grisette/pull/206))+- [Breaking] Changed the CEGIS interface.+  ([#206](https://github.com/lsrcz/grisette/pull/206))+- Bumped the minimum supported sbv version to 8.17.+  ([#207](https://github.com/lsrcz/grisette/pull/207))++## [0.5.0.1] -- 2024-04-18++### Fixed++- Fix an building error due to a GHC 9.8.1 regression+  (https://gitlab.haskell.org/ghc/ghc/-/issues/24084).+  ([#195](https://github.com/lsrcz/grisette/pull/195))++## [0.5.0.0] -- 2024-04-18++### Added++- Added the creation of unparameterized bit vectors from run-time bit-widths.+  ([#168](https://github.com/lsrcz/grisette/pull/168),+  [#177](https://github.com/lsrcz/grisette/pull/177))+- Added all the functions available for the exception transformer in+  `transformers` and `mtl` packages.+  ([#171](https://github.com/lsrcz/grisette/pull/171))+- Improved the partial evaluation for bit vectors.+  ([#176](https://github.com/lsrcz/grisette/pull/176))+- Added `symRotateNegated` and `symShiftNegated`.+  ([#181](https://github.com/lsrcz/grisette/pull/181))+- Added `mrg` and `sym` variants for all reasonable operations from+  `Control.Monad`, `Control.Applicative`, `Data.Foldable`, `Data.List`, and+  `Data.Traversable`. ([#182](https://github.com/lsrcz/grisette/pull/182))+- Added `mrgIfPropagatedStrategy`.+  ([#184](https://github.com/lsrcz/grisette/pull/184))+- Added `freshString`. ([#188](https://github.com/lsrcz/grisette/pull/188))+- Added `localFreshIdent`. ([#190](https://github.com/lsrcz/grisette/pull/190))+- Added deriving for void types for builtin type classes.+  ([#191](https://github.com/lsrcz/grisette/pull/191))++### Fixed++- Fixed the merging for safe division.+  ([#173](https://github.com/lsrcz/grisette/pull/173))+- Fixed the behavior for safe `mod` and `rem` for signed, bounded concrete+  types. ([#173](https://github.com/lsrcz/grisette/pull/173))+- Fixed merging in `mrg*` operations for monad transformers to ensure that they+  merge the results. ([#187](https://github.com/lsrcz/grisette/pull/187))++### Changed++- [Breaking] Removed the `UnionLike` and `UnionPrjOp` interface, added the+  `TryMerge` and `PlainUnion` interface. This allows `mrg*` operations to be+  used with non-union programs.+  ([#170](https://github.com/lsrcz/grisette/pull/170))+- [Breaking] Refined the safe operations interface using `TryMerge`.+  ([#172](https://github.com/lsrcz/grisette/pull/172))+- [Breaking] Renamed `safeMinus` to `safeSub` to be more consistent.+  ([#172](https://github.com/lsrcz/grisette/pull/172))+- [Breaking] Unifies the implementation for all symbolic non-indexed+  bit-vectors. The legacy types are now type and pattern synonyms.+  ([#174](https://github.com/lsrcz/grisette/pull/174),+  [#179](https://github.com/lsrcz/grisette/pull/179),+  [#180](https://github.com/lsrcz/grisette/pull/180))+- [Breaking] Use functional dependency instead of type family for the `Function`+  class. ([#178](https://github.com/lsrcz/grisette/pull/178))+- [Breaking] Added `Mergeable` constraints to some `mrg*` list operators+  ([#182](https://github.com/lsrcz/grisette/pull/182))+- [Breaking] Refactored the `mrg*` constructor related template haskell code.+  ([#185](https://github.com/lsrcz/grisette/pull/185))+- [Breaking] Dropped symbols with extra information.+  ([#188](https://github.com/lsrcz/grisette/pull/188))+- [Breaking] The `FreshIdent` is removed. It is now changed to `Identifier` and+  `Symbol` types. ([#192](https://github.com/lsrcz/grisette/pull/192))+- Changed the internal representation of the terms.+  ([#193](https://github.com/lsrcz/grisette/pull/193))+- [Breaking] Refactored the project structures.+  ([#194](https://github.com/lsrcz/grisette/pull/194))+ ## [0.4.1.0] -- 2024-01-10  ### Added -- Added `cegisForAll` interfaces. ([#165])(https://github.com/lsrcz/grisette/pull/165)+- Added `cegisForAll` interfaces.+  ([#165](https://github.com/lsrcz/grisette/pull/165))  ## [0.4.0.0] -- 2024-01-08  ### Added -- Added wrappers for state transformers. ([#132](https://github.com/lsrcz/grisette/pull/132))-- Added `toGuardList` function. ([#137](https://github.com/lsrcz/grisette/pull/137))-- Exported some previously hidden API (`BVSignConversion`, `runFreshTFromIndex`) that we found useful or forgot to export. ([#138](https://github.com/lsrcz/grisette/pull/138), [#139](https://github.com/lsrcz/grisette/pull/139))-- Provided `mrgRunFreshT` to run `FreshT` with merging. ([#140](https://github.com/lsrcz/grisette/pull/140))-- Added `Grisette.Data.Class.SignConversion.SignConversion` for types from `Data.Int` and `Data.Word`. ([#142](https://github.com/lsrcz/grisette/pull/142))-- Added shift functions by symbolic shift amounts. ([#151](https://github.com/lsrcz/grisette/pull/151))-- Added `apply` for uninterpreted functions. ([#155](https://github.com/lsrcz/grisette/pull/155))-- Added `liftFresh` to lift a `Fresh` into `MonadFresh`. ([#156](https://github.com/lsrcz/grisette/pull/156))-- Added a handle types for SBV solvers. This allows users to use SBV solvers without the need to wrap everything in the SBV monads. ([#159](https://github.com/lsrcz/grisette/pull/159))-- Added a new generic CEGIS interface. This allows any verifier/fuzzer to be used in the CEGIS loop. ([#159](https://github.com/lsrcz/grisette/pull/159))+- Added wrappers for state transformers.+  ([#132](https://github.com/lsrcz/grisette/pull/132))+- Added `toGuardList` function.+  ([#137](https://github.com/lsrcz/grisette/pull/137))+- Exported some previously hidden API (`BVSignConversion`, `runFreshTFromIndex`)+  that we found useful or forgot to export.+  ([#138](https://github.com/lsrcz/grisette/pull/138),+  [#139](https://github.com/lsrcz/grisette/pull/139))+- Provided `mrgRunFreshT` to run `FreshT` with merging.+  ([#140](https://github.com/lsrcz/grisette/pull/140))+- Added `Grisette.Data.Class.SignConversion.SignConversion` for types from+  `Data.Int` and `Data.Word`.+  ([#142](https://github.com/lsrcz/grisette/pull/142))+- Added shift functions by symbolic shift amounts.+  ([#151](https://github.com/lsrcz/grisette/pull/151))+- Added `apply` for uninterpreted functions.+  ([#155](https://github.com/lsrcz/grisette/pull/155))+- Added `liftFresh` to lift a `Fresh` into `MonadFresh`.+  ([#156](https://github.com/lsrcz/grisette/pull/156))+- Added a handle types for SBV solvers. This allows users to use SBV solvers+  without the need to wrap everything in the SBV monads.+  ([#159](https://github.com/lsrcz/grisette/pull/159))+- Added a new generic CEGIS interface. This allows any verifier/fuzzer to be+  used in the CEGIS loop. ([#159](https://github.com/lsrcz/grisette/pull/159))  ### Removed -- [Breaking] Removed the `Grisette.Lib.Mtl` module. ([#132](https://github.com/lsrcz/grisette/pull/132))-- [Breaking] Removed `SymBoolOp` and `SymIntegerOp`. ([#146](https://github.com/lsrcz/grisette/pull/146))-- [Breaking] Removed `ExtractSymbolics` instance for `SymbolSet`. ([#146](https://github.com/lsrcz/grisette/pull/146))+- [Breaking] Removed the `Grisette.Lib.Mtl` module.+  ([#132](https://github.com/lsrcz/grisette/pull/132))+- [Breaking] Removed `SymBoolOp` and `SymIntegerOp`.+  ([#146](https://github.com/lsrcz/grisette/pull/146))+- [Breaking] Removed `ExtractSymbolics` instance for `SymbolSet`.+  ([#146](https://github.com/lsrcz/grisette/pull/146))  ### Fixed -- Removed the quotation marks around the pretty printed results for string-like data types. ([#127](https://github.com/lsrcz/grisette/pull/127))-- Fixed the `SOrd` instance for `VerificationConditions`. ([#131](https://github.com/lsrcz/grisette/pull/131))-- Fixed the missing `SubstituteSym` instance for `UnionM`. ([#131](https://github.com/lsrcz/grisette/pull/131))-- Fixed the symbolic generation order for `Maybe`. ([#131](https://github.com/lsrcz/grisette/pull/131))-- Fixed the `toInteger` function for `IntN 1`. ([#143](https://github.com/lsrcz/grisette/pull/143))-- Fixed the `abs` function for `WordN`. ([#144](https://github.com/lsrcz/grisette/pull/143))-- Fixed the QuickCheck shrink function for `WordN 1` and `IntN 1`. ([#149](https://github.com/lsrcz/grisette/pull/149))-- Fixed the heap overflow bug for `shiftL` for `WordN` and `IntN` by large numbers. ([#150](https://github.com/lsrcz/grisette/pull/150))+- Removed the quotation marks around the pretty printed results for string-like+  data types. ([#127](https://github.com/lsrcz/grisette/pull/127))+- Fixed the `SOrd` instance for `VerificationConditions`.+  ([#131](https://github.com/lsrcz/grisette/pull/131))+- Fixed the missing `SubstituteSym` instance for `UnionM`.+  ([#131](https://github.com/lsrcz/grisette/pull/131))+- Fixed the symbolic generation order for `Maybe`.+  ([#131](https://github.com/lsrcz/grisette/pull/131))+- Fixed the `toInteger` function for `IntN 1`.+  ([#143](https://github.com/lsrcz/grisette/pull/143))+- Fixed the `abs` function for `WordN`.+  ([#144](https://github.com/lsrcz/grisette/pull/143))+- Fixed the QuickCheck shrink function for `WordN 1` and `IntN 1`.+  ([#149](https://github.com/lsrcz/grisette/pull/149))+- Fixed the heap overflow bug for `shiftL` for `WordN` and `IntN` by large+  numbers. ([#150](https://github.com/lsrcz/grisette/pull/150))  ### Changed -- Reorganized the files for `MonadTrans`. ([#132](https://github.com/lsrcz/grisette/pull/132))-- [Breaking] Changed the name of `Union` constructors and patterns. ([#133](https://github.com/lsrcz/grisette/pull/133))-- The `Union` patterns, when used as constructors, now merges the result. ([#133](https://github.com/lsrcz/grisette/pull/133))-- Changed the symbolic identifier type from `String` to `Data.Text.Text`. ([#141](https://github.com/lsrcz/grisette/pull/141))-- [Breaking] `Grisette.Data.Class.BitVector.BVSignConversion` is now `Grisette.Data.Class.SignConversion.SignConversion`. ([#142](https://github.com/lsrcz/grisette/pull/142))-- [Breaking] Moved the `ITEOp`, `LogicalOp`, and `SEq` type classes to dedicated modules. ([#146](https://github.com/lsrcz/grisette/pull/146))-- [Breaking] Moved `Grisette.Data.Class.Evaluate` to `Grisette.Data.Class.EvaluateSym`. ([#146](https://github.com/lsrcz/grisette/pull/146))-- [Breaking] Moved `Grisette.Data.Class.Substitute` to `Grisette.Data.Class.SubstituteSym`. ([#146](https://github.com/lsrcz/grisette/pull/146))-- [Breaking] Split the `Grisette.Data.Class.SafeArith` module to `Grisette.Data.Class.SafeDivision` and `Grisette.Data.Class.SafeLinearArith`. ([#146](https://github.com/lsrcz/grisette/pull/146))-- [Breaking] Changed the API to `MonadFresh`. ([#156](https://github.com/lsrcz/grisette/pull/156))-- [Breaking] Renamed multiple symbolic operators. ([#158](https://github.com/lsrcz/grisette/pull/158))-- [Breaking] Changed the solver interface. ([#159](https://github.com/lsrcz/grisette/pull/159))-- [Breaking] Changed the CEGIS solver interface. ([#159](https://github.com/lsrcz/grisette/pull/159))+- Reorganized the files for `MonadTrans`.+  ([#132](https://github.com/lsrcz/grisette/pull/132))+- [Breaking] Changed the name of `Union` constructors and patterns.+  ([#133](https://github.com/lsrcz/grisette/pull/133))+- The `Union` patterns, when used as constructors, now merges the result.+  ([#133](https://github.com/lsrcz/grisette/pull/133))+- Changed the symbolic identifier type from `String` to `Data.Text.Text`.+  ([#141](https://github.com/lsrcz/grisette/pull/141))+- [Breaking] `Grisette.Data.Class.BitVector.BVSignConversion` is now+  `Grisette.Data.Class.SignConversion.SignConversion`.+  ([#142](https://github.com/lsrcz/grisette/pull/142))+- [Breaking] Moved the `ITEOp`, `LogicalOp`, and `SEq` type classes to dedicated+  modules. ([#146](https://github.com/lsrcz/grisette/pull/146))+- [Breaking] Moved `Grisette.Data.Class.Evaluate` to+  `Grisette.Data.Class.EvaluateSym`.+  ([#146](https://github.com/lsrcz/grisette/pull/146))+- [Breaking] Moved `Grisette.Data.Class.Substitute` to+  `Grisette.Data.Class.SubstituteSym`.+  ([#146](https://github.com/lsrcz/grisette/pull/146))+- [Breaking] Split the `Grisette.Data.Class.SafeArith` module to+  `Grisette.Data.Class.SafeDivision` and `Grisette.Data.Class.SafeLinearArith`.+  ([#146](https://github.com/lsrcz/grisette/pull/146))+- [Breaking] Changed the API to `MonadFresh`.+  ([#156](https://github.com/lsrcz/grisette/pull/156))+- [Breaking] Renamed multiple symbolic operators.+  ([#158](https://github.com/lsrcz/grisette/pull/158))+- [Breaking] Changed the solver interface.+  ([#159](https://github.com/lsrcz/grisette/pull/159))+- [Breaking] Changed the CEGIS solver interface.+  ([#159](https://github.com/lsrcz/grisette/pull/159))  ## [0.3.1.1] -- 2023-09-29 @@ -67,74 +541,119 @@  ### Added -- Added support to `Data.Text`. ([#95](https://github.com/lsrcz/grisette/pull/95))-- Added `Arbitrary` instances for bit vectors. ([#97](https://github.com/lsrcz/grisette/pull/97))-- Added pretty printers for Grisette data types. ([#101](https://github.com/lsrcz/grisette/pull/101))-- Added `ExtractSymbolics` instances for tuples longer than 2. ([#103](https://github.com/lsrcz/grisette/pull/103))+- Added support to `Data.Text`.+  ([#95](https://github.com/lsrcz/grisette/pull/95))+- Added `Arbitrary` instances for bit vectors.+  ([#97](https://github.com/lsrcz/grisette/pull/97))+- Added pretty printers for Grisette data types.+  ([#101](https://github.com/lsrcz/grisette/pull/101))+- Added `ExtractSymbolics` instances for tuples longer than 2.+  ([#103](https://github.com/lsrcz/grisette/pull/103))  ### Fixed -- Fixed the `Read` instance for bit vectors. ([#99](https://github.com/lsrcz/grisette/pull/99), [#100](https://github.com/lsrcz/grisette/pull/100))+- Fixed the `Read` instance for bit vectors.+  ([#99](https://github.com/lsrcz/grisette/pull/99),+  [#100](https://github.com/lsrcz/grisette/pull/100))  ## [0.3.0.0] -- 2023-07-07  ### Added -- Added the conversion between signed and unsigned bit vectors. ([#69](https://github.com/lsrcz/grisette/pull/69))-- Added the generation of `SomeSymIntN` and `SomeSymWordN` from a single `Int` for bit width. ([#73](https://github.com/lsrcz/grisette/pull/73))-- Added the `FiniteBits` instance for `SomeSymIntN` and `SomeSymWordN`. ([#83](https://github.com/lsrcz/grisette/pull/83))-- Added more flexible instances for symbolic generation for `Either`, `Maybe` and list types. ([#84](https://github.com/lsrcz/grisette/pull/84))-- Added an experimental `GenSymConstrained` type class. ([#89](https://github.com/lsrcz/grisette/pull/89))+- Added the conversion between signed and unsigned bit vectors.+  ([#69](https://github.com/lsrcz/grisette/pull/69))+- Added the generation of `SomeSymIntN` and `SomeSymWordN` from a single `Int`+  for bit width. ([#73](https://github.com/lsrcz/grisette/pull/73))+- Added the `FiniteBits` instance for `SomeSymIntN` and `SomeSymWordN`.+  ([#83](https://github.com/lsrcz/grisette/pull/83))+- Added more flexible instances for symbolic generation for `Either`, `Maybe`+  and list types. ([#84](https://github.com/lsrcz/grisette/pull/84))+- Added an experimental `GenSymConstrained` type class.+  ([#89](https://github.com/lsrcz/grisette/pull/89))  ### Changed -- Changed the operations for `SomeIntN` and `SomeWordN` to accepting dynamic runtime integers rather than compile-time integers. ([#71](https://github.com/lsrcz/grisette/pull/71))-- Comparing the equality of `SomeIntN`/`SomeWordN`/`SomeSymIntN`/`SomeSymWordN` with different bit widths returns false rather than crash now. ([#74](https://github.com/lsrcz/grisette/pull/74))+- Changed the operations for `SomeIntN` and `SomeWordN` to accepting dynamic+  runtime integers rather than compile-time integers.+  ([#71](https://github.com/lsrcz/grisette/pull/71))+- Comparing the equality of `SomeIntN`/`SomeWordN`/`SomeSymIntN`/`SomeSymWordN`+  with different bit widths returns false rather than crash now.+  ([#74](https://github.com/lsrcz/grisette/pull/74))  ### Fixed -- Fixed the compatibility issue with sbv 10+. ([#66](https://github.com/lsrcz/grisette/pull/66))-- Fixed build error with newer GHC. ([#70](https://github.com/lsrcz/grisette/pull/70))-- Fixed the merging for `SomeSymIntN` and `SomeSymWordN`. ([#72](https://github.com/lsrcz/grisette/pull/72))+- Fixed the compatibility issue with sbv 10+.+  ([#66](https://github.com/lsrcz/grisette/pull/66))+- Fixed build error with newer GHC.+  ([#70](https://github.com/lsrcz/grisette/pull/70))+- Fixed the merging for `SomeSymIntN` and `SomeSymWordN`.+  ([#72](https://github.com/lsrcz/grisette/pull/72)) -## [0.2.0.0] - 2023-04-13+## [0.2.0.0] -- 2023-04-13  ### Added -- Add term size count API. ([#48](https://github.com/lsrcz/grisette/pull/48), [#53](https://github.com/lsrcz/grisette/pull/53))-- Add timeout to solver interface. ([#49](https://github.com/lsrcz/grisette/pull/49), [#50](https://github.com/lsrcz/grisette/pull/50))-- Add parallel do-notation for parallel symbolic compilation. ([#51](https://github.com/lsrcz/grisette/pull/51))-- Added some missing instances for symbolic values and bit vectors. ([#46](https://github.com/lsrcz/grisette/pull/46), [#61](https://github.com/lsrcz/grisette/pull/61))-- Add missing instances for `MonadFresh` and `FreshT`. ([#59](https://github.com/lsrcz/grisette/pull/59))+- Add term size count API. ([#48](https://github.com/lsrcz/grisette/pull/48),+  [#53](https://github.com/lsrcz/grisette/pull/53))+- Add timeout to solver interface.+  ([#49](https://github.com/lsrcz/grisette/pull/49),+  [#50](https://github.com/lsrcz/grisette/pull/50))+- Add parallel do-notation for parallel symbolic compilation.+  ([#51](https://github.com/lsrcz/grisette/pull/51))+- Added some missing instances for symbolic values and bit vectors.+  ([#46](https://github.com/lsrcz/grisette/pull/46),+  [#61](https://github.com/lsrcz/grisette/pull/61))+- Add missing instances for `MonadFresh` and `FreshT`.+  ([#59](https://github.com/lsrcz/grisette/pull/59))  ### Changed -- New safe operator interfaces. ([#56](https://github.com/lsrcz/grisette/pull/56))+- New safe operator interfaces.+  ([#56](https://github.com/lsrcz/grisette/pull/56)) - Redesigned symbolic value interface.-  - `Sym Bool`/`Sym Integer`, etc., are no longer available and are replaced with `SymBool` and `SymInteger`. ([#41](https://github.com/lsrcz/grisette/pull/41))-  - New symbolic bit vector interface. Added unsized bit vector. ([#41](https://github.com/lsrcz/grisette/pull/41))+  - `Sym Bool`/`Sym Integer`, etc., are no longer available and are replaced+    with `SymBool` and `SymInteger`.+    ([#41](https://github.com/lsrcz/grisette/pull/41))+  - New symbolic bit vector interface. Added unsized bit vector.+    ([#41](https://github.com/lsrcz/grisette/pull/41))  ### Removed -- Dropped merging cache for `UnionM`. This fixed some segmentation fault errors. ([#43](https://github.com/lsrcz/grisette/pull/43))+- Dropped merging cache for `UnionM`. This fixed some segmentation fault errors.+  ([#43](https://github.com/lsrcz/grisette/pull/43))  ### Fixed -- Fix CEGIS when no symbolic input is present. ([#52](https://github.com/lsrcz/grisette/pull/52))-- Fix overlapping `ToSym` and `ToCon` instances. ([#54](https://github.com/lsrcz/grisette/pull/54))-- Fix uninterpreted function lowering. ([#57](https://github.com/lsrcz/grisette/pull/57), [#58](https://github.com/lsrcz/grisette/pull/58))-- Fix CEGIS crash when subsequent solver calls introduces new symbolic constant. ([#60](https://github.com/lsrcz/grisette/pull/60))+- Fix CEGIS when no symbolic input is present.+  ([#52](https://github.com/lsrcz/grisette/pull/52))+- Fix overlapping `ToSym` and `ToCon` instances.+  ([#54](https://github.com/lsrcz/grisette/pull/54))+- Fix uninterpreted function lowering.+  ([#57](https://github.com/lsrcz/grisette/pull/57),+  [#58](https://github.com/lsrcz/grisette/pull/58))+- Fix CEGIS crash when subsequent solver calls introduces new symbolic constant.+  ([#60](https://github.com/lsrcz/grisette/pull/60)) -## [0.1.0.0] - 2023-01-20+## [0.1.0.0] -- 2023-01-20  ### Added  - Initial release for Grisette. -[0.4.1.0]: https://github.com/lsrcz/grisette/compare/v0.4.1.0...v0.4.0.0-[0.4.0.0]: https://github.com/lsrcz/grisette/compare/v0.4.0.0...v0.3.1.0-[0.3.1.1]: https://github.com/lsrcz/grisette/compare/v0.3.1.0...v0.3.1.1-[0.3.1.0]: https://github.com/lsrcz/grisette/compare/v0.3.0.0...v0.3.1.0-[0.3.0.0]: https://github.com/lsrcz/grisette/compare/v0.2.0.0...v0.3.0.0-[0.2.0.0]: https://github.com/lsrcz/grisette/compare/v0.1.0.0...v0.2.0.0 [0.1.0.0]: https://github.com/lsrcz/grisette/tree/v0.1.0.0+[0.10.0.0]: https://github.com/lsrcz/grisette/compare/v0.9.0.0...v0.10.0.0+[0.11.0.0]: https://github.com/lsrcz/grisette/compare/v0.10.0.0...v0.11.0.0+[0.12.0.0]: https://github.com/lsrcz/grisette/compare/v0.11.0.0...v0.12.0.0+[0.13.0.0]: https://github.com/lsrcz/grisette/compare/v0.12.0.0...v0.13.0.0+[0.2.0.0]: https://github.com/lsrcz/grisette/compare/v0.1.0.0...v0.2.0.0+[0.3.0.0]: https://github.com/lsrcz/grisette/compare/v0.2.0.0...v0.3.0.0+[0.3.1.0]: https://github.com/lsrcz/grisette/compare/v0.3.0.0...v0.3.1.0+[0.3.1.1]: https://github.com/lsrcz/grisette/compare/v0.3.1.0...v0.3.1.1+[0.4.0.0]: https://github.com/lsrcz/grisette/compare/v0.3.1.1...v0.4.0.0+[0.4.1.0]: https://github.com/lsrcz/grisette/compare/v0.4.0.0...v0.4.1.0+[0.5.0.0]: https://github.com/lsrcz/grisette/compare/v0.4.1.0...v0.5.0.0+[0.5.0.1]: https://github.com/lsrcz/grisette/compare/v0.5.0.0...v0.5.0.1+[0.6.0.0]: https://github.com/lsrcz/grisette/compare/v0.5.0.1...v0.6.0.0+[0.7.0.0]: https://github.com/lsrcz/grisette/compare/v0.6.0.0...v0.7.0.0+[0.8.0.0]: https://github.com/lsrcz/grisette/compare/v0.7.0.0...v0.8.0.0+[0.9.0.0]: https://github.com/lsrcz/grisette/compare/v0.8.0.0...v0.9.0.0
LICENSE view
@@ -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.
README.md view
@@ -1,31 +1,33 @@ # Grisette  [![Haskell Tests](https://github.com/lsrcz/grisette/actions/workflows/test.yml/badge.svg)](https://github.com/lsrcz/grisette/actions/workflows/test.yml)+[![Hackage Version](https://img.shields.io/hackage/v/grisette)](https://hackage.haskell.org/package/grisette) -Grisette is a symbolic evaluation library for Haskell. By translating-programs into constraints, Grisette can help the development of program-reasoning tools, including verification and synthesis.+Grisette is a symbolic evaluation library for Haskell. By translating programs+into SMT constraints, Grisette can help the development of program reasoning+tools, including verification and synthesis.  For a detailed description of the system, please refer to our POPL'23 paper [Grisette: Symbolic Compilation as a Functional Programming Library](https://lsrcz.github.io/files/POPL23.pdf). -## Features--- **Multi-path** symbolic evaluation with efficient (customizable) state merging.-- Symbolic evaluation is **purely functional**. The propagated symbolic value includes the assertion / error state of the execution, yet it is just a data structure. As a result, Grisette is a library that does not modify the Haskell compiler.-- The separation of symbolic and concrete values is enforced with **static types**. These types help discover opportunities for partial evaluation as well as safe use of Haskell libraries.- ## Design and Benefits -- Modular purely functional design, with a focus on composability.+- **Separate the concern** of problem modeling and symbolic compilation. Users+  only need to focus on modeling the problem and write interpreters, and the+  symbolic compilation algorithms are provided by Grisette.+- **Supports rich theories** including booleans, uninterpreted functions,+  bitvectors, integers, real numbers, and floating points.+- **Multi-path symbolic evaluation** with efficient state merging, suitable for+  whole program verification, program synthesis, and other symbolic reasoning+  tasks.+- **Modular purely functional design**, with a focus on composability.+  - Use our familiar Haskell facilities like `Either` to maintain exceptions+    (e.g., assertions and assumptions).   - Allows for symbolic evaluation of user-defined data structures / data     structures from third-party libraries.-  - Allows for symbolic evaluation of error-handling code with user-defined-    error types.-  - Allows for memoization (tested and benchmarked) / parallelization (not-    tested and benchmarked yet) of symbolic evaluation.-- Core multi-path symbolic evaluation semantics modeled as a monad, allowing for-  easy integration with other monadic effects, for example:+  - Allows for memoization / parallelization of symbolic evaluation.+- **Core multi-path symbolic evaluation semantics modeled as a monad**, allowing+  for easy integration with other monadic effects, for example:   - error handling via `ExceptT`,   - stateful computation via `StateT`,   - unstructured control flow via `ContT`, etc.@@ -34,38 +36,50 @@  ### Install Grisette -Grisette is available via-[Hackage](https://hackage.haskell.org/package/grisette). You can add it to your-project with `cabal`, and we also provided a stack template for quickly starting a-new project with Grisette.+Grisette is available on [Hackage](https://hackage.haskell.org/package/grisette)+and Stackage. You can add it to your project with `cabal`, and we also provided+a stack template for quickly starting a new project with Grisette.  #### Manually writing cabal file -Grisette is a library and is usually used as a dependency of other-packages. You can add it to your project's `.cabal` file:+Grisette is a library and is usually used as a dependency of other packages. You+can add it to your project's `.cabal` file:  ```cabal library   ...-  build-depends: grisette >= 0.4.1 < 0.5+  build-depends: grisette >= 0.13 < 0.14 ``` -#### Quick start template with `stack new`+#### Using stack -You can quickly start an stack-based Grisette project with `stack new`:+Note: Grisette on Stackage is currently outdated. Please make sure to use+`extra-deps` to get the latest version of Grisette from stackage. In your+`stack.yaml` file, add: -```bash-$ stack new <projectname> github:lsrcz/grisette+```yaml+extra-deps:+  - grisette-0.13.0.1 ``` -You can specify the resolver version with the parameters:+and in your `package.yaml` file: +```yaml+dependencies:+  - grisette >= 0.13.0.1 < 0.14+```++#### Quick start template with `stack new`++You can quickly start an stack-based Grisette project with `stack new`:+ ```bash-$ stack new a-new-project github:lsrcz/grisette -p "resolver:lts-19.33"+$ stack new <projectname> github:lsrcz/grisette ```  For more details, please see the-[template file](https://github.com/lsrcz/stack-templates/blob/main/grisette.hsfiles) and the+[template file](https://github.com/lsrcz/stack-templates/blob/main/grisette.hsfiles)+and the [documentation for stack templates](https://docs.haskellstack.org/en/stable/templates_command/).  You can test your installation by running the following command:@@ -79,12 +93,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 @@ -104,150 +118,238 @@ 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-post](https://www.cs.utexas.edu/~bornholt/post/building-synthesizer.html) by-James Bornholt.+The following example uses Grisette to build a symbolic domain-specific language+for boolean and integer expressions. -The example has three parts:+We will -- 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.+- define the *syntax* and *semantics* of an arithmetic language, and+- build a *verifier* to check if a given arithmetic expression is equivalent to+  another, and+- build a *synthesizer* to find an arithmetic expression that is equivalent to a+  given expression. -### Defining the Arithmetic Language+### Defining the Syntax -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:+Our language is a simple boolean and integer expression language, following the+grammar: +```haskell+Expr -> IntExpr | BoolExpr+IntExpr -> IntVal int+         | Add IntExpr IntExpr+         | Mul IntExpr IntExpr+BoolExpr -> BoolVal bool+          | BAnd BoolExpr BoolExpr+          | BOr BoolExpr BoolExpr+          | Eq Expr Expr ```-E -> c      -- constant-   | x      -- value for input variable-   | E + E  -- addition-   | E * E  -- multiplication++A symbolic expression can be represented in Grisette as a GADT as follows. In+the GADT,++- `SymInteger` and `SymBool` are symbolic (primitive) types, and they represent+  SMT terms of integer and boolean theories, respectively.+- `Union` represents choices of symbolic expressions, and we introduce it to+  represent program spaces and allow the synthesizer to choose operands from+  different symbolic expressions.+- `BasicSymPrim` is a constraint that contains all the symbolic primitive types+  that Grisette supports, including `SymInteger` and `SymBool`.++```haskell+data Expr a where+  IntVal :: SymInteger -> IntExpr+  BoolVal :: SymBool -> BoolExpr+  Add :: IntUExpr -> IntUExpr -> IntExpr+  Mul :: IntUExpr -> IntUExpr -> IntExpr+  BAnd :: BoolUExpr -> BoolUExpr -> BoolExpr+  BOr :: BoolUExpr -> BoolUExpr -> BoolExpr+  Eq :: (BasicSymPrim a) => UExpr a -> UExpr a -> BoolExpr++type IntExpr = Expr SymInteger+type BoolExpr = Expr SymBool+type UExpr a = Union (Expr a)+type IntUExpr = UExpr SymInteger+type BoolUExpr = UExpr SymBool ``` -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 GADT works well with Grisette, we need to derive some instances and+get some smart constructors: -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.+- `deriveGADT` provides instances for data types that are frequently used with+  or provided by Grisette. See the+  [documentation](https://hackage.haskell.org/package/grisette/docs/Grisette-TH.html)+  for the details on what instances are provided.+- `makeSmartCtor` generates smart constructors for the GADT.  ```haskell-data SExpr-  -- `SConst` 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.-  ---  -- The children are **sets** of symbolic programs. Here `UnionM`s are such-  -- sets.-  ---  -- 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`.-  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 instance Show (Expr a)+deriveGADT [''Expr] basicClasses0+makeSmartCtor ''Expr --- A template haskell procedure to help the construction of `SExpr` sets.------ >>> SConst 1 :: SExpr--- SConst 1--- >>> mrgSConst 1 :: UnionM SExpr--- UMrg (Single (SConst 1))-$(makeUnionWrapper "mrg" ''SExpr)+> intVal 1 :: IntUExpr -- smart constructor for IntVal in Unions+{IntVal 1}+-- Add takes two IntUExprs, use the smart constructors+> Add (intVal "a") (intVal 1)+Add {IntVal a} {IntVal 1} ``` -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`.+The introduction of `Union` allows us to represent choices of expressions, and+the following code chooses between `a + 2` or `a * 2`. A synthesizer can then+pick true or false for the `choice` variable to decide which expression to pick.+If the synthesizer picks true, the result is `a + 2`; otherwise, it is `a * 2`.  ```haskell-space :: SymInteger -> SExpr-space x = SPlus-  (mrgSInput x)-  (mrgIf "choice" (mrgSInput x) (mrgSConst "c"))+add2 = add (intVal "a") (intVal 2)+mul2 = mul (intVal "a") (intVal 2)+> mrgIf "choice" add2 mul2 :: IntUExpr+{If choice {Add {IntVal a} {IntVal 2}} {Mul {IntVal a} {IntVal 2}}} ``` -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.+### Defining the Semantics +The semantics of the expressions can be defined by the following interpreter.+Grisette provides various combinators for working with symbolic values. In the+interpreter, the `.#` operator is very important. It conceptually++- extracts all the choices from the `Union` container,+- apply the `eval` function to each choice, and+- merge the results into a single value.+ ```haskell-interpret :: SExpr -> SymInteger-interpret (SInt x) = x-interpret (SPlus x y) = interpretU x + interpretU y-interpret (SMul x y) = interpretU x * interpretU y+eval :: Expr a -> a+eval (IntVal a) = a+eval (BoolVal a) = a+eval (Add a b) = eval .# a + eval .# b+eval (Mul a b) = eval .# a * eval .# b+eval (BAnd a b) = eval .# a .&& eval .# b+eval (BOr a b) = eval .# a .|| eval .# b+eval (Eq a b) = eval .# a .== eval .# b+``` --- interpet a set of programs-interpretU :: UnionM SExpr -> SymInteger-interpretU = onUnion interpret+There are other operators like `.==`, `.&&`, `.||`, etc. These operators are+provided by Grisette and have symbolic semantics. They construct constraints+instead of evaluating to a concrete value.++We may also write `eval` with do-notations as `Union` is a monad. Please refer+to the [tutorials](tutorials) for more details.++### Get a verifier++With the syntax and semantics defined, we can build a verifier to check if two+expressions are equivalent. This can be done by checking if there exists a+counter-example that falsifies the equivalence of the two expressions.++In the following code, we verify that $a+b$ and $b+a$ are equivalent, as there+does not exist a counter-example that makes the two expressions evaluate to+different values.++```haskell+aPlusB = Add (intVal "a") (intVal "b")+bPlusA = Add (intVal "b") (intVal "a")+aPlusA = Add (intVal "a") (intVal "a")++> solve z3 $ eval aPlusB ./= eval bPlusA+Left Unsat ``` -And we can compose the interpreter with the program space to get it executable.+In the following code, we verify that $a+b$ and $a+a$ are not equivalent, as+there exists a counter-example that makes the two expressions evaluate to+different values. The counter-example is $a=0$, $b=1$, such that $a+b=1$ and+$a+a=0$.  ```haskell-executableSpace :: Integer -> SymInteger-executableSpace = interpret . space . toSym+> solve z3 $ eval aPlusB ./= eval aPlusA+Right (Model {a -> 0 :: Integer, b -> 1 :: Integer}) ``` -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.+### Get a synthesizer -We can then use the model to evaluate the program space, and get the synthesized program.+We can also build a synthesizer using the built-in CEGIS algorithm in Grisette.+Given a target expression, we can synthesize an expression using a sketch with+"symbolic holes" that is equivalent to the target expression. +In the following code, we synthesize an expression that is equivalent to $a+a$+using a sketch with a "symbolic hole" $c$. The `cegisForAll` function treats all+the variables in the sketch but not in the target expression as holes to fill+in.+ ```haskell-example :: IO ()-example = do-  Right model <- solve (UnboundedReasoning z3) $ executableSpace 2 ==~ 5-  print $ evaluateSym False model (space "x")-  -- result: SPlus {SInput x} {SConst 3}-  let synthesizedProgram :: Integer -> Integer =-        evaluateSymToCon model . executableSpace-  print $ synthesizedProgram 10-  -- result: 13+target = Add (intVal "a") (intVal "a")+sketch = Mul (intVal "a") (intVal "c")++> cegisForAll z3 target $ cegisPostCond $ eval target .== eval sketch+([],CEGISSuccess (Model {c -> 2 :: Integer})) ``` -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 -- Haddock documentation at [grisette](https://hackage.haskell.org/package/grisette).-- Grisette essentials (WIP).-- Grisette tutorials (WIP).+- Haddock documentation: [HEAD version](https://lsrcz.github.io/grisette),+  [release version on Hackage](https://hackage.haskell.org/package/grisette).+- A tutorial to Grisette is in the [tutorials](tutorials) directory. They are+  provided as jupyter notebooks with the+  [IHaskell](https://github.com/IHaskell/IHaskell) kernel.  ## License  The Grisette library is distributed under the terms of the BSD3 license. The [LICENSE](LICENSE) file contains the full license text.++## Note++Grisette is fully compatible with GHC 9.6+, and works in most cases with GHC+8.10+.++### CLC proposal #10++As the type classes provided by Grisette implements+[CLC proposal #10](https://github.com/haskell/core-libraries-committee/issues/10),+which requires `base-4.18.0.0` to work reliably, Grisette is fully compatible+with GHC 9.6. You may experience instance resolution failure when using older+GHCs in the client code (Grisette itself is buildable against GHC 8.10+ with+some tricks).++### Quantifiers++Grisette currently supports universal and existential quantifiers $\\forall$ and+$\\exists$, but only when building with sbv >= 10.1. This also means that you+need to use GHC >= 9.2.++### 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.++### `AsKey1` wrapper for `Union`++To use term equality based comparison for `Union`, we may use the `AsKey1`+wrapper. For the same reason as unified interfaces, it cannot be used with GHC+9.0 or earlier.  ## Citing Grisette
doctest/Main.hs view
@@ -1,9 +1,34 @@ module Main (main) where -import System.FilePath.Glob (glob) import Test.DocTest (doctest)  main :: IO () main = do-  core <- glob "src/**/*.hs"-  doctest core+  doctest+    [ "-isrc",+      "--fast",+      "-XBinaryLiterals",+      "-XDataKinds",+      "-XDeriveAnyClass",+      "-XDeriveGeneric",+      "-XDeriveLift",+      "-XDerivingStrategies",+      "-XDerivingVia",+      "-XFlexibleContexts",+      "-XFlexibleInstances",+      "-XFunctionalDependencies",+      "-XLambdaCase",+      "-XMonoLocalBinds",+      "-XMultiParamTypeClasses",+      "-XOverloadedStrings",+      "-XScopedTypeVariables",+      "-XStandaloneDeriving",+      "-XTemplateHaskell",+      "-XTypeApplications",+      "-XTypeOperators",+      "-XUndecidableInstances",+      "-Wno-unrecognised-warning-flags",+      "-Wno-x-partial",+      "-Wno-deriving-defaults",+      "src"+    ]
grisette.cabal view
@@ -1,20 +1,28 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.36.0.+-- This file has been generated from package.yaml by hpack version 0.37.0. -- -- see: https://github.com/sol/hpack  name:           grisette-version:        0.4.1.0+version:        0.13.0.1 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@@ -29,7 +37,10 @@   , GHC == 9.0.2   , GHC == 9.2.8   , GHC == 9.4.8-  , GHC == 9.6.3+  , GHC == 9.6.6+  , GHC == 9.8.4+  , GHC == 9.10.2+  , GHC == 9.12.2 extra-source-files:     CHANGELOG.md     README.md@@ -46,126 +57,296 @@ library   exposed-modules:       Grisette-      Grisette.Backend.SBV-      Grisette.Backend.SBV.Data.SMT.Lowering-      Grisette.Backend.SBV.Data.SMT.Solving-      Grisette.Backend.SBV.Data.SMT.SymBiMap+      Grisette.Backend       Grisette.Core-      Grisette.Core.BuiltinUnionWrappers-      Grisette.Core.Control.Exception-      Grisette.Core.Control.Monad.CBMCExcept-      Grisette.Core.Control.Monad.Class.MonadParallelUnion-      Grisette.Core.Control.Monad.Union-      Grisette.Core.Control.Monad.UnionM-      Grisette.Core.Data.BV-      Grisette.Core.Data.Class.BitVector-      Grisette.Core.Data.Class.CEGISSolver-      Grisette.Core.Data.Class.Error-      Grisette.Core.Data.Class.EvaluateSym-      Grisette.Core.Data.Class.ExtractSymbolics-      Grisette.Core.Data.Class.Function-      Grisette.Core.Data.Class.GenSym-      Grisette.Core.Data.Class.GPretty-      Grisette.Core.Data.Class.ITEOp-      Grisette.Core.Data.Class.LogicalOp-      Grisette.Core.Data.Class.Mergeable-      Grisette.Core.Data.Class.ModelOps-      Grisette.Core.Data.Class.SafeDivision-      Grisette.Core.Data.Class.SafeLinearArith-      Grisette.Core.Data.Class.SafeSymRotate-      Grisette.Core.Data.Class.SafeSymShift-      Grisette.Core.Data.Class.SEq-      Grisette.Core.Data.Class.SignConversion-      Grisette.Core.Data.Class.SimpleMergeable-      Grisette.Core.Data.Class.Solvable-      Grisette.Core.Data.Class.Solver-      Grisette.Core.Data.Class.SOrd-      Grisette.Core.Data.Class.SubstituteSym-      Grisette.Core.Data.Class.SymRotate-      Grisette.Core.Data.Class.SymShift-      Grisette.Core.Data.Class.ToCon-      Grisette.Core.Data.Class.ToSym-      Grisette.Core.Data.FileLocation-      Grisette.Core.Data.MemoUtils-      Grisette.Core.Data.Union-      Grisette.Core.TH-      Grisette.Core.THCompat       Grisette.Experimental       Grisette.Experimental.GenSymConstrained-      Grisette.Internal.Backend.SBV-      Grisette.Internal.Core-      Grisette.Internal.IR.SymPrim-      Grisette.IR.SymPrim-      Grisette.IR.SymPrim.Data.IntBitwidth-      Grisette.IR.SymPrim.Data.Prim.Helpers-      Grisette.IR.SymPrim.Data.Prim.InternedTerm.Caches-      Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors-      Grisette.IR.SymPrim.Data.Prim.InternedTerm.SomeTerm-      Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term-      Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermSubstitution-      Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermUtils-      Grisette.IR.SymPrim.Data.Prim.Model-      Grisette.IR.SymPrim.Data.Prim.ModelValue-      Grisette.IR.SymPrim.Data.Prim.PartialEval.Bits-      Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool-      Grisette.IR.SymPrim.Data.Prim.PartialEval.BV-      Grisette.IR.SymPrim.Data.Prim.PartialEval.GeneralFun-      Grisette.IR.SymPrim.Data.Prim.PartialEval.Integral-      Grisette.IR.SymPrim.Data.Prim.PartialEval.Num-      Grisette.IR.SymPrim.Data.Prim.PartialEval.PartialEval-      Grisette.IR.SymPrim.Data.Prim.PartialEval.TabularFun-      Grisette.IR.SymPrim.Data.Prim.PartialEval.Unfold-      Grisette.IR.SymPrim.Data.Prim.Utils-      Grisette.IR.SymPrim.Data.SymPrim-      Grisette.IR.SymPrim.Data.TabularFun+      Grisette.Experimental.MonadParallelUnion+      Grisette.Experimental.Qualified.ParallelUnionDo+      Grisette.Internal.Backend.QuantifiedStack+      Grisette.Internal.Backend.Solving+      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.Data.Class.AsKey+      Grisette.Internal.Core.Data.Class.BitCast+      Grisette.Internal.Core.Data.Class.BitVector+      Grisette.Internal.Core.Data.Class.CEGISSolver+      Grisette.Internal.Core.Data.Class.Concrete+      Grisette.Internal.Core.Data.Class.Error+      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.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.PPrint+      Grisette.Internal.Core.Data.Class.SafeBitCast+      Grisette.Internal.Core.Data.Class.SafeDiv+      Grisette.Internal.Core.Data.Class.SafeFdiv+      Grisette.Internal.Core.Data.Class.SafeFromFP+      Grisette.Internal.Core.Data.Class.SafeLinearArith+      Grisette.Internal.Core.Data.Class.SafeLogBase+      Grisette.Internal.Core.Data.Class.SafeSymRotate+      Grisette.Internal.Core.Data.Class.SafeSymShift+      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.SubstSym+      Grisette.Internal.Core.Data.Class.SymEq+      Grisette.Internal.Core.Data.Class.SymFiniteBits+      Grisette.Internal.Core.Data.Class.SymFromIntegral+      Grisette.Internal.Core.Data.Class.SymIEEEFP+      Grisette.Internal.Core.Data.Class.SymOrd+      Grisette.Internal.Core.Data.Class.SymRotate+      Grisette.Internal.Core.Data.Class.SymShift+      Grisette.Internal.Core.Data.Class.ToCon+      Grisette.Internal.Core.Data.Class.ToSym+      Grisette.Internal.Core.Data.Class.TryMerge+      Grisette.Internal.Core.Data.Class.UnionView+      Grisette.Internal.Core.Data.MemoUtils+      Grisette.Internal.Core.Data.SExpr+      Grisette.Internal.Core.Data.Symbol+      Grisette.Internal.Core.Data.UnionBase+      Grisette.Internal.SymPrim.AlgReal+      Grisette.Internal.SymPrim.AllSyms+      Grisette.Internal.SymPrim.BV+      Grisette.Internal.SymPrim.FP+      Grisette.Internal.SymPrim.FunInstanceGen+      Grisette.Internal.SymPrim.GeneralFun+      Grisette.Internal.SymPrim.IntBitwidth+      Grisette.Internal.SymPrim.ModelRep+      Grisette.Internal.SymPrim.Prim.Internal.Caches+      Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalBitCastTerm+      Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalDivModIntegralTerm+      Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalFloatingTerm+      Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalFP+      Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalFractionalTerm+      Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalFromIntegralTerm+      Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalIEEEFPConvertibleTerm+      Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalNumTerm+      Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalOrdTerm+      Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalRotateTerm+      Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalShiftTerm+      Grisette.Internal.SymPrim.Prim.Internal.PartialEval+      Grisette.Internal.SymPrim.Prim.Internal.Serialize+      Grisette.Internal.SymPrim.Prim.Internal.Term+      Grisette.Internal.SymPrim.Prim.Internal.Unfold+      Grisette.Internal.SymPrim.Prim.Internal.Utils+      Grisette.Internal.SymPrim.Prim.Model+      Grisette.Internal.SymPrim.Prim.Pattern+      Grisette.Internal.SymPrim.Prim.SomeTerm+      Grisette.Internal.SymPrim.Prim.Term+      Grisette.Internal.SymPrim.Prim.TermUtils+      Grisette.Internal.SymPrim.Quantifier+      Grisette.Internal.SymPrim.SomeBV+      Grisette.Internal.SymPrim.SymAlgReal+      Grisette.Internal.SymPrim.SymBool+      Grisette.Internal.SymPrim.SymBV+      Grisette.Internal.SymPrim.SymFP+      Grisette.Internal.SymPrim.SymGeneralFun+      Grisette.Internal.SymPrim.SymInteger+      Grisette.Internal.SymPrim.SymPrim+      Grisette.Internal.SymPrim.SymTabularFun+      Grisette.Internal.SymPrim.TabularFun+      Grisette.Internal.TH.ADT+      Grisette.Internal.TH.Ctor.Common+      Grisette.Internal.TH.Ctor.SmartConstructor+      Grisette.Internal.TH.Ctor.UnifiedConstructor+      Grisette.Internal.TH.Derivation.BinaryOpCommon+      Grisette.Internal.TH.Derivation.Common+      Grisette.Internal.TH.Derivation.ConvertOpCommon+      Grisette.Internal.TH.Derivation.Derive+      Grisette.Internal.TH.Derivation.DeriveAllSyms+      Grisette.Internal.TH.Derivation.DeriveBinary+      Grisette.Internal.TH.Derivation.DeriveCereal+      Grisette.Internal.TH.Derivation.DeriveEq+      Grisette.Internal.TH.Derivation.DeriveEvalSym+      Grisette.Internal.TH.Derivation.DeriveExtractSym+      Grisette.Internal.TH.Derivation.DeriveHashable+      Grisette.Internal.TH.Derivation.DeriveMergeable+      Grisette.Internal.TH.Derivation.DeriveNFData+      Grisette.Internal.TH.Derivation.DeriveOrd+      Grisette.Internal.TH.Derivation.DerivePPrint+      Grisette.Internal.TH.Derivation.DeriveSerial+      Grisette.Internal.TH.Derivation.DeriveShow+      Grisette.Internal.TH.Derivation.DeriveSimpleMergeable+      Grisette.Internal.TH.Derivation.DeriveSubstSym+      Grisette.Internal.TH.Derivation.DeriveSymEq+      Grisette.Internal.TH.Derivation.DeriveSymOrd+      Grisette.Internal.TH.Derivation.DeriveToCon+      Grisette.Internal.TH.Derivation.DeriveToSym+      Grisette.Internal.TH.Derivation.DeriveUnifiedSimpleMergeable+      Grisette.Internal.TH.Derivation.DeriveUnifiedSymEq+      Grisette.Internal.TH.Derivation.DeriveUnifiedSymOrd+      Grisette.Internal.TH.Derivation.SerializeCommon+      Grisette.Internal.TH.Derivation.ShowPPrintCommon+      Grisette.Internal.TH.Derivation.UnaryOpCommon+      Grisette.Internal.TH.Derivation.UnifiedOpCommon+      Grisette.Internal.TH.Util+      Grisette.Internal.Unified.BaseConstraint+      Grisette.Internal.Unified.BVBVConversion+      Grisette.Internal.Unified.BVFPConversion+      Grisette.Internal.Unified.Class.UnifiedFiniteBits+      Grisette.Internal.Unified.Class.UnifiedFromIntegral+      Grisette.Internal.Unified.Class.UnifiedITEOp+      Grisette.Internal.Unified.Class.UnifiedRep+      Grisette.Internal.Unified.Class.UnifiedSafeBitCast+      Grisette.Internal.Unified.Class.UnifiedSafeDiv+      Grisette.Internal.Unified.Class.UnifiedSafeFdiv+      Grisette.Internal.Unified.Class.UnifiedSafeFromFP+      Grisette.Internal.Unified.Class.UnifiedSafeLinearArith+      Grisette.Internal.Unified.Class.UnifiedSafeSymRotate+      Grisette.Internal.Unified.Class.UnifiedSafeSymShift+      Grisette.Internal.Unified.Class.UnifiedSimpleMergeable+      Grisette.Internal.Unified.Class.UnifiedSolvable+      Grisette.Internal.Unified.Class.UnifiedSymEq+      Grisette.Internal.Unified.Class.UnifiedSymOrd+      Grisette.Internal.Unified.Class.UnionViewMode+      Grisette.Internal.Unified.EvalMode+      Grisette.Internal.Unified.EvalModeTag+      Grisette.Internal.Unified.FPFPConversion+      Grisette.Internal.Unified.Theories+      Grisette.Internal.Unified.UnifiedAlgReal+      Grisette.Internal.Unified.UnifiedBool+      Grisette.Internal.Unified.UnifiedBV+      Grisette.Internal.Unified.UnifiedData+      Grisette.Internal.Unified.UnifiedFP+      Grisette.Internal.Unified.UnifiedFun+      Grisette.Internal.Unified.UnifiedInteger+      Grisette.Internal.Unified.UnifiedPrim+      Grisette.Internal.Unified.Util+      Grisette.Internal.Utils.Derive+      Grisette.Internal.Utils.Parameterized       Grisette.Lib.Base+      Grisette.Lib.Control.Applicative       Grisette.Lib.Control.Monad       Grisette.Lib.Control.Monad.Except       Grisette.Lib.Control.Monad.State.Class       Grisette.Lib.Control.Monad.Trans       Grisette.Lib.Control.Monad.Trans.Class       Grisette.Lib.Control.Monad.Trans.Cont+      Grisette.Lib.Control.Monad.Trans.Except       Grisette.Lib.Control.Monad.Trans.State       Grisette.Lib.Control.Monad.Trans.State.Lazy       Grisette.Lib.Control.Monad.Trans.State.Strict+      Grisette.Lib.Data.Bool+      Grisette.Lib.Data.Either       Grisette.Lib.Data.Foldable+      Grisette.Lib.Data.Functor+      Grisette.Lib.Data.Functor.Sum       Grisette.Lib.Data.List+      Grisette.Lib.Data.Maybe       Grisette.Lib.Data.Traversable-      Grisette.Qualified.ParallelUnionDo+      Grisette.Lib.Data.Tuple+      Grisette.SymPrim+      Grisette.TH+      Grisette.Unified+      Grisette.Unified.Lib.Control.Applicative+      Grisette.Unified.Lib.Control.Monad+      Grisette.Unified.Lib.Data.Foldable+      Grisette.Unified.Lib.Data.Functor       Grisette.Utils-      Grisette.Utils.Parameterized   other-modules:-      Paths_grisette+      Grisette.Internal.Internal.Decl.Core.Data.Class.ExtractSym+      Grisette.Internal.Internal.Decl.Core.Data.Class.PPrint+      Grisette.Internal.Internal.Decl.Core.Data.Class.ToCon+      Grisette.Internal.Internal.Decl.Core.Data.Class.SafeDiv+      Grisette.Internal.Internal.Decl.Core.Data.Class.SubstSym+      Grisette.Internal.Internal.Decl.Core.Data.Class.ToSym+      Grisette.Internal.Internal.Decl.Core.Data.Class.SymEq+      Grisette.Internal.Internal.Decl.Core.Data.Class.TryMerge+      Grisette.Internal.Internal.Decl.Core.Data.Class.SymOrd+      Grisette.Internal.Internal.Decl.Core.Data.Class.Solver+      Grisette.Internal.Internal.Decl.Core.Data.Class.SimpleMergeable+      Grisette.Internal.Internal.Decl.Core.Data.Class.Mergeable+      Grisette.Internal.Internal.Decl.Core.Data.Class.EvalSym+      Grisette.Internal.Internal.Decl.Core.Data.UnionBase+      Grisette.Internal.Internal.Decl.Core.Control.Monad.Union+      Grisette.Internal.Internal.Decl.SymPrim.AllSyms+      Grisette.Internal.Internal.Decl.Unified.UnifiedBV+      Grisette.Internal.Internal.Decl.Unified.UnifiedBool+      Grisette.Internal.Internal.Decl.Unified.BVFPConversion+      Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSymEq+      Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSymOrd+      Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSimpleMergeable+      Grisette.Internal.Internal.Decl.Unified.Class.UnifiedITEOp+      Grisette.Internal.Internal.Decl.Unified.UnifiedFP+      Grisette.Internal.Internal.Decl.Unified.EvalMode+      Grisette.Internal.Internal.Decl.Unified.FPFPConversion+      Grisette.Internal.Internal.Impl.Core.Data.Class.ExtractSym+      Grisette.Internal.Internal.Impl.Core.Data.Class.PPrint+      Grisette.Internal.Internal.Impl.Core.Data.Class.ToCon+      Grisette.Internal.Internal.Impl.Core.Data.Class.SafeDiv+      Grisette.Internal.Internal.Impl.Core.Data.Class.SubstSym+      Grisette.Internal.Internal.Impl.Core.Data.Class.ToSym+      Grisette.Internal.Internal.Impl.Core.Data.Class.SymEq+      Grisette.Internal.Internal.Impl.Core.Data.Class.TryMerge+      Grisette.Internal.Internal.Impl.Core.Data.Class.SymOrd+      Grisette.Internal.Internal.Impl.Core.Data.Class.Solver+      Grisette.Internal.Internal.Impl.Core.Data.Class.SimpleMergeable+      Grisette.Internal.Internal.Impl.Core.Data.Class.Mergeable+      Grisette.Internal.Internal.Impl.Core.Data.Class.EvalSym+      Grisette.Internal.Internal.Impl.Core.Data.UnionBase+      Grisette.Internal.Internal.Impl.Core.Control.Monad.Union+      Grisette.Internal.Internal.Impl.SymPrim.AllSyms+      Grisette.Internal.Internal.Impl.Unified.UnifiedBV+      Grisette.Internal.Internal.Impl.Unified.UnifiedBool+      Grisette.Internal.Internal.Impl.Unified.BVFPConversion+      Grisette.Internal.Internal.Impl.Unified.Class.UnifiedSymEq+      Grisette.Internal.Internal.Impl.Unified.Class.UnifiedSymOrd+      Grisette.Internal.Internal.Impl.Unified.Class.UnifiedSimpleMergeable+      Grisette.Internal.Internal.Impl.Unified.Class.UnifiedITEOp+      Grisette.Internal.Internal.Impl.Unified.UnifiedFP+      Grisette.Internal.Internal.Impl.Unified.EvalMode+      Grisette.Internal.Internal.Impl.Unified.FPFPConversion   hs-source-dirs:       src-  ghc-options: -Wextra -Wcompat -Widentities -Wincomplete-record-updates -Wmissing-export-lists -Wmissing-home-modules -Wmissing-import-lists -Wpartial-fields -Wunused-type-patterns+  ghc-options: -Wextra -Wcompat -Widentities -Wincomplete-record-updates -Wmissing-export-lists -Wmissing-home-modules -Wmissing-import-lists -Wpartial-fields -Wunused-type-patterns -Wno-x-partial -Wno-unrecognised-warning-flags   build-depends:-      QuickCheck ==2.14.*+      QuickCheck >=2.14 && <2.17     , array >=0.5.4 && <0.6     , async >=2.2.2 && <2.3+    , atomic-primops >=0.8.3 && <0.9     , base >=4.14 && <5+    , binary >=0.8.8.0 && <0.9+    , bytes >=0.17.1 && <0.18     , bytestring >=0.10.12 && <0.13+    , cereal >=0.5.8.1 && <0.6+    , cereal-text >=0.1.0.2 && <0.2+    , containers >=0.5.7 && <0.9     , deepseq >=1.4.4 && <1.6     , generic-deriving >=1.14.1 && <1.15-    , hashable >=1.2.3 && <1.5-    , hashtables >=1.2.3.4 && <1.4-    , intern >=0.9.2 && <0.10+    , hashable >=1.3 && <1.6+    , libBF >=0.6.3 && <0.7     , loch-th >=0.2.2 && <0.3     , mtl >=2.2.2 && <2.4-    , parallel >=3.2.2.0 && <3.3+    , parallel >=3.2.2 && <3.3     , prettyprinter >=1.5.0 && <1.8-    , sbv >=8.11 && <10.4+    , sbv >=8.17 && <13     , stm ==2.5.*-    , template-haskell >=2.16 && <2.22+    , template-haskell >=2.16 && <2.24     , 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+    , th-lift-instances >=0.1.16 && <0.2+    , transformers >=0.5.6.2 && <0.7+    , unordered-containers >=0.2.17 && <0.3+    , vector >=0.12.1.2 && <0.14   default-language: Haskell2010   if flag(optimize)     ghc-options: -O2   else     ghc-options: -O0+  if impl(ghc >= 9.2)+    ghc-prof-options: -finfo-table-map -fdistinct-constructor-tables+  else  test-suite doctest   type: exitcode-stdio-1.0@@ -174,120 +355,168 @@       Paths_grisette   hs-source-dirs:       doctest-  ghc-options: -Wextra -Wcompat -Widentities -Wincomplete-record-updates -Wmissing-export-lists -Wmissing-home-modules -Wmissing-import-lists -Wpartial-fields -Wunused-type-patterns -threaded -rtsopts -with-rtsopts=-N+  ghc-options: -Wextra -Wcompat -Widentities -Wincomplete-record-updates -Wmissing-export-lists -Wmissing-home-modules -Wmissing-import-lists -Wpartial-fields -Wunused-type-patterns -Wno-x-partial -Wno-unrecognised-warning-flags -threaded -rtsopts -with-rtsopts=-N   build-depends:-      Glob-    , QuickCheck ==2.14.*+      QuickCheck >=2.14 && <2.17     , array >=0.5.4 && <0.6     , async >=2.2.2 && <2.3+    , atomic-primops >=0.8.3 && <0.9     , base >=4.14 && <5+    , binary >=0.8.8.0 && <0.9+    , bytes >=0.17.1 && <0.18     , bytestring >=0.10.12 && <0.13+    , cereal >=0.5.8.1 && <0.6+    , cereal-text >=0.1.0.2 && <0.2+    , containers >=0.5.7 && <0.9     , deepseq >=1.4.4 && <1.6-    , doctest >=0.18.2 && <0.23+    , doctest >=0.18.2 && <0.25     , generic-deriving >=1.14.1 && <1.15     , grisette-    , hashable >=1.2.3 && <1.5-    , hashtables >=1.2.3.4 && <1.4-    , intern >=0.9.2 && <0.10+    , hashable >=1.3 && <1.6+    , libBF >=0.6.3 && <0.7     , loch-th >=0.2.2 && <0.3     , mtl >=2.2.2 && <2.4-    , parallel >=3.2.2.0 && <3.3+    , parallel >=3.2.2 && <3.3     , prettyprinter >=1.5.0 && <1.8-    , sbv >=8.11 && <10.4+    , sbv >=8.17 && <13     , stm ==2.5.*-    , template-haskell >=2.16 && <2.22+    , template-haskell >=2.16 && <2.24     , 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+    , th-lift-instances >=0.1.16 && <0.2+    , transformers >=0.5.6.2 && <0.7+    , unordered-containers >=0.2.17 && <0.3+    , vector >=0.12.1.2 && <0.14   default-language: Haskell2010   if flag(optimize)     ghc-options: -O2   else     ghc-options: -O0+  if impl(ghc >= 9.2)+    ghc-prof-options: -finfo-table-map -fdistinct-constructor-tables+  else  test-suite spec   type: exitcode-stdio-1.0   main-is: Main.hs   other-modules:-      Grisette.Backend.SBV.Data.SMT.CEGISTests-      Grisette.Backend.SBV.Data.SMT.LoweringTests-      Grisette.Backend.SBV.Data.SMT.TermRewritingGen-      Grisette.Backend.SBV.Data.SMT.TermRewritingTests+      Grisette.Backend.CEGISTests+      Grisette.Backend.LoweringTests+      Grisette.Backend.TermRewritingGen+      Grisette.Backend.TermRewritingTests       Grisette.Core.Control.ExceptionTests-      Grisette.Core.Control.Monad.UnionMTests       Grisette.Core.Control.Monad.UnionTests-      Grisette.Core.Data.BVTests+      Grisette.Core.Data.Class.BitCastTests       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.PPrintTests+      Grisette.Core.Data.Class.SafeDivTests+      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.SymFiniteBitsTests+      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.UnionLikeTests-      Grisette.IR.SymPrim.Data.Prim.BitsTests-      Grisette.IR.SymPrim.Data.Prim.BoolTests-      Grisette.IR.SymPrim.Data.Prim.BVTests-      Grisette.IR.SymPrim.Data.Prim.IntegralTests-      Grisette.IR.SymPrim.Data.Prim.ModelTests-      Grisette.IR.SymPrim.Data.Prim.NumTests-      Grisette.IR.SymPrim.Data.Prim.TabularFunTests-      Grisette.IR.SymPrim.Data.SymPrimTests-      Grisette.IR.SymPrim.Data.TabularFunTests+      Grisette.Core.Data.Class.TryMergeTests+      Grisette.Core.Data.Class.UnionViewTests+      Grisette.Core.Data.UnionBaseTests+      Grisette.Core.TH.DerivationData+      Grisette.Core.TH.DerivationTest+      Grisette.Core.TH.PartialEvalMode+      Grisette.Lib.Control.ApplicativeTest       Grisette.Lib.Control.Monad.ExceptTests       Grisette.Lib.Control.Monad.State.ClassTests       Grisette.Lib.Control.Monad.Trans.ClassTests+      Grisette.Lib.Control.Monad.Trans.ExceptTests       Grisette.Lib.Control.Monad.Trans.State.Common       Grisette.Lib.Control.Monad.Trans.State.LazyTests       Grisette.Lib.Control.Monad.Trans.State.StrictTests       Grisette.Lib.Control.MonadTests       Grisette.Lib.Data.FoldableTests+      Grisette.Lib.Data.FunctorTests+      Grisette.Lib.Data.ListTests       Grisette.Lib.Data.TraversableTests+      Grisette.SymPrim.AlgRealTests+      Grisette.SymPrim.BVTests+      Grisette.SymPrim.FPTests+      Grisette.SymPrim.GeneralFunTests+      Grisette.SymPrim.Prim.BitsTests+      Grisette.SymPrim.Prim.BoolTests+      Grisette.SymPrim.Prim.BVTests+      Grisette.SymPrim.Prim.ConcurrentTests+      Grisette.SymPrim.Prim.IntegralTests+      Grisette.SymPrim.Prim.ModelTests+      Grisette.SymPrim.Prim.NumTests+      Grisette.SymPrim.Prim.SerializationTests+      Grisette.SymPrim.Prim.TabularFunTests+      Grisette.SymPrim.QuantifierTests+      Grisette.SymPrim.SomeBVTests+      Grisette.SymPrim.SymGeneralFunTests+      Grisette.SymPrim.SymPrimConstraintTests+      Grisette.SymPrim.SymPrimTests+      Grisette.SymPrim.TabularFunTests+      Grisette.TestUtil.NoMerge+      Grisette.TestUtil.PrettyPrint       Grisette.TestUtil.SymbolicAssertion+      Grisette.Unified.EvalModeTest+      Grisette.Unified.GetDataTest+      Grisette.Unified.UnifiedClassesTest+      Grisette.Unified.UnifiedConstructorTest       Paths_grisette   hs-source-dirs:       test-  ghc-options: -Wextra -Wcompat -Widentities -Wincomplete-record-updates -Wmissing-export-lists -Wmissing-home-modules -Wmissing-import-lists -Wpartial-fields -Wunused-type-patterns -threaded -rtsopts -with-rtsopts=-N+  ghc-options: -Wextra -Wcompat -Widentities -Wincomplete-record-updates -Wmissing-export-lists -Wmissing-home-modules -Wmissing-import-lists -Wpartial-fields -Wunused-type-patterns -Wno-x-partial -Wno-unrecognised-warning-flags -threaded -rtsopts -with-rtsopts=-N -Wredundant-constraints   build-depends:       HUnit ==1.6.*-    , QuickCheck ==2.14.*+    , QuickCheck >=2.14 && <2.17     , array >=0.5.4 && <0.6     , async >=2.2.2 && <2.3+    , atomic-primops >=0.8.3 && <0.9     , base >=4.14 && <5+    , binary >=0.8.8.0 && <0.9+    , bytes >=0.17.1 && <0.18     , bytestring >=0.10.12 && <0.13+    , cereal >=0.5.8.1 && <0.6+    , cereal-text >=0.1.0.2 && <0.2+    , containers >=0.5.7 && <0.9     , deepseq >=1.4.4 && <1.6     , generic-deriving >=1.14.1 && <1.15     , grisette-    , hashable >=1.2.3 && <1.5-    , hashtables >=1.2.3.4 && <1.4-    , intern >=0.9.2 && <0.10+    , hashable >=1.3 && <1.6+    , libBF >=0.6.3 && <0.7     , loch-th >=0.2.2 && <0.3     , mtl >=2.2.2 && <2.4-    , parallel >=3.2.2.0 && <3.3+    , parallel >=3.2.2 && <3.3     , prettyprinter >=1.5.0 && <1.8-    , sbv >=8.11 && <10.4+    , sbv >=8.17 && <13     , stm ==2.5.*-    , template-haskell >=2.16 && <2.22+    , template-haskell >=2.16 && <2.24     , test-framework >=0.8.2 && <0.9     , 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+    , th-lift-instances >=0.1.16 && <0.2+    , transformers >=0.5.6.2 && <0.7+    , unordered-containers >=0.2.17 && <0.3+    , vector >=0.12.1.2 && <0.14   default-language: Haskell2010   if flag(optimize)     ghc-options: -O2   else     ghc-options: -O0+  if impl(ghc >= 9.2)+    ghc-prof-options: -finfo-table-map -fdistinct-constructor-tables+  else
src/Grisette.hs view
@@ -3,32 +3,79 @@  -- | -- 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-    module Grisette.IR.SymPrim, +    -- | This module provides primitive types for symbolic evaluation.+    module Grisette.SymPrim,+     -- * Solver backend-    module Grisette.Backend.SBV, +    -- | 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 -import Grisette.Backend.SBV+import Grisette.Backend import Grisette.Core-import Grisette.IR.SymPrim import Grisette.Lib.Base+import Grisette.SymPrim+import Grisette.TH import Grisette.Utils
+ src/Grisette/Backend.hs view
@@ -0,0 +1,55 @@+-- Disable this warning because we are re-exporting things.+{-# OPTIONS_GHC -Wno-missing-import-lists #-}++-- |+-- Module      :   Grisette.Backend+-- 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.Backend+  ( -- * SMT backend configuration+    GrisetteSMTConfig (..),+    boolector,+    bitwuzla,+    cvc4,+    cvc5,+    yices,+    dReal,+    z3,+    mathSAT,+    abc,++    -- * Changing the extra configurations+    ExtraConfig (..),+    withTimeout,+    clearTimeout,++    -- * SBV backend solver configuration+    SBV.SMTConfig (..),+    SBV.Logic (..),+    SBVC.SMTOption (..),+    SBV.Timing (..),+    SBV.SMTSolver (..),+  )+where++import qualified Data.SBV as SBV+import qualified Data.SBV.Control as SBVC+import Grisette.Internal.Backend.Solving+  ( ExtraConfig (..),+    GrisetteSMTConfig (..),+    abc,+    bitwuzla,+    boolector,+    clearTimeout,+    cvc4,+    cvc5,+    dReal,+    mathSAT,+    withTimeout,+    yices,+    z3,+  )
− src/Grisette/Backend/SBV.hs 
@@ -1,48 +0,0 @@--- Disable this warning because we are re-exporting things.-{-# OPTIONS_GHC -Wno-missing-import-lists #-}---- |--- Module      :   Grisette.Backend.SBV--- 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.Backend.SBV-  ( -- * Grisette SBV backend configuration-    ApproximationConfig (..),-    ExtraConfig (..),-    precise,-    approx,-    withTimeout,-    clearTimeout,-    withApprox,-    clearApprox,-    GrisetteSMTConfig (..),--    -- * SBV backend solver configuration-    SBV.SMTConfig (..),-    SBV.boolector,-    SBV.cvc4,-    SBV.yices,-    SBV.dReal,-    SBV.z3,-    SBV.mathSAT,-    SBV.abc,-    SBV.Timing (..),-  )-where--import qualified Data.SBV as SBV-import Grisette.Backend.SBV.Data.SMT.Solving-  ( ApproximationConfig (..),-    ExtraConfig (..),-    GrisetteSMTConfig (..),-    approx,-    clearApprox,-    clearTimeout,-    precise,-    withApprox,-    withTimeout,-  )
− src/Grisette/Backend/SBV/Data/SMT/Lowering.hs 
@@ -1,1882 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE QuantifiedConstraints #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RoleAnnotations #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE ViewPatterns #-}---- |--- Module      :   Grisette.Backend.SBV.Data.SMT.Lowering--- 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.Backend.SBV.Data.SMT.Lowering-  ( lowerSinglePrim,-    lowerSinglePrimCached,-    parseModel,-    SymBiMap,-  )-where--import Control.Monad.IO.Class (MonadIO)-import Control.Monad.Reader (MonadTrans (lift), ReaderT)-import Control.Monad.State (StateT)-import Data.Bifunctor (Bifunctor (bimap, first, second))-import Data.Bits-  ( Bits (complement, xor, (.&.), (.|.)),-  )-import Data.Dynamic (Typeable, fromDyn, toDyn)-import Data.Foldable (Foldable (foldl'), asum)-import Data.Kind (Type)-import Data.Maybe (fromMaybe)-import Data.SBV (SIntegral, sRotateLeft, sRotateRight, sShiftLeft, sShiftRight)-import qualified Data.SBV as SBV-import qualified Data.SBV.Internals as SBVI-import qualified Data.SBV.Trans as SBVT-import qualified Data.SBV.Trans.Control as SBVTC-import Data.Type.Equality (type (~~))-import Data.Typeable (Proxy (Proxy), type (:~:) (Refl))-import GHC.Exts (sortWith)-import GHC.Stack (HasCallStack)-import GHC.TypeNats-  ( KnownNat,-    Nat,-    natVal,-    type (+),-    type (-),-    type (<=),-  )-import {-# SOURCE #-} Grisette.Backend.SBV.Data.SMT.Solving-  ( ApproximationConfig (Approx, NoApprox),-    ExtraConfig (integerApprox),-    GrisetteSMTConfig (GrisetteSMTConfig),-    TermTy,-  )-import Grisette.Backend.SBV.Data.SMT.SymBiMap-  ( SymBiMap,-    addBiMap,-    addBiMapIntermediate,-    emptySymBiMap,-    findStringToSymbol,-    lookupTerm,-    sizeBiMap,-  )-import Grisette.Core.Data.BV (IntN (IntN, unIntN), WordN (WordN))-import Grisette.Core.Data.Class.ModelOps-  ( ModelOps (emptyModel, insertValue),-  )-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors-  ( conTerm,-    symTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.SomeTerm-  ( SomeTerm (SomeTerm),-  )-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term-  ( SomeTypedSymbol (SomeTypedSymbol),-    SupportedPrim (withPrim),-    Term-      ( AbsNumTerm,-        AddNumTerm,-        AndBitsTerm,-        AndTerm,-        BVConcatTerm,-        BVExtendTerm,-        BVSelectTerm,-        BinaryTerm,-        ComplementBitsTerm,-        ConTerm,-        DivBoundedIntegralTerm,-        DivIntegralTerm,-        EqvTerm,-        GeneralFunApplyTerm,-        ITETerm,-        LENumTerm,-        LTNumTerm,-        ModBoundedIntegralTerm,-        ModIntegralTerm,-        NotTerm,-        OrBitsTerm,-        OrTerm,-        QuotBoundedIntegralTerm,-        QuotIntegralTerm,-        RemBoundedIntegralTerm,-        RemIntegralTerm,-        RotateLeftTerm,-        RotateRightTerm,-        ShiftLeftTerm,-        ShiftRightTerm,-        SignumNumTerm,-        SymTerm,-        TabularFunApplyTerm,-        TernaryTerm,-        TimesNumTerm,-        ToSignedTerm,-        ToUnsignedTerm,-        UMinusNumTerm,-        UnaryTerm,-        XorBitsTerm-      ),-    TypedSymbol (IndexedSymbol),-    buildGeneralFun,-    someTypedSymbol,-    withSymbolSupported,-    type (-->),-  )-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermUtils-  ( introSupportedPrimConstraint,-  )-import Grisette.IR.SymPrim.Data.Prim.Model as PM (Model)-import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool-  ( pevalEqvTerm,-    pevalITETerm,-  )-import Grisette.IR.SymPrim.Data.TabularFun-  ( type (=->) (TabularFun),-  )-import Grisette.Utils.Parameterized-  ( KnownProof (KnownProof),-    LeqProof (LeqProof),-    unsafeAxiom,-    unsafeKnownProof,-    unsafeLeqProof,-    withKnownProof,-  )-import qualified Type.Reflection as R--translateTypeError :: (HasCallStack) => R.TypeRep a -> b-translateTypeError ta =-  error $-    "Don't know how to translate the type " ++ show ta ++ " to SMT"--translateUnaryError :: (HasCallStack) => String -> R.TypeRep a -> R.TypeRep b -> c-translateUnaryError op ta tb =-  error $-    "Don't know how to translate the op "-      ++ show op-      ++ " :: "-      ++ show ta-      ++ " -> "-      ++ show tb-      ++ " to SMT"--translateBinaryError :: (HasCallStack) => String -> R.TypeRep a -> R.TypeRep b -> R.TypeRep c -> d-translateBinaryError op ta tb tc =-  error $-    "Don't know how to translate the op "-      ++ show op-      ++ " :: "-      ++ show ta-      ++ " -> "-      ++ show tb-      ++ " -> "-      ++ show tc-      ++ " to SMT"--translateTernaryError :: (HasCallStack) => String -> R.TypeRep a -> R.TypeRep b -> R.TypeRep c -> R.TypeRep d -> e-translateTernaryError op ta tb tc td =-  error $-    "Don't know how to translate the op "-      ++ show op-      ++ " :: "-      ++ show ta-      ++ " -> "-      ++ show tb-      ++ " -> "-      ++ show tc-      ++ " -> "-      ++ show td-      ++ " to SMT"--lowerValue ::-  forall integerBitWidth a.-  (SupportedPrim a, Typeable a) =>-  GrisetteSMTConfig integerBitWidth ->-  a ->-  TermTy integerBitWidth a-lowerValue config@ResolvedConfig {} v =-  case R.typeRep @a of-    BoolType -> if v then SBV.sTrue else SBV.sFalse-    IntegerType -> fromInteger v-    SignedBVType _ -> case v of-      IntN x -> fromInteger x-    UnsignedBVType _ -> case v of-      WordN x -> fromInteger x-    TFunType (l :: a1) (r :: a2) ->-      case ((config, l), (config, r)) of-        (ResolvedSimpleType, ResolvedMergeableType) ->-          lowerTFunCon config v-        _ -> translateTypeError (R.typeRep @a)-    _ -> translateTypeError (R.typeRep @a)-lowerValue _ _ = translateTypeError (R.typeRep @a)--lowerTFunCon ::-  forall integerBitWidth a b.-  (SupportedPrim a, SupportedPrim b, SBV.EqSymbolic (TermTy integerBitWidth a), SBV.Mergeable (TermTy integerBitWidth b)) =>-  GrisetteSMTConfig integerBitWidth ->-  (a =-> b) ->-  (TermTy integerBitWidth a -> TermTy integerBitWidth b)-lowerTFunCon config@ResolvedConfig {} (TabularFun l d) = go l d-  where-    go [] d _ = lowerValue config d-    go ((x, r) : xs) d v = SBV.ite (lowerValue config x SBV..== v) (lowerValue config r) (go xs d v)-lowerTFunCon _ TabularFun {} = translateTypeError (R.typeRep @a)--buildUTFun11 ::-  forall integerBitWidth s1 s2 a.-  (SupportedPrim a, SupportedPrim s1, SupportedPrim s2) =>-  GrisetteSMTConfig integerBitWidth ->-  R.TypeRep s1 ->-  R.TypeRep s2 ->-  Term a ->-  SymBiMap ->-  Maybe (SymBiMap, TermTy integerBitWidth (s1 =-> s2))-buildUTFun11 config ta tb term@(SymTerm _ ts) m = case ((config, ta), (config, tb)) of-  (ResolvedSimpleType, ResolvedSimpleType) ->-    let name = "ufunc_" ++ show (sizeBiMap m)-        f = SBV.uninterpret @(TermTy integerBitWidth s1 -> TermTy integerBitWidth s2) name-     in Just (addBiMap (SomeTerm term) (toDyn f) name (someTypedSymbol ts) m, f)-  _ -> Nothing-buildUTFun11 _ _ _ _ _ = error "Should only be called on SymTerm"--buildUTFun111 ::-  forall integerBitWidth s1 s2 s3 a.-  (SupportedPrim a, SupportedPrim s1, SupportedPrim s2, SupportedPrim s3) =>-  GrisetteSMTConfig integerBitWidth ->-  R.TypeRep s1 ->-  R.TypeRep s2 ->-  R.TypeRep s3 ->-  Term a ->-  SymBiMap ->-  Maybe (SymBiMap, TermTy integerBitWidth (s1 =-> s2 =-> s3))-buildUTFun111 config ta tb tc term@(SymTerm _ ts) m =-  case ((config, ta), (config, tb), (config, tc)) of-    (ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType) ->-      let name = "ufunc_" ++ show (sizeBiMap m)-          f =-            SBV.uninterpret @(TermTy integerBitWidth s1 -> TermTy integerBitWidth s2 -> TermTy integerBitWidth s3)-              name-       in Just (addBiMap (SomeTerm term) (toDyn f) name (someTypedSymbol ts) m, f)-    _ -> Nothing-buildUTFun111 _ _ _ _ _ _ = error "Should only be called on SymTerm"--buildUTFun1111 ::-  forall integerBitWidth s1 s2 s3 s4 a.-  (SupportedPrim a, SupportedPrim s1, SupportedPrim s2, SupportedPrim s3, SupportedPrim s4) =>-  GrisetteSMTConfig integerBitWidth ->-  R.TypeRep s1 ->-  R.TypeRep s2 ->-  R.TypeRep s3 ->-  R.TypeRep s4 ->-  Term a ->-  SymBiMap ->-  Maybe (SymBiMap, TermTy integerBitWidth (s1 =-> s2 =-> s3 =-> s4))-buildUTFun1111 config ta tb tc td term@(SymTerm _ ts) m =-  case ((config, ta), (config, tb), (config, tc), (config, td)) of-    (ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType) ->-      let name = "ufunc_" ++ show (sizeBiMap m)-          f =-            SBV.uninterpret @(TermTy integerBitWidth s1 -> TermTy integerBitWidth s2 -> TermTy integerBitWidth s3 -> TermTy integerBitWidth s4)-              name-       in Just (addBiMap (SomeTerm term) (toDyn f) name (someTypedSymbol ts) m, f)-    _ -> Nothing-buildUTFun1111 _ _ _ _ _ _ _ = error "Should only be called on SymTerm"--buildUTFun11111 ::-  forall integerBitWidth s1 s2 s3 s4 s5 a.-  (SupportedPrim a, SupportedPrim s1, SupportedPrim s2, SupportedPrim s3, SupportedPrim s4, SupportedPrim s5) =>-  GrisetteSMTConfig integerBitWidth ->-  R.TypeRep s1 ->-  R.TypeRep s2 ->-  R.TypeRep s3 ->-  R.TypeRep s4 ->-  R.TypeRep s5 ->-  Term a ->-  SymBiMap ->-  Maybe (SymBiMap, TermTy integerBitWidth (s1 =-> s2 =-> s3 =-> s4 =-> s5))-buildUTFun11111 config ta tb tc td te term@(SymTerm _ ts) m =-  case ((config, ta), (config, tb), (config, tc), (config, td), (config, te)) of-    (ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType) ->-      let name = "ufunc_" ++ show (sizeBiMap m)-          f =-            SBV.uninterpret @(TermTy integerBitWidth (s1 =-> s2 =-> s3 =-> s4 =-> s5))-              name-       in Just (addBiMap (SomeTerm term) (toDyn f) name (someTypedSymbol ts) m, f)-    _ -> Nothing-buildUTFun11111 _ _ _ _ _ _ _ _ = error "Should only be called on SymTerm"--buildUTFun111111 ::-  forall integerBitWidth s1 s2 s3 s4 s5 s6 a.-  ( SupportedPrim a,-    SupportedPrim s1,-    SupportedPrim s2,-    SupportedPrim s3,-    SupportedPrim s4,-    SupportedPrim s5,-    SupportedPrim s6-  ) =>-  GrisetteSMTConfig integerBitWidth ->-  R.TypeRep s1 ->-  R.TypeRep s2 ->-  R.TypeRep s3 ->-  R.TypeRep s4 ->-  R.TypeRep s5 ->-  R.TypeRep s6 ->-  Term a ->-  SymBiMap ->-  Maybe (SymBiMap, TermTy integerBitWidth (s1 =-> s2 =-> s3 =-> s4 =-> s5 =-> s6))-buildUTFun111111 config ta tb tc td te tf term@(SymTerm _ ts) m =-  case ((config, ta), (config, tb), (config, tc), (config, td), (config, te), (config, tf)) of-    (ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType) ->-      let name = "ufunc_" ++ show (sizeBiMap m)-          f =-            SBV.uninterpret @(TermTy integerBitWidth (s1 =-> s2 =-> s3 =-> s4 =-> s5 =-> s6))-              name-       in Just (addBiMap (SomeTerm term) (toDyn f) name (someTypedSymbol ts) m, f)-    _ -> Nothing-buildUTFun111111 _ _ _ _ _ _ _ _ _ = error "Should only be called on SymTerm"--buildUTFun1111111 ::-  forall integerBitWidth s1 s2 s3 s4 s5 s6 s7 a.-  ( SupportedPrim a,-    SupportedPrim s1,-    SupportedPrim s2,-    SupportedPrim s3,-    SupportedPrim s4,-    SupportedPrim s5,-    SupportedPrim s6,-    SupportedPrim s7-  ) =>-  GrisetteSMTConfig integerBitWidth ->-  R.TypeRep s1 ->-  R.TypeRep s2 ->-  R.TypeRep s3 ->-  R.TypeRep s4 ->-  R.TypeRep s5 ->-  R.TypeRep s6 ->-  R.TypeRep s7 ->-  Term a ->-  SymBiMap ->-  Maybe (SymBiMap, TermTy integerBitWidth (s1 =-> s2 =-> s3 =-> s4 =-> s5 =-> s6 =-> s7))-buildUTFun1111111 config ta tb tc td te tf tg term@(SymTerm _ ts) m =-  case ((config, ta), (config, tb), (config, tc), (config, td), (config, te), (config, tf), (config, tg)) of-    (ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType) ->-      let name = "ufunc_" ++ show (sizeBiMap m)-          f =-            SBV.uninterpret @(TermTy integerBitWidth (s1 =-> s2 =-> s3 =-> s4 =-> s5 =-> s6 =-> s7))-              name-       in Just (addBiMap (SomeTerm term) (toDyn f) name (someTypedSymbol ts) m, f)-    _ -> Nothing-buildUTFun1111111 _ _ _ _ _ _ _ _ _ _ = error "Should only be called on SymTerm"--buildUTFun11111111 ::-  forall integerBitWidth s1 s2 s3 s4 s5 s6 s7 s8 a.-  ( SupportedPrim a,-    SupportedPrim s1,-    SupportedPrim s2,-    SupportedPrim s3,-    SupportedPrim s4,-    SupportedPrim s5,-    SupportedPrim s6,-    SupportedPrim s7,-    SupportedPrim s8-  ) =>-  GrisetteSMTConfig integerBitWidth ->-  R.TypeRep s1 ->-  R.TypeRep s2 ->-  R.TypeRep s3 ->-  R.TypeRep s4 ->-  R.TypeRep s5 ->-  R.TypeRep s6 ->-  R.TypeRep s7 ->-  R.TypeRep s8 ->-  Term a ->-  SymBiMap ->-  Maybe (SymBiMap, TermTy integerBitWidth (s1 =-> s2 =-> s3 =-> s4 =-> s5 =-> s6 =-> s7 =-> s8))-buildUTFun11111111 config ta tb tc td te tf tg th term@(SymTerm _ ts) m =-  case ((config, ta), (config, tb), (config, tc), (config, td), (config, te), (config, tf), (config, tg), (config, th)) of-    (ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType) ->-      let name = "ufunc_" ++ show (sizeBiMap m)-          f =-            SBV.uninterpret @(TermTy integerBitWidth (s1 =-> s2 =-> s3 =-> s4 =-> s5 =-> s6 =-> s7 =-> s8))-              name-       in Just (addBiMap (SomeTerm term) (toDyn f) name (someTypedSymbol ts) m, f)-    _ -> Nothing-buildUTFun11111111 _ _ _ _ _ _ _ _ _ _ _ = error "Should only be called on SymTerm"--buildUGFun11 ::-  forall integerBitWidth s1 s2 a.-  (SupportedPrim a, SupportedPrim s1, SupportedPrim s2) =>-  GrisetteSMTConfig integerBitWidth ->-  R.TypeRep s1 ->-  R.TypeRep s2 ->-  Term a ->-  SymBiMap ->-  Maybe (SymBiMap, TermTy integerBitWidth (s1 --> s2))-buildUGFun11 config ta tb term@(SymTerm _ ts) m = case ((config, ta), (config, tb)) of-  (ResolvedSimpleType, ResolvedSimpleType) ->-    let name = "ufunc_" ++ show (sizeBiMap m)-        f = SBV.uninterpret @(TermTy integerBitWidth s1 -> TermTy integerBitWidth s2) name-     in Just (addBiMap (SomeTerm term) (toDyn f) name (someTypedSymbol ts) m, f)-  _ -> Nothing-buildUGFun11 _ _ _ _ _ = error "Should only be called on SymTerm"--buildUGFun111 ::-  forall integerBitWidth s1 s2 s3 a.-  (SupportedPrim a, SupportedPrim s1, SupportedPrim s2, SupportedPrim s3) =>-  GrisetteSMTConfig integerBitWidth ->-  R.TypeRep s1 ->-  R.TypeRep s2 ->-  R.TypeRep s3 ->-  Term a ->-  SymBiMap ->-  Maybe (SymBiMap, TermTy integerBitWidth (s1 --> s2 --> s3))-buildUGFun111 config ta tb tc term@(SymTerm _ ts) m = case ((config, ta), (config, tb), (config, tc)) of-  (ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType) ->-    let name = "ufunc_" ++ show (sizeBiMap m)-        f =-          SBV.uninterpret @(TermTy integerBitWidth s1 -> TermTy integerBitWidth s2 -> TermTy integerBitWidth s3)-            name-     in Just (addBiMap (SomeTerm term) (toDyn f) name (someTypedSymbol ts) m, f)-  _ -> Nothing-buildUGFun111 _ _ _ _ _ _ = error "Should only be called on SymTerm"--buildUGFun1111 ::-  forall integerBitWidth s1 s2 s3 s4 a.-  (SupportedPrim a, SupportedPrim s1, SupportedPrim s2, SupportedPrim s3, SupportedPrim s4) =>-  GrisetteSMTConfig integerBitWidth ->-  R.TypeRep s1 ->-  R.TypeRep s2 ->-  R.TypeRep s3 ->-  R.TypeRep s4 ->-  Term a ->-  SymBiMap ->-  Maybe (SymBiMap, TermTy integerBitWidth (s1 --> s2 --> s3 --> s4))-buildUGFun1111 config ta tb tc td term@(SymTerm _ ts) m =-  case ((config, ta), (config, tb), (config, tc), (config, td)) of-    (ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType) ->-      let name = "ufunc_" ++ show (sizeBiMap m)-          f =-            SBV.uninterpret @(TermTy integerBitWidth s1 -> TermTy integerBitWidth s2 -> TermTy integerBitWidth s3 -> TermTy integerBitWidth s4)-              name-       in Just (addBiMap (SomeTerm term) (toDyn f) name (someTypedSymbol ts) m, f)-    _ -> Nothing-buildUGFun1111 _ _ _ _ _ _ _ = error "Should only be called on SymTerm"--buildUGFun11111 ::-  forall integerBitWidth s1 s2 s3 s4 s5 a.-  (SupportedPrim a, SupportedPrim s1, SupportedPrim s2, SupportedPrim s3, SupportedPrim s4, SupportedPrim s5) =>-  GrisetteSMTConfig integerBitWidth ->-  R.TypeRep s1 ->-  R.TypeRep s2 ->-  R.TypeRep s3 ->-  R.TypeRep s4 ->-  R.TypeRep s5 ->-  Term a ->-  SymBiMap ->-  Maybe (SymBiMap, TermTy integerBitWidth (s1 --> s2 --> s3 --> s4 --> s5))-buildUGFun11111 config ta tb tc td te term@(SymTerm _ ts) m =-  case ((config, ta), (config, tb), (config, tc), (config, td), (config, te)) of-    (ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType) ->-      let name = "ufunc_" ++ show (sizeBiMap m)-          f =-            SBV.uninterpret @(TermTy integerBitWidth (s1 --> s2 --> s3 --> s4 --> s5))-              name-       in Just (addBiMap (SomeTerm term) (toDyn f) name (someTypedSymbol ts) m, f)-    _ -> Nothing-buildUGFun11111 _ _ _ _ _ _ _ _ = error "Should only be called on SymTerm"--buildUGFun111111 ::-  forall integerBitWidth s1 s2 s3 s4 s5 s6 a.-  ( SupportedPrim a,-    SupportedPrim s1,-    SupportedPrim s2,-    SupportedPrim s3,-    SupportedPrim s4,-    SupportedPrim s5,-    SupportedPrim s6-  ) =>-  GrisetteSMTConfig integerBitWidth ->-  R.TypeRep s1 ->-  R.TypeRep s2 ->-  R.TypeRep s3 ->-  R.TypeRep s4 ->-  R.TypeRep s5 ->-  R.TypeRep s6 ->-  Term a ->-  SymBiMap ->-  Maybe (SymBiMap, TermTy integerBitWidth (s1 --> s2 --> s3 --> s4 --> s5 --> s6))-buildUGFun111111 config ta tb tc td te tf term@(SymTerm _ ts) m =-  case ((config, ta), (config, tb), (config, tc), (config, td), (config, te), (config, tf)) of-    (ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType) ->-      let name = "ufunc_" ++ show (sizeBiMap m)-          f =-            SBV.uninterpret @(TermTy integerBitWidth (s1 --> s2 --> s3 --> s4 --> s5 --> s6))-              name-       in Just (addBiMap (SomeTerm term) (toDyn f) name (someTypedSymbol ts) m, f)-    _ -> Nothing-buildUGFun111111 _ _ _ _ _ _ _ _ _ = error "Should only be called on SymTerm"--buildUGFun1111111 ::-  forall integerBitWidth s1 s2 s3 s4 s5 s6 s7 a.-  ( SupportedPrim a,-    SupportedPrim s1,-    SupportedPrim s2,-    SupportedPrim s3,-    SupportedPrim s4,-    SupportedPrim s5,-    SupportedPrim s6,-    SupportedPrim s7-  ) =>-  GrisetteSMTConfig integerBitWidth ->-  R.TypeRep s1 ->-  R.TypeRep s2 ->-  R.TypeRep s3 ->-  R.TypeRep s4 ->-  R.TypeRep s5 ->-  R.TypeRep s6 ->-  R.TypeRep s7 ->-  Term a ->-  SymBiMap ->-  Maybe (SymBiMap, TermTy integerBitWidth (s1 --> s2 --> s3 --> s4 --> s5 --> s6 --> s7))-buildUGFun1111111 config ta tb tc td te tf tg term@(SymTerm _ ts) m =-  case ((config, ta), (config, tb), (config, tc), (config, td), (config, te), (config, tf), (config, tg)) of-    (ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType) ->-      let name = "ufunc_" ++ show (sizeBiMap m)-          f =-            SBV.uninterpret @(TermTy integerBitWidth (s1 --> s2 --> s3 --> s4 --> s5 --> s6 --> s7))-              name-       in Just (addBiMap (SomeTerm term) (toDyn f) name (someTypedSymbol ts) m, f)-    _ -> Nothing-buildUGFun1111111 _ _ _ _ _ _ _ _ _ _ = error "Should only be called on SymTerm"--buildUGFun11111111 ::-  forall integerBitWidth s1 s2 s3 s4 s5 s6 s7 s8 a.-  ( SupportedPrim a,-    SupportedPrim s1,-    SupportedPrim s2,-    SupportedPrim s3,-    SupportedPrim s4,-    SupportedPrim s5,-    SupportedPrim s6,-    SupportedPrim s7,-    SupportedPrim s8-  ) =>-  GrisetteSMTConfig integerBitWidth ->-  R.TypeRep s1 ->-  R.TypeRep s2 ->-  R.TypeRep s3 ->-  R.TypeRep s4 ->-  R.TypeRep s5 ->-  R.TypeRep s6 ->-  R.TypeRep s7 ->-  R.TypeRep s8 ->-  Term a ->-  SymBiMap ->-  Maybe (SymBiMap, TermTy integerBitWidth (s1 --> s2 --> s3 --> s4 --> s5 --> s6 --> s7 --> s8))-buildUGFun11111111 config ta tb tc td te tf tg th term@(SymTerm _ ts) m =-  case ((config, ta), (config, tb), (config, tc), (config, td), (config, te), (config, tf), (config, tg), (config, th)) of-    (ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType) ->-      let name = "ufunc_" ++ show (sizeBiMap m)-          f =-            SBV.uninterpret @(TermTy integerBitWidth (s1 --> s2 --> s3 --> s4 --> s5 --> s6 --> s7 --> s8))-              name-       in Just (addBiMap (SomeTerm term) (toDyn f) name (someTypedSymbol ts) m, f)-    _ -> Nothing-buildUGFun11111111 _ _ _ _ _ _ _ _ _ _ _ = error "Should only be called on SymTerm"--lowerSinglePrimUFun ::-  forall integerBitWidth a.-  GrisetteSMTConfig integerBitWidth ->-  Term a ->-  SymBiMap ->-  Maybe (SymBiMap, TermTy integerBitWidth a)-lowerSinglePrimUFun config t@(SymTerm _ _) m =-  case R.typeRep @a of-    TFun8Type t1 t2 t3 t4 t5 t6 t7 t8 -> buildUTFun11111111 config t1 t2 t3 t4 t5 t6 t7 t8 t m-    TFun7Type t1 t2 t3 t4 t5 t6 t7 -> buildUTFun1111111 config t1 t2 t3 t4 t5 t6 t7 t m-    TFun6Type t1 t2 t3 t4 t5 t6 -> buildUTFun111111 config t1 t2 t3 t4 t5 t6 t m-    TFun5Type t1 t2 t3 t4 t5 -> buildUTFun11111 config t1 t2 t3 t4 t5 t m-    TFun4Type t1 t2 t3 t4 -> buildUTFun1111 config t1 t2 t3 t4 t m-    TFun3Type t1 t2 t3 -> buildUTFun111 config t1 t2 t3 t m-    TFunType t1 t2 -> buildUTFun11 config t1 t2 t m-    GFun8Type t1 t2 t3 t4 t5 t6 t7 t8 -> buildUGFun11111111 config t1 t2 t3 t4 t5 t6 t7 t8 t m-    GFun7Type t1 t2 t3 t4 t5 t6 t7 -> buildUGFun1111111 config t1 t2 t3 t4 t5 t6 t7 t m-    GFun6Type t1 t2 t3 t4 t5 t6 -> buildUGFun111111 config t1 t2 t3 t4 t5 t6 t m-    GFun5Type t1 t2 t3 t4 t5 -> buildUGFun11111 config t1 t2 t3 t4 t5 t m-    GFun4Type t1 t2 t3 t4 -> buildUGFun1111 config t1 t2 t3 t4 t m-    GFun3Type t1 t2 t3 -> buildUGFun111 config t1 t2 t3 t m-    GFunType t1 t2 -> buildUGFun11 config t1 t2 t m-    _ -> Nothing-lowerSinglePrimUFun _ _ _ = error "Should not call this function"--class (Monad m) => SBVFreshMonad m where-  sbvFresh :: (SBV.SymVal a) => String -> m (SBV.SBV a)--instance (MonadIO m) => SBVFreshMonad (SBVT.SymbolicT m) where-  sbvFresh = SBVT.free--instance (MonadIO m) => SBVFreshMonad (SBVTC.QueryT m) where-  sbvFresh = SBVTC.freshVar--instance (SBVFreshMonad m) => SBVFreshMonad (ReaderT r m) where-  sbvFresh = lift . sbvFresh--instance (SBVFreshMonad m) => SBVFreshMonad (StateT s m) where-  sbvFresh = lift . sbvFresh--lowerUnaryTerm ::-  forall integerBitWidth a a1 x x1 m.-  (Typeable x1, a1 ~ TermTy integerBitWidth a, SupportedPrim x, HasCallStack, SBVFreshMonad m) =>-  GrisetteSMTConfig integerBitWidth ->-  Term x ->-  Term a ->-  (a1 -> x1) ->-  SymBiMap ->-  m (SymBiMap, x1)-lowerUnaryTerm config orig t1 f m = do-  (m1, l1) <- lowerSinglePrimCached config t1 m-  let g = f l1-  return (addBiMapIntermediate (SomeTerm orig) (toDyn g) m1, g)--lowerBinaryTerm ::-  forall integerBitWidth a b a1 b1 x x1 m.-  (Typeable x1, a1 ~ TermTy integerBitWidth a, b1 ~ TermTy integerBitWidth b, SupportedPrim x, HasCallStack, SBVFreshMonad m) =>-  GrisetteSMTConfig integerBitWidth ->-  Term x ->-  Term a ->-  Term b ->-  (a1 -> b1 -> x1) ->-  SymBiMap ->-  m (SymBiMap, x1)-lowerBinaryTerm config orig t1 t2 f m = do-  (m1, l1) <- lowerSinglePrimCached config t1 m-  (m2, l2) <- lowerSinglePrimCached config t2 m1-  let g = f l1 l2-  return (addBiMapIntermediate (SomeTerm orig) (toDyn g) m2, g)--lowerSinglePrimCached ::-  forall integerBitWidth a m.-  (HasCallStack, SBVFreshMonad m) =>-  GrisetteSMTConfig integerBitWidth ->-  Term a ->-  SymBiMap ->-  m (SymBiMap, TermTy integerBitWidth a)-lowerSinglePrimCached config t m =-  introSupportedPrimConstraint t $-    case (config, R.typeRep @a) of-      ResolvedDeepType ->-        case lookupTerm (SomeTerm t) m of-          Just x -> return (m, fromDyn x undefined)-          Nothing -> lowerSinglePrimImpl config t m-      _ -> translateTypeError (R.typeRep @a)--lowerSinglePrim ::-  forall integerBitWidth a m.-  (HasCallStack, SBVFreshMonad m) =>-  GrisetteSMTConfig integerBitWidth ->-  Term a ->-  m (SymBiMap, TermTy integerBitWidth a)-lowerSinglePrim config t = lowerSinglePrimCached config t emptySymBiMap--lowerSinglePrimImpl ::-  forall integerBitWidth a m.-  (HasCallStack, SBVFreshMonad m) =>-  GrisetteSMTConfig integerBitWidth ->-  Term a ->-  SymBiMap ->-  m (SymBiMap, TermTy integerBitWidth a)-lowerSinglePrimImpl config@ResolvedConfig {} (ConTerm _ v) m = return (m, lowerValue config v)-lowerSinglePrimImpl config t@(SymTerm _ ts) m =-  fromMaybe errorMsg $ asum [simple, ufunc]-  where-    errorMsg :: forall x. x-    errorMsg = translateTypeError (R.typeRep @a)-    simple :: Maybe (m (SymBiMap, TermTy integerBitWidth a))-    simple = case (config, R.typeRep @a) of-      ResolvedSimpleType -> Just $ do-        let name = show ts-        (g :: TermTy integerBitWidth a) <- sbvFresh name-        return (addBiMap (SomeTerm t) (toDyn g) name (someTypedSymbol ts) m, g)-      _ -> Nothing-    ufunc :: (Maybe (m (SymBiMap, TermTy integerBitWidth a)))-    ufunc = return <$> lowerSinglePrimUFun config t m-lowerSinglePrimImpl _ (UnaryTerm _ op (_ :: Term x)) _ = errorMsg-  where-    errorMsg :: forall t1. t1-    errorMsg = translateUnaryError (show op) (R.typeRep @x) (R.typeRep @a)-lowerSinglePrimImpl _ (BinaryTerm _ op (_ :: Term x) (_ :: Term y)) _ = errorMsg-  where-    errorMsg :: forall t1. t1-    errorMsg = translateBinaryError (show op) (R.typeRep @x) (R.typeRep @y) (R.typeRep @a)-lowerSinglePrimImpl ResolvedConfig {} (TernaryTerm _ op (_ :: Term x) (_ :: Term y) (_ :: Term z)) _ = errorMsg-  where-    errorMsg :: forall t1. t1-    errorMsg = translateTernaryError (show op) (R.typeRep @x) (R.typeRep @y) (R.typeRep @z) (R.typeRep @a)-lowerSinglePrimImpl config t@(NotTerm _ arg) m = lowerUnaryTerm config t arg SBV.sNot m-lowerSinglePrimImpl config t@(OrTerm _ arg1 arg2) m = lowerBinaryTerm config t arg1 arg2 (SBV..||) m-lowerSinglePrimImpl config t@(AndTerm _ arg1 arg2) m = lowerBinaryTerm config t arg1 arg2 (SBV..&&) m-lowerSinglePrimImpl config t@(EqvTerm _ (arg1 :: Term x) arg2) m =-  case (config, R.typeRep @x) of-    ResolvedSimpleType -> lowerBinaryTerm config t arg1 arg2 (SBV..==) m-    _ -> translateBinaryError "(==)" (R.typeRep @x) (R.typeRep @x) (R.typeRep @a)-lowerSinglePrimImpl config t@(ITETerm _ cond arg1 arg2) m =-  case (config, R.typeRep @a) of-    ResolvedMergeableType -> do-      (m1, l1) <- lowerSinglePrimCached config cond m-      (m2, l2) <- lowerSinglePrimCached config arg1 m1-      (m3, l3) <- lowerSinglePrimCached config arg2 m2-      let g = SBV.ite l1 l2 l3-      return (addBiMapIntermediate (SomeTerm t) (toDyn g) m3, g)-    _ -> translateBinaryError "ite" (R.typeRep @Bool) (R.typeRep @a) (R.typeRep @a) (R.typeRep @a)-lowerSinglePrimImpl config t@(AddNumTerm _ arg1 arg2) m =-  case (config, R.typeRep @a) of-    ResolvedNumType -> lowerBinaryTerm config t arg1 arg2 (+) m-    _ -> translateBinaryError "(+)" (R.typeRep @a) (R.typeRep @a) (R.typeRep @a)-lowerSinglePrimImpl config t@(UMinusNumTerm _ arg) m =-  case (config, R.typeRep @a) of-    ResolvedNumType -> lowerUnaryTerm config t arg negate m-    _ -> translateUnaryError "negate" (R.typeRep @a) (R.typeRep @a)-lowerSinglePrimImpl config t@(TimesNumTerm _ arg1 arg2) m =-  case (config, R.typeRep @a) of-    ResolvedNumType -> lowerBinaryTerm config t arg1 arg2 (*) m-    _ -> translateBinaryError "(*)" (R.typeRep @a) (R.typeRep @a) (R.typeRep @a)-lowerSinglePrimImpl config t@(AbsNumTerm _ arg) m =-  case (config, R.typeRep @a) of-    ResolvedNumType -> lowerUnaryTerm config t arg abs m-    _ -> translateUnaryError "abs" (R.typeRep @a) (R.typeRep @a)-lowerSinglePrimImpl config t@(SignumNumTerm _ arg) m =-  case (config, R.typeRep @a) of-    ResolvedNumType -> lowerUnaryTerm config t arg signum m-    _ -> translateUnaryError "signum" (R.typeRep @a) (R.typeRep @a)-lowerSinglePrimImpl config t@(LTNumTerm _ (arg1 :: Term arg) arg2) m =-  case (config, R.typeRep @arg) of-    ResolvedNumOrdType -> lowerBinaryTerm config t arg1 arg2 (SBV..<) m-    _ -> translateBinaryError "(<)" (R.typeRep @a) (R.typeRep @a) (R.typeRep @Bool)-lowerSinglePrimImpl config t@(LENumTerm _ (arg1 :: Term arg) arg2) m =-  case (config, R.typeRep @arg) of-    ResolvedNumOrdType -> lowerBinaryTerm config t arg1 arg2 (SBV..<=) m-    _ -> translateBinaryError "(<=)" (R.typeRep @a) (R.typeRep @a) (R.typeRep @Bool)-lowerSinglePrimImpl config t@(AndBitsTerm _ arg1 arg2) m =-  case (config, R.typeRep @a) of-    ResolvedBitsType -> lowerBinaryTerm config t arg1 arg2 (.&.) m-    _ -> translateBinaryError "(.&.)" (R.typeRep @a) (R.typeRep @a) (R.typeRep @a)-lowerSinglePrimImpl config t@(OrBitsTerm _ arg1 arg2) m =-  case (config, R.typeRep @a) of-    ResolvedBitsType -> lowerBinaryTerm config t arg1 arg2 (.|.) m-    _ -> translateBinaryError "(.|.)" (R.typeRep @a) (R.typeRep @a) (R.typeRep @a)-lowerSinglePrimImpl config t@(XorBitsTerm _ arg1 arg2) m =-  case (config, R.typeRep @a) of-    ResolvedBitsType -> lowerBinaryTerm config t arg1 arg2 xor m-    _ -> translateBinaryError "xor" (R.typeRep @a) (R.typeRep @a) (R.typeRep @a)-lowerSinglePrimImpl config t@(ComplementBitsTerm _ arg) m =-  case (config, R.typeRep @a) of-    ResolvedBitsType -> lowerUnaryTerm config t arg complement m-    _ -> translateUnaryError "complement" (R.typeRep @a) (R.typeRep @a)-lowerSinglePrimImpl config t@(ShiftLeftTerm _ arg n) m =-  case (config, R.typeRep @a) of-    ResolvedBitsType -> lowerBinaryTerm config t arg n sShiftLeft m-    _ -> translateBinaryError "shiftLeft" (R.typeRep @a) (R.typeRep @Int) (R.typeRep @a)-lowerSinglePrimImpl config t@(ShiftRightTerm _ arg n) m =-  case (config, R.typeRep @a) of-    ResolvedBitsType -> lowerBinaryTerm config t arg n sShiftRight m-    _ -> translateBinaryError "shiftRight" (R.typeRep @a) (R.typeRep @Int) (R.typeRep @a)--- SBV's rotateLeft and rotateRight are broken for signed values, so we have to--- do this--- https://github.com/LeventErkok/sbv/issues/673-lowerSinglePrimImpl config t@(RotateLeftTerm _ arg n) m =-  case (config, R.typeRep @a) of-    (_, SignedBVType (Proxy :: Proxy n)) ->-      lowerBinaryTerm-        config-        t-        arg-        n-        ( \x y ->-            SBV.sFromIntegral $-              sRotateLeft-                (SBV.sFromIntegral x :: SBV.SWord n)-                (SBV.sFromIntegral y :: SBV.SWord n)-        )-        m-    ResolvedBitsType -> lowerBinaryTerm config t arg n sRotateLeft m-    _ -> translateBinaryError "rotateLeft" (R.typeRep @a) (R.typeRep @Int) (R.typeRep @a)-lowerSinglePrimImpl config t@(RotateRightTerm _ arg n) m =-  case (config, R.typeRep @a) of-    (_, SignedBVType (Proxy :: Proxy n)) ->-      lowerBinaryTerm-        config-        t-        arg-        n-        ( \x y ->-            SBV.sFromIntegral $-              sRotateRight-                (SBV.sFromIntegral x :: SBV.SWord n)-                (SBV.sFromIntegral y :: SBV.SWord n)-        )-        m-    ResolvedBitsType -> lowerBinaryTerm config t arg n sRotateRight m-    _ -> translateBinaryError "rotateRight" (R.typeRep @a) (R.typeRep @Int) (R.typeRep @a)-lowerSinglePrimImpl config t@(ToSignedTerm _ (bv :: Term x)) m =-  case (R.typeRep @a, R.typeRep @x) of-    (SignedBVType (_ :: Proxy na), UnsignedBVType (_ :: Proxy nx)) ->-      case R.eqTypeRep (R.typeRep @na) (R.typeRep @nx) of-        Just R.HRefl ->-          lowerUnaryTerm config t bv SBV.sFromIntegral m-        _ -> translateUnaryError "u2s" (R.typeRep @x) (R.typeRep @a)-    _ -> translateUnaryError "u2s" (R.typeRep @x) (R.typeRep @a)-lowerSinglePrimImpl config t@(ToUnsignedTerm _ (bv :: Term x)) m =-  case (R.typeRep @a, R.typeRep @x) of-    (UnsignedBVType (_ :: Proxy na), SignedBVType (_ :: Proxy nx)) ->-      case R.eqTypeRep (R.typeRep @na) (R.typeRep @nx) of-        Just R.HRefl ->-          lowerUnaryTerm config t bv SBV.sFromIntegral m-        _ -> translateUnaryError "s2u" (R.typeRep @x) (R.typeRep @a)-    _ -> translateUnaryError "s2u" (R.typeRep @x) (R.typeRep @a)-lowerSinglePrimImpl config t@(BVConcatTerm _ (bv1 :: Term x) (bv2 :: Term y)) m =-  case (R.typeRep @a, R.typeRep @x, R.typeRep @y) of-    (UnsignedBVType (_ :: Proxy na), UnsignedBVType (_ :: Proxy nx), UnsignedBVType (_ :: Proxy ny)) ->-      case (unsafeAxiom @(nx + ny) @na) of-        Refl -> lowerBinaryTerm config t bv1 bv2 (SBV.#) m-    (SignedBVType (_ :: Proxy na), SignedBVType (_ :: Proxy nx), SignedBVType (_ :: Proxy ny)) ->-      case (unsafeAxiom @(nx + ny) @na) of-        Refl ->-          lowerBinaryTerm-            config-            t-            bv1-            bv2-            ( \(x :: SBV.SInt xn) (y :: SBV.SInt yn) ->-                SBV.sFromIntegral $-                  (SBV.sFromIntegral x :: SBV.SWord xn) SBV.# (SBV.sFromIntegral y :: SBV.SWord yn)-            )-            m-    _ -> translateBinaryError "bvconcat" (R.typeRep @x) (R.typeRep @y) (R.typeRep @a)-lowerSinglePrimImpl config t@(BVSelectTerm _ (ix :: R.TypeRep ix) w (bv :: Term x)) m =-  case (R.typeRep @a, R.typeRep @x) of-    (UnsignedBVType (_ :: Proxy na), UnsignedBVType (_ :: Proxy xn)) ->-      withKnownProof (unsafeKnownProof @(na + ix - 1) (natVal (Proxy @na) + natVal (Proxy @ix) - 1)) $-        case ( unsafeAxiom @(na + ix - 1 - ix + 1) @na,-               unsafeLeqProof @(na + ix - 1 + 1) @xn,-               unsafeLeqProof @ix @(na + ix - 1)-             ) of-          (Refl, LeqProof, LeqProof) ->-            lowerUnaryTerm config t bv (SBV.bvExtract (Proxy @(na + ix - 1)) (Proxy @ix)) m-    (SignedBVType (_ :: Proxy na), SignedBVType (_ :: Proxy xn)) ->-      withKnownProof (unsafeKnownProof @(na + ix - 1) (natVal (Proxy @na) + natVal (Proxy @ix) - 1)) $-        case ( unsafeAxiom @(na + ix - 1 - ix + 1) @na,-               unsafeLeqProof @(na + ix - 1 + 1) @xn,-               unsafeLeqProof @ix @(na + ix - 1)-             ) of-          (Refl, LeqProof, LeqProof) ->-            lowerUnaryTerm config t bv (SBV.bvExtract (Proxy @(na + ix - 1)) (Proxy @ix)) m-    _ -> translateTernaryError "bvselect" ix w (R.typeRep @x) (R.typeRep @a)-lowerSinglePrimImpl config t@(BVExtendTerm _ signed (n :: R.TypeRep n) (bv :: Term x)) m =-  case (R.typeRep @a, R.typeRep @x) of-    (UnsignedBVType (_ :: Proxy na), UnsignedBVType (_ :: Proxy nx)) ->-      withKnownProof (unsafeKnownProof @(na - nx) (natVal (Proxy @na) - natVal (Proxy @nx))) $-        case (unsafeLeqProof @(nx + 1) @na, unsafeLeqProof @1 @(na - nx)) of-          (LeqProof, LeqProof) ->-            bvIsNonZeroFromGEq1 @(na - nx) $-              lowerUnaryTerm config t bv (if signed then SBV.signExtend else SBV.zeroExtend) m-    (SignedBVType (_ :: Proxy na), SignedBVType (_ :: Proxy nx)) ->-      withKnownProof (unsafeKnownProof @(na - nx) (natVal (Proxy @na) - natVal (Proxy @nx))) $-        case (unsafeLeqProof @(nx + 1) @na, unsafeLeqProof @1 @(na - nx)) of-          (LeqProof, LeqProof) ->-            bvIsNonZeroFromGEq1 @(na - nx) $-              lowerUnaryTerm-                config-                t-                bv-                ( if signed-                    then SBV.signExtend-                    else \x ->-                      SBV.sFromIntegral-                        (SBV.zeroExtend (SBV.sFromIntegral x :: SBV.SBV (SBV.WordN nx)) :: SBV.SBV (SBV.WordN na))-                )-                m-    _ -> translateTernaryError "bvextend" (R.typeRep @Bool) n (R.typeRep @x) (R.typeRep @a)-lowerSinglePrimImpl config t@(TabularFunApplyTerm _ (f :: Term (b =-> a)) (arg :: Term b)) m =-  case (config, R.typeRep @a) of-    ResolvedDeepType -> do-      (m1, l1) <- lowerSinglePrimCached config f m-      (m2, l2) <- lowerSinglePrimCached config arg m1-      let g = l1 l2-      return (addBiMapIntermediate (SomeTerm t) (toDyn g) m2, g)-    _ -> translateBinaryError "tabularApply" (R.typeRep @(b =-> a)) (R.typeRep @b) (R.typeRep @a)-lowerSinglePrimImpl config t@(GeneralFunApplyTerm _ (f :: Term (b --> a)) (arg :: Term b)) m =-  case (config, R.typeRep @a) of-    ResolvedDeepType -> do-      (m1, l1) <- lowerSinglePrimCached config f m-      (m2, l2) <- lowerSinglePrimCached config arg m1-      let g = l1 l2-      return (addBiMapIntermediate (SomeTerm t) (toDyn g) m2, g)-    _ -> translateBinaryError "generalApply" (R.typeRep @(b --> a)) (R.typeRep @b) (R.typeRep @a)-lowerSinglePrimImpl config t@(DivIntegralTerm _ arg1 arg2) m =-  case (config, R.typeRep @a) of-    ResolvedSDivisibleType -> lowerBinaryTerm config t arg1 arg2 SBV.sDiv m-    _ -> translateBinaryError "div" (R.typeRep @a) (R.typeRep @a) (R.typeRep @a)-lowerSinglePrimImpl config t@(ModIntegralTerm _ arg1 arg2) m =-  case (config, R.typeRep @a) of-    ResolvedSDivisibleType -> lowerBinaryTerm config t arg1 arg2 SBV.sMod m-    _ -> translateBinaryError "mod" (R.typeRep @a) (R.typeRep @a) (R.typeRep @a)-lowerSinglePrimImpl config t@(QuotIntegralTerm _ arg1 arg2) m =-  case (config, R.typeRep @a) of-    ResolvedSDivisibleType -> lowerBinaryTerm config t arg1 arg2 SBV.sQuot m-    _ -> translateBinaryError "quot" (R.typeRep @a) (R.typeRep @a) (R.typeRep @a)-lowerSinglePrimImpl config t@(RemIntegralTerm _ arg1 arg2) m =-  case (config, R.typeRep @a) of-    ResolvedSDivisibleType -> lowerBinaryTerm config t arg1 arg2 SBV.sRem m-    _ -> translateBinaryError "rem" (R.typeRep @a) (R.typeRep @a) (R.typeRep @a)-lowerSinglePrimImpl config t@(DivBoundedIntegralTerm _ arg1 arg2) m =-  case (config, R.typeRep @a) of-    ResolvedSDivisibleType -> lowerBinaryTerm config t arg1 arg2 SBV.sDiv m-    _ -> translateBinaryError "div" (R.typeRep @a) (R.typeRep @a) (R.typeRep @a)-lowerSinglePrimImpl config t@(ModBoundedIntegralTerm _ arg1 arg2) m =-  case (config, R.typeRep @a) of-    ResolvedSDivisibleType -> lowerBinaryTerm config t arg1 arg2 SBV.sMod m-    _ -> translateBinaryError "mod" (R.typeRep @a) (R.typeRep @a) (R.typeRep @a)-lowerSinglePrimImpl config t@(QuotBoundedIntegralTerm _ arg1 arg2) m =-  case (config, R.typeRep @a) of-    ResolvedSDivisibleType -> lowerBinaryTerm config t arg1 arg2 SBV.sQuot m-    _ -> translateBinaryError "quot" (R.typeRep @a) (R.typeRep @a) (R.typeRep @a)-lowerSinglePrimImpl config t@(RemBoundedIntegralTerm _ arg1 arg2) m =-  case (config, R.typeRep @a) of-    ResolvedSDivisibleType -> lowerBinaryTerm config t arg1 arg2 SBV.sRem m-    _ -> translateBinaryError "rem" (R.typeRep @a) (R.typeRep @a) (R.typeRep @a)-lowerSinglePrimImpl _ _ _ = error "Should never happen"--bvIsNonZeroFromGEq1 :: forall w r. (1 <= w) => ((SBV.BVIsNonZero w) => r) -> r-bvIsNonZeroFromGEq1 r1 = case unsafeAxiom :: w :~: 1 of-  Refl -> r1--#if MIN_VERSION_sbv(10,3,0)-preprocessUIFuncs ::-  [(String, (Bool, SBVI.SBVType, Either String ([([SBVI.CV], SBVI.CV)], SBVI.CV)))] ->-  Maybe [(String, (SBVI.SBVType, ([([SBVI.CV], SBVI.CV)], SBVI.CV)))]-preprocessUIFuncs =-  traverse-    (\case-      (a, (_, b, Right c)) -> Just (a, (b, c))-      _ -> Nothing)-#elif MIN_VERSION_sbv(10,0,0)-preprocessUIFuncs ::-  [(String, (SBVI.SBVType, Either String ([([SBVI.CV], SBVI.CV)], SBVI.CV)))] ->-  Maybe [(String, (SBVI.SBVType, ([([SBVI.CV], SBVI.CV)], SBVI.CV)))]-preprocessUIFuncs =-  traverse-    (\case-      (a, (b, Right c)) -> Just (a, (b, c))-      _ -> Nothing)-#else-preprocessUIFuncs ::-  [(String, (SBVI.SBVType, ([([SBVI.CV], SBVI.CV)], SBVI.CV)))] ->-  Maybe [(String, (SBVI.SBVType, ([([SBVI.CV], SBVI.CV)], SBVI.CV)))]-preprocessUIFuncs = Just-#endif--parseModel :: forall integerBitWidth. GrisetteSMTConfig integerBitWidth -> SBVI.SMTModel -> SymBiMap -> PM.Model-parseModel _ (SBVI.SMTModel _ _ assoc orguifuncs) mp =-  case preprocessUIFuncs orguifuncs of-    Just uifuncs -> foldr gouifuncs (foldr goassoc emptyModel assoc) uifuncs-    _ -> error "SBV Failed to parse model"-  where-    goassoc :: (String, SBVI.CV) -> PM.Model -> PM.Model-    goassoc (name, cv) m = case findStringToSymbol name mp of-      Just (SomeTypedSymbol tr s) ->-        insertValue s (resolveSingle tr cv) m-      Nothing -> error "Bad"-    resolveSingle :: R.TypeRep a -> SBVI.CV -> a-    resolveSingle t (SBVI.CV SBVI.KBool (SBVI.CInteger n)) =-      case R.eqTypeRep t (R.typeRep @Bool) of-        Just R.HRefl -> n /= 0-        Nothing -> error "Bad type"-    resolveSingle t (SBVI.CV SBVI.KUnbounded (SBVI.CInteger i)) =-      case R.eqTypeRep t (R.typeRep @Integer) of-        Just R.HRefl -> i-        Nothing -> error "Bad type"-    resolveSingle t (SBVI.CV (SBVI.KBounded _ bitWidth) (SBVI.CInteger i)) =-      case R.eqTypeRep t (R.typeRep @Integer) of-        Just R.HRefl -> i-        _ -> case t of-          R.App a (n :: R.TypeRep w) ->-            case R.eqTypeRep (R.typeRepKind n) (R.typeRep @Nat) of-              Just R.HRefl ->-                case (unsafeKnownProof @w (fromIntegral bitWidth), unsafeLeqProof @1 @w) of-                  (KnownProof, LeqProof) ->-                    case (R.eqTypeRep a (R.typeRep @IntN), R.eqTypeRep a (R.typeRep @WordN)) of-                      (Just R.HRefl, _) ->-                        fromInteger i-                      (_, Just R.HRefl) -> fromInteger i-                      _ -> error "Bad type"-              _ -> error "Bad type"-          _ -> error "Bad type"-    resolveSingle _ _ = error "Unknown cv"--    buildConstFun :: (SupportedPrim a, SupportedPrim r) => R.TypeRep a -> R.TypeRep r -> SBVI.CV -> a =-> r-    buildConstFun _ tr v = case tr of-      TFunType (ta2' :: R.TypeRep a2) (tr2' :: R.TypeRep r2) -> TabularFun [] $ buildConstFun ta2' tr2' v-      _ -> TabularFun [] $ resolveSingle tr v--    goutfuncResolve ::-      forall a r.-      (SupportedPrim a, SupportedPrim r) =>-      R.TypeRep a ->-      R.TypeRep r ->-      ([([SBVI.CV], SBVI.CV)], SBVI.CV) ->-      (a =-> r)-    goutfuncResolve ta1 ta2 (l, s) =-      case ta2 of-        TFunType (ta2' :: R.TypeRep a2) (tr2' :: R.TypeRep r2) ->-          TabularFun-            (second (\r -> goutfuncResolve ta2' tr2' (r, s)) <$> partition ta1 l)-            (buildConstFun ta2' tr2' s)-        _ ->-          TabularFun-            (bimap (resolveSingle ta1 . head) (resolveSingle ta2) <$> l)-            (resolveSingle ta2 s)--    gougfuncResolve ::-      forall a r.-      (SupportedPrim a, SupportedPrim r) =>-      Int ->-      R.TypeRep a ->-      R.TypeRep r ->-      ([([SBVI.CV], SBVI.CV)], SBVI.CV) ->-      (a --> r)-    gougfuncResolve idx ta1 ta2 (l, s) =-      case ta2 of-        GFunType (ta2' :: R.TypeRep a2) (tr2' :: R.TypeRep r2) ->-          let sym = IndexedSymbol "arg" idx-              funs = second (\r -> gougfuncResolve (idx + 1) ta2' tr2' (r, s)) <$> partition ta1 l-              def = gougfuncResolve (idx + 1) ta2' tr2' ([], s)-              body =-                foldl'-                  ( \acc (v, f) ->-                      pevalITETerm-                        (pevalEqvTerm (symTerm sym) (conTerm v))-                        (conTerm f)-                        acc-                  )-                  (conTerm def)-                  funs-           in buildGeneralFun sym body-        _ ->-          let sym = IndexedSymbol "arg" idx-              vs = bimap (resolveSingle ta1 . head) (resolveSingle ta2) <$> l-              def = resolveSingle ta2 s-              body =-                foldl'-                  ( \acc (v, a) ->-                      pevalITETerm-                        (pevalEqvTerm (symTerm sym) (conTerm v))-                        (conTerm a)-                        acc-                  )-                  (conTerm def)-                  vs-           in buildGeneralFun sym body-    partition :: R.TypeRep a -> [([SBVI.CV], SBVI.CV)] -> [(a, [([SBVI.CV], SBVI.CV)])]-    partition t = case (R.eqTypeRep t (R.typeRep @Bool), R.eqTypeRep t (R.typeRep @Integer)) of-      (Just R.HRefl, _) -> partitionWithOrd . resolveFirst t-      (_, Just R.HRefl) -> partitionWithOrd . resolveFirst t-      _ -> case t of-        R.App bv _ -> case (R.eqTypeRep bv (R.typeRep @IntN), R.eqTypeRep bv (R.typeRep @WordN)) of-          (Just R.HRefl, _) -> fmap (first IntN) . partitionWithOrd . fmap (first unIntN) . resolveFirst t-          (_, Just R.HRefl) -> partitionWithOrd . resolveFirst t-          _ -> error "Unknown type"-        _ -> error "Unknown type"--    resolveFirst :: R.TypeRep a -> [([SBVI.CV], SBVI.CV)] -> [(a, [([SBVI.CV], SBVI.CV)])]-    resolveFirst tf = fmap (\case (x : xs, v) -> (resolveSingle tf x, [(xs, v)]); _ -> error "impossible")--    partitionWithOrd :: forall a. (Ord a) => [(a, [([SBVI.CV], SBVI.CV)])] -> [(a, [([SBVI.CV], SBVI.CV)])]-    partitionWithOrd v = go sorted-      where-        sorted = sortWith fst v-        go (x : x1 : xs) =-          if fst x == fst x1-            then go $ (fst x, snd x ++ snd x1) : xs-            else x : go (x1 : xs)-        go x = x--    gouifuncs :: (String, (SBVI.SBVType, ([([SBVI.CV], SBVI.CV)], SBVI.CV))) -> PM.Model -> PM.Model-    gouifuncs (name, (SBVI.SBVType _, l)) m = case findStringToSymbol name mp of-      Just (SomeTypedSymbol tr s) -> withSymbolSupported s $ case tr of-        t@(TFunType a r) -> R.withTypeable t $ insertValue s (goutfuncResolve a r l) m-        t@(GFunType a r) -> R.withTypeable t $ insertValue s (gougfuncResolve 0 a r l) m-        _ -> error "Bad"-      Nothing -> error "Bad"---- helpers--data BVTypeContainer bv k where-  BVTypeContainer :: (SBV.BVIsNonZero n, KnownNat n, 1 <= n, k ~ bv n) => Proxy n -> BVTypeContainer bv k--signedBVTypeView :: forall t. (SupportedPrim t) => R.TypeRep t -> Maybe (BVTypeContainer IntN t)-signedBVTypeView t = case t of-  R.App s (n :: R.TypeRep w) ->-    case (R.eqTypeRep s (R.typeRep @IntN), R.eqTypeRep (R.typeRepKind n) (R.typeRep @Nat)) of-      (Just R.HRefl, Just R.HRefl) ->-        Just $ unsafeBVIsNonZero @w $ withPrim (Proxy @t) (BVTypeContainer Proxy)-      _ -> Nothing-  _ -> Nothing-  where-    unsafeBVIsNonZero :: forall w r. ((SBV.BVIsNonZero w) => r) -> r-    unsafeBVIsNonZero r1 = case unsafeAxiom :: w :~: 1 of-      Refl -> r1--pattern SignedBVType ::-  forall t.-  (SupportedPrim t) =>-  forall (n :: Nat).-  (t ~~ IntN n, KnownNat n, 1 <= n, SBV.BVIsNonZero n) =>-  Proxy n ->-  R.TypeRep t-pattern SignedBVType p <- (signedBVTypeView @t -> Just (BVTypeContainer p))--unsignedBVTypeView :: forall t. (SupportedPrim t) => R.TypeRep t -> Maybe (BVTypeContainer WordN t)-unsignedBVTypeView t = case t of-  R.App s (n :: R.TypeRep w) ->-    case (R.eqTypeRep s (R.typeRep @WordN), R.eqTypeRep (R.typeRepKind n) (R.typeRep @Nat)) of-      (Just R.HRefl, Just R.HRefl) ->-        Just $ unsafeBVIsNonZero @w $ withPrim (Proxy @t) (BVTypeContainer Proxy)-      _ -> Nothing-  _ -> Nothing-  where-    unsafeBVIsNonZero :: forall w r. ((SBV.BVIsNonZero w) => r) -> r-    unsafeBVIsNonZero r1 = case unsafeAxiom :: w :~: 1 of-      Refl -> r1--pattern UnsignedBVType ::-  forall t.-  (SupportedPrim t) =>-  forall (n :: Nat).-  (t ~~ WordN n, KnownNat n, 1 <= n, SBV.BVIsNonZero n) =>-  Proxy n ->-  R.TypeRep t-pattern UnsignedBVType p <- (unsignedBVTypeView @t -> Just (BVTypeContainer p))--data TFunTypeContainer :: forall k. k -> Type where-  TFunTypeContainer :: (SupportedPrim a, SupportedPrim b) => R.TypeRep a -> R.TypeRep b -> TFunTypeContainer (a =-> b)--tFunTypeView :: forall t. (SupportedPrim t) => R.TypeRep t -> Maybe (TFunTypeContainer t)-tFunTypeView t = case t of-  R.App (R.App arr (ta2' :: R.TypeRep a2)) (tr2' :: R.TypeRep r2) ->-    case R.eqTypeRep arr (R.typeRep @(=->)) of-      Just R.HRefl -> Just $ withPrim (Proxy @t) $ TFunTypeContainer ta2' tr2'-      Nothing -> Nothing-  _ -> Nothing--pattern TFunType ::-  forall t.-  (SupportedPrim t) =>-  forall (a :: Type) (b :: Type).-  (t ~~ (a =-> b), SupportedPrim a, SupportedPrim b) =>-  R.TypeRep a ->-  R.TypeRep b ->-  R.TypeRep t-pattern TFunType a b <--  (tFunTypeView -> Just (TFunTypeContainer a b))-  where-    TFunType a b = R.App (R.App (R.typeRep @(=->)) a) b--pattern TFun3Type ::-  forall t.-  (SupportedPrim t) =>-  forall (a :: Type) (b :: Type) (c :: Type).-  (t ~~ (a =-> b =-> c), SupportedPrim a, SupportedPrim b, SupportedPrim c) =>-  R.TypeRep a ->-  R.TypeRep b ->-  R.TypeRep c ->-  R.TypeRep t-pattern TFun3Type a b c = TFunType a (TFunType b c)--pattern TFun4Type ::-  forall t.-  (SupportedPrim t) =>-  forall (a :: Type) (b :: Type) (c :: Type) (d :: Type).-  ( t ~~ (a =-> b =-> c =-> d),-    SupportedPrim a,-    SupportedPrim b,-    SupportedPrim c,-    SupportedPrim d-  ) =>-  R.TypeRep a ->-  R.TypeRep b ->-  R.TypeRep c ->-  R.TypeRep d ->-  R.TypeRep t-pattern TFun4Type a b c d = TFunType a (TFunType b (TFunType c d))--pattern TFun5Type ::-  forall t.-  (SupportedPrim t) =>-  forall (a :: Type) (b :: Type) (c :: Type) (d :: Type) (e :: Type).-  ( t ~~ (a =-> b =-> c =-> d =-> e),-    SupportedPrim a,-    SupportedPrim b,-    SupportedPrim c,-    SupportedPrim d,-    SupportedPrim e-  ) =>-  R.TypeRep a ->-  R.TypeRep b ->-  R.TypeRep c ->-  R.TypeRep d ->-  R.TypeRep e ->-  R.TypeRep t-pattern TFun5Type a b c d e =-  TFunType-    a-    ( TFunType-        b-        ( TFunType-            c-            (TFunType d e)-          )-      )--pattern TFun6Type ::-  forall t.-  (SupportedPrim t) =>-  forall-    (a :: Type)-    (b :: Type)-    (c :: Type)-    (d :: Type)-    (e :: Type)-    (f :: Type).-  ( t ~~ (a =-> b =-> c =-> d =-> e =-> f),-    SupportedPrim a,-    SupportedPrim b,-    SupportedPrim c,-    SupportedPrim d,-    SupportedPrim e,-    SupportedPrim f-  ) =>-  R.TypeRep a ->-  R.TypeRep b ->-  R.TypeRep c ->-  R.TypeRep d ->-  R.TypeRep e ->-  R.TypeRep f ->-  R.TypeRep t-pattern TFun6Type a b c d e f =-  TFunType-    a-    ( TFunType-        b-        ( TFunType-            c-            ( TFunType-                d-                (TFunType e f)-              )-          )-      )--pattern TFun7Type ::-  forall t.-  (SupportedPrim t) =>-  forall-    (a :: Type)-    (b :: Type)-    (c :: Type)-    (d :: Type)-    (e :: Type)-    (f :: Type)-    (g :: Type).-  ( t ~~ (a =-> b =-> c =-> d =-> e =-> f =-> g),-    SupportedPrim a,-    SupportedPrim b,-    SupportedPrim c,-    SupportedPrim d,-    SupportedPrim e,-    SupportedPrim f,-    SupportedPrim g-  ) =>-  R.TypeRep a ->-  R.TypeRep b ->-  R.TypeRep c ->-  R.TypeRep d ->-  R.TypeRep e ->-  R.TypeRep f ->-  R.TypeRep g ->-  R.TypeRep t-pattern TFun7Type a b c d e f g =-  TFunType-    a-    ( TFunType-        b-        ( TFunType-            c-            ( TFunType-                d-                ( TFunType-                    e-                    (TFunType f g)-                  )-              )-          )-      )--pattern TFun8Type ::-  forall t.-  (SupportedPrim t) =>-  forall-    (a :: Type)-    (b :: Type)-    (c :: Type)-    (d :: Type)-    (e :: Type)-    (f :: Type)-    (g :: Type)-    (h :: Type).-  ( t ~~ (a =-> b =-> c =-> d =-> e =-> f =-> g =-> h),-    SupportedPrim a,-    SupportedPrim b,-    SupportedPrim c,-    SupportedPrim d,-    SupportedPrim e,-    SupportedPrim f,-    SupportedPrim g,-    SupportedPrim h-  ) =>-  R.TypeRep a ->-  R.TypeRep b ->-  R.TypeRep c ->-  R.TypeRep d ->-  R.TypeRep e ->-  R.TypeRep f ->-  R.TypeRep g ->-  R.TypeRep h ->-  R.TypeRep t-pattern TFun8Type a b c d e f g h =-  TFunType-    a-    ( TFunType-        b-        ( TFunType-            c-            ( TFunType-                d-                ( TFunType-                    e-                    ( TFunType-                        f-                        (TFunType g h)-                      )-                  )-              )-          )-      )--data GFunTypeContainer :: forall k. k -> Type where-  GFunTypeContainer :: (SupportedPrim a, SupportedPrim b) => R.TypeRep a -> R.TypeRep b -> GFunTypeContainer (a --> b)--gFunTypeView :: forall t. (SupportedPrim t) => R.TypeRep t -> Maybe (GFunTypeContainer t)-gFunTypeView t = case t of-  R.App (R.App arr (ta2' :: R.TypeRep a2)) (tr2' :: R.TypeRep r2) ->-    case R.eqTypeRep arr (R.typeRep @(-->)) of-      Just R.HRefl -> Just $ withPrim (Proxy @t) $ GFunTypeContainer ta2' tr2'-      Nothing -> Nothing-  _ -> Nothing--pattern GFunType ::-  forall t.-  (SupportedPrim t) =>-  forall (a :: Type) (b :: Type).-  (t ~~ (a --> b), SupportedPrim a, SupportedPrim b) =>-  R.TypeRep a ->-  R.TypeRep b ->-  R.TypeRep t-pattern GFunType a b <--  (gFunTypeView -> Just (GFunTypeContainer a b))-  where-    GFunType a b = R.App (R.App (R.typeRep @(-->)) a) b--pattern GFun3Type ::-  forall t.-  (SupportedPrim t) =>-  forall (a :: Type) (b :: Type) (c :: Type).-  (t ~~ (a --> b --> c), SupportedPrim a, SupportedPrim b, SupportedPrim c) =>-  R.TypeRep a ->-  R.TypeRep b ->-  R.TypeRep c ->-  R.TypeRep t-pattern GFun3Type a b c = GFunType a (GFunType b c)--pattern GFun4Type ::-  forall t.-  (SupportedPrim t) =>-  forall (a :: Type) (b :: Type) (c :: Type) (d :: Type).-  ( t ~~ (a --> b --> c --> d),-    SupportedPrim a,-    SupportedPrim b,-    SupportedPrim c,-    SupportedPrim d-  ) =>-  R.TypeRep a ->-  R.TypeRep b ->-  R.TypeRep c ->-  R.TypeRep d ->-  R.TypeRep t-pattern GFun4Type a b c d = GFunType a (GFunType b (GFunType c d))--pattern GFun5Type ::-  forall t.-  (SupportedPrim t) =>-  forall (a :: Type) (b :: Type) (c :: Type) (d :: Type) (e :: Type).-  ( t ~~ (a --> b --> c --> d --> e),-    SupportedPrim a,-    SupportedPrim b,-    SupportedPrim c,-    SupportedPrim d,-    SupportedPrim e-  ) =>-  R.TypeRep a ->-  R.TypeRep b ->-  R.TypeRep c ->-  R.TypeRep d ->-  R.TypeRep e ->-  R.TypeRep t-pattern GFun5Type a b c d e =-  GFunType-    a-    ( GFunType-        b-        ( GFunType-            c-            (GFunType d e)-          )-      )--pattern GFun6Type ::-  forall t.-  (SupportedPrim t) =>-  forall-    (a :: Type)-    (b :: Type)-    (c :: Type)-    (d :: Type)-    (e :: Type)-    (f :: Type).-  ( t ~~ (a --> b --> c --> d --> e --> f),-    SupportedPrim a,-    SupportedPrim b,-    SupportedPrim c,-    SupportedPrim d,-    SupportedPrim e,-    SupportedPrim f-  ) =>-  R.TypeRep a ->-  R.TypeRep b ->-  R.TypeRep c ->-  R.TypeRep d ->-  R.TypeRep e ->-  R.TypeRep f ->-  R.TypeRep t-pattern GFun6Type a b c d e f =-  GFunType-    a-    ( GFunType-        b-        ( GFunType-            c-            ( GFunType-                d-                (GFunType e f)-              )-          )-      )--pattern GFun7Type ::-  forall t.-  (SupportedPrim t) =>-  forall-    (a :: Type)-    (b :: Type)-    (c :: Type)-    (d :: Type)-    (e :: Type)-    (f :: Type)-    (g :: Type).-  ( t ~~ (a --> b --> c --> d --> e --> f --> g),-    SupportedPrim a,-    SupportedPrim b,-    SupportedPrim c,-    SupportedPrim d,-    SupportedPrim e,-    SupportedPrim f,-    SupportedPrim g-  ) =>-  R.TypeRep a ->-  R.TypeRep b ->-  R.TypeRep c ->-  R.TypeRep d ->-  R.TypeRep e ->-  R.TypeRep f ->-  R.TypeRep g ->-  R.TypeRep t-pattern GFun7Type a b c d e f g =-  GFunType-    a-    ( GFunType-        b-        ( GFunType-            c-            ( GFunType-                d-                ( GFunType-                    e-                    (GFunType f g)-                  )-              )-          )-      )--pattern GFun8Type ::-  forall t.-  (SupportedPrim t) =>-  forall-    (a :: Type)-    (b :: Type)-    (c :: Type)-    (d :: Type)-    (e :: Type)-    (f :: Type)-    (g :: Type)-    (h :: Type).-  ( t ~~ (a --> b --> c --> d --> e --> f --> g --> h),-    SupportedPrim a,-    SupportedPrim b,-    SupportedPrim c,-    SupportedPrim d,-    SupportedPrim e,-    SupportedPrim f,-    SupportedPrim g,-    SupportedPrim h-  ) =>-  R.TypeRep a ->-  R.TypeRep b ->-  R.TypeRep c ->-  R.TypeRep d ->-  R.TypeRep e ->-  R.TypeRep f ->-  R.TypeRep g ->-  R.TypeRep h ->-  R.TypeRep t-pattern GFun8Type a b c d e f g h =-  GFunType-    a-    ( GFunType-        b-        ( GFunType-            c-            ( GFunType-                d-                ( GFunType-                    e-                    ( GFunType-                        f-                        (GFunType g h)-                      )-                  )-              )-          )-      )--pattern BoolType ::-  forall t.-  () =>-  (t ~~ Bool) =>-  R.TypeRep t-pattern BoolType <- (R.eqTypeRep (R.typeRep @Bool) -> Just R.HRefl)--pattern IntegerType ::-  forall t.-  () =>-  (t ~~ Integer) =>-  R.TypeRep t-pattern IntegerType <- (R.eqTypeRep (R.typeRep @Integer) -> Just R.HRefl)--type ConfigConstraint integerBitWidth s =-  ( SBV.SBV s ~ TermTy integerBitWidth Integer,-    SBV.SymVal s,-    SBV.HasKind s,-    Typeable s,-    Num (SBV.SBV s),-    Num s,-    SBV.OrdSymbolic (SBV.SBV s),-    Ord s,-    SBV.SDivisible (SBV.SBV s),-    SBV.OrdSymbolic (SBV.SBV s),-    SBV.Mergeable (SBV.SBV s)-  )--data DictConfig integerBitWidth where-  DictConfig ::-    forall s integerBitWidth.-    (ConfigConstraint integerBitWidth s) =>-    SBV.SMTConfig ->-    DictConfig integerBitWidth--resolveConfigView ::-  forall integerBitWidth.-  GrisetteSMTConfig integerBitWidth ->-  DictConfig integerBitWidth-resolveConfigView config = case config of-  GrisetteSMTConfig c extra ->-    case integerApprox extra of-      NoApprox -> DictConfig c-      Approx _ -> DictConfig c--pattern ResolvedConfig ::-  forall integerBitWidth.-  () =>-  forall s.-  (ConfigConstraint integerBitWidth s) =>-  SBV.SMTConfig ->-  GrisetteSMTConfig integerBitWidth-pattern ResolvedConfig c <- (resolveConfigView -> DictConfig c)--type MergeableTypeConstraint integerBitWidth s =-  ( Typeable (TermTy integerBitWidth s),-    SBV.Mergeable (TermTy integerBitWidth s)-  )---- has to declare this because GHC does not support impredicative polymorphism-data DictMergeableType integerBitWidth s where-  DictMergeableType ::-    forall integerBitWidth s.-    (MergeableTypeConstraint integerBitWidth s) =>-    DictMergeableType integerBitWidth s--resolveMergeableTypeView :: TypeResolver DictMergeableType-resolveMergeableTypeView (config@ResolvedConfig {}, s) = case s of-  BoolType -> Just DictMergeableType-  IntegerType -> Just DictMergeableType-  SignedBVType _ -> Just DictMergeableType-  UnsignedBVType _ -> Just DictMergeableType-  TFunType l r ->-    case (resolveSimpleTypeView (config, l), resolveMergeableTypeView (config, r)) of-      (Just DictSimpleType, Just DictMergeableType) -> Just DictMergeableType-      _ -> Nothing-  GFunType l r ->-    case (resolveSimpleTypeView (config, l), resolveMergeableTypeView (config, r)) of-      (Just DictSimpleType, Just DictMergeableType) -> Just DictMergeableType-      _ -> Nothing-  _ -> Nothing-resolveMergeableTypeView _ = error "Should never happen, make compiler happy"--pattern ResolvedMergeableType ::-  forall integerBitWidth s.-  (SupportedPrim s) =>-  (MergeableTypeConstraint integerBitWidth s) =>-  (GrisetteSMTConfig integerBitWidth, R.TypeRep s)-pattern ResolvedMergeableType <- (resolveMergeableTypeView -> Just DictMergeableType)--type SimpleTypeConstraint integerBitWidth s s' =-  ( SBV.SBV s' ~ TermTy integerBitWidth s,-    SBV.SymVal s',-    SBV.HasKind s',-    Typeable s',-    SBV.OrdSymbolic (SBV.SBV s'),-    SBV.Mergeable (SBV.SBV s')-  )--type TypeResolver dictType =-  forall integerBitWidth s.-  (SupportedPrim s) =>-  (GrisetteSMTConfig integerBitWidth, R.TypeRep s) ->-  Maybe (dictType integerBitWidth s)---- has to declare this because GHC does not support impredicative polymorphism-data DictSimpleType integerBitWidth s where-  DictSimpleType ::-    forall integerBitWidth s s'.-    (SimpleTypeConstraint integerBitWidth s s') =>-    DictSimpleType integerBitWidth s--resolveSimpleTypeView :: TypeResolver DictSimpleType-resolveSimpleTypeView (ResolvedConfig {}, s) = case s of-  BoolType -> Just DictSimpleType-  IntegerType -> Just DictSimpleType-  SignedBVType _ -> Just DictSimpleType-  UnsignedBVType _ -> Just DictSimpleType-  _ -> Nothing-resolveSimpleTypeView _ = error "Should never happen, make compiler happy"--pattern ResolvedSimpleType ::-  forall integerBitWidth s.-  (SupportedPrim s) =>-  forall s'.-  (SimpleTypeConstraint integerBitWidth s s') =>-  (GrisetteSMTConfig integerBitWidth, R.TypeRep s)-pattern ResolvedSimpleType <- (resolveSimpleTypeView -> Just DictSimpleType)--type DeepTypeConstraint integerBitWidth s s' =-  ( s' ~ TermTy integerBitWidth s,-    Typeable s',-    SBV.Mergeable s'-  )--data DictDeepType integerBitWidth s where-  DictDeepType ::-    forall integerBitWidth s s'.-    (DeepTypeConstraint integerBitWidth s s') =>-    DictDeepType integerBitWidth s--resolveDeepTypeView :: TypeResolver DictDeepType-resolveDeepTypeView r = case r of-  ResolvedSimpleType -> Just DictDeepType-  (config, TFunType (ta :: R.TypeRep a) (tb :: R.TypeRep b)) ->-    case (resolveDeepTypeView (config, ta), resolveDeepTypeView (config, tb)) of-      (Just DictDeepType, Just DictDeepType) -> Just DictDeepType-      _ -> Nothing-  (config, GFunType (ta :: R.TypeRep a) (tb :: R.TypeRep b)) ->-    case (resolveDeepTypeView (config, ta), resolveDeepTypeView (config, tb)) of-      (Just DictDeepType, Just DictDeepType) -> Just DictDeepType-      _ -> Nothing-  _ -> Nothing--pattern ResolvedDeepType ::-  forall integerBitWidth s.-  (SupportedPrim s) =>-  forall s'.-  (DeepTypeConstraint integerBitWidth s s') =>-  (GrisetteSMTConfig integerBitWidth, R.TypeRep s)-pattern ResolvedDeepType <- (resolveDeepTypeView -> Just DictDeepType)--type NumTypeConstraint integerBitWidth s s' =-  ( SimpleTypeConstraint integerBitWidth s s',-    Num (SBV.SBV s'),-    Num s',-    Num s-  )--data DictNumType integerBitWidth s where-  DictNumType ::-    forall integerBitWidth s s'.-    (NumTypeConstraint integerBitWidth s s') =>-    DictNumType integerBitWidth s--resolveNumTypeView :: TypeResolver DictNumType-resolveNumTypeView (ResolvedConfig {}, s) = case s of-  IntegerType -> Just DictNumType-  SignedBVType _ -> Just DictNumType-  UnsignedBVType _ -> Just DictNumType-  _ -> Nothing-resolveNumTypeView _ = error "Should never happen, make compiler happy"--pattern ResolvedNumType ::-  forall integerBitWidth s.-  (SupportedPrim s) =>-  forall s'.-  (NumTypeConstraint integerBitWidth s s') =>-  (GrisetteSMTConfig integerBitWidth, R.TypeRep s)-pattern ResolvedNumType <- (resolveNumTypeView -> Just DictNumType)--type SDivisibleTypeConstraint integerBitWidth s s' =-  ( SimpleTypeConstraint integerBitWidth s s',-    SBV.SDivisible (SBV.SBV s'),-    Integral s-  )--data DictSDivisibleType integerBitWidth s where-  DictSDivisibleType ::-    forall integerBitWidth s s'.-    (SDivisibleTypeConstraint integerBitWidth s s') =>-    DictSDivisibleType integerBitWidth s--resolveSDivisibleTypeView :: TypeResolver DictSDivisibleType-resolveSDivisibleTypeView (ResolvedConfig {}, s) = case s of-  IntegerType -> Just DictSDivisibleType-  SignedBVType _ -> Just DictSDivisibleType-  UnsignedBVType _ -> Just DictSDivisibleType-  _ -> Nothing-resolveSDivisibleTypeView _ = error "Should never happen, make compiler happy"--pattern ResolvedSDivisibleType ::-  forall integerBitWidth s.-  (SupportedPrim s) =>-  forall s'.-  (SDivisibleTypeConstraint integerBitWidth s s') =>-  (GrisetteSMTConfig integerBitWidth, R.TypeRep s)-pattern ResolvedSDivisibleType <- (resolveSDivisibleTypeView -> Just DictSDivisibleType)--type NumOrdTypeConstraint integerBitWidth s s' =-  ( NumTypeConstraint integerBitWidth s s',-    SBV.OrdSymbolic (SBV.SBV s'),-    Ord s',-    Ord s-  )--data DictNumOrdType integerBitWidth s where-  DictNumOrdType ::-    forall integerBitWidth s s'.-    (NumOrdTypeConstraint integerBitWidth s s') =>-    DictNumOrdType integerBitWidth s--resolveNumOrdTypeView :: TypeResolver DictNumOrdType-resolveNumOrdTypeView (ResolvedConfig {}, s) = case s of-  IntegerType -> Just DictNumOrdType-  SignedBVType _ -> Just DictNumOrdType-  UnsignedBVType _ -> Just DictNumOrdType-  _ -> Nothing-resolveNumOrdTypeView _ = error "Should never happen, make compiler happy"--pattern ResolvedNumOrdType ::-  forall integerBitWidth s.-  (SupportedPrim s) =>-  forall s'.-  (NumOrdTypeConstraint integerBitWidth s s') =>-  (GrisetteSMTConfig integerBitWidth, R.TypeRep s)-pattern ResolvedNumOrdType <- (resolveNumOrdTypeView -> Just DictNumOrdType)--type BitsTypeConstraint integerBitWidth s s' =-  ( SimpleTypeConstraint integerBitWidth s s',-    Bits (SBV.SBV s'),-    Bits s',-    Bits s,-    SIntegral s',-    Integral s-  )--data DictBitsType integerBitWidth s where-  DictBitsType ::-    forall integerBitWidth s s'.-    (BitsTypeConstraint integerBitWidth s s') =>-    DictBitsType integerBitWidth s--resolveBitsTypeView :: TypeResolver DictBitsType-resolveBitsTypeView (ResolvedConfig {}, s) = case s of-  SignedBVType _ -> Just DictBitsType-  UnsignedBVType _ -> Just DictBitsType-  _ -> Nothing-resolveBitsTypeView _ = error "Should never happen, make compiler happy"--pattern ResolvedBitsType ::-  forall integerBitWidth s.-  (SupportedPrim s) =>-  forall s'.-  (BitsTypeConstraint integerBitWidth s s') =>-  (GrisetteSMTConfig integerBitWidth, R.TypeRep s)-pattern ResolvedBitsType <- (resolveBitsTypeView -> Just DictBitsType)
− src/Grisette/Backend/SBV/Data/SMT/Solving.hs 
@@ -1,418 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneKindSignatures #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}---- |--- Module      :   Grisette.Backend.SBV.Data.SMT.Solving--- 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.Backend.SBV.Data.SMT.Solving-  ( -- * Term type computation-    TermTy,--    -- * SBV backend configuration-    ApproximationConfig (..),-    ExtraConfig (..),-    precise,-    approx,-    withTimeout,-    clearTimeout,-    withApprox,-    clearApprox,-    GrisetteSMTConfig (..),--    -- * SBV monadic solver interface-    SBVIncrementalT,-    SBVIncremental,-    runSBVIncrementalT,-    runSBVIncremental,--    -- * SBV solver handle-    SBVSolverHandle,-  )-where--import Control.Concurrent.Async (Async (asyncThreadId), async, wait)-import Control.Concurrent.STM-  ( TMVar,-    atomically,-    newTMVarIO,-    putTMVar,-    takeTMVar,-    tryReadTMVar,-    tryTakeTMVar,-  )-import Control.Concurrent.STM.TChan (TChan, newTChan, readTChan, writeTChan)-import Control.Exception (handle, throwTo)-import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Monad.Reader-  ( MonadReader (ask),-    MonadTrans (lift),-    ReaderT (runReaderT),-  )-import Control.Monad.STM (STM)-import Control.Monad.State (MonadState (get, put), StateT, evalStateT)-import Data.Kind (Type)-import qualified Data.SBV as SBV-import qualified Data.SBV.Control as SBVC-import qualified Data.SBV.Trans as SBVT-import qualified Data.SBV.Trans.Control as SBVTC-import GHC.IO.Exception (ExitCode (ExitSuccess))-import GHC.TypeNats (KnownNat, Nat)-import Grisette.Backend.SBV.Data.SMT.Lowering-  ( SymBiMap,-    lowerSinglePrimCached,-    parseModel,-  )-import Grisette.Backend.SBV.Data.SMT.SymBiMap (emptySymBiMap)-import Grisette.Core.Data.BV (IntN, WordN)-import Grisette.Core.Data.Class.Solver-  ( ConfigurableSolver (newSolver),-    MonadicSolver-      ( monadicSolverPop,-        monadicSolverPush,-        monadicSolverSolve-      ),-    Solver-      ( solverForceTerminate,-        solverRunCommand,-        solverSolve,-        solverTerminate-      ),-    SolverCommand (SolverPop, SolverPush, SolverSolve, SolverTerminate),-    SolvingFailure (SolvingError, Terminated, Unk, Unsat),-  )-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term-  ( type (-->),-  )-import Grisette.IR.SymPrim.Data.Prim.Model as PM-  ( Model,-  )-import Grisette.IR.SymPrim.Data.SymPrim (SymBool (SymBool))-import Grisette.IR.SymPrim.Data.TabularFun (type (=->))---- $setup--- >>> import Grisette.Core--- >>> import Grisette.IR.SymPrim--- >>> import Grisette.Backend.SBV--- >>> import Data.Proxy--type Aux :: Bool -> Nat -> Type-type family Aux o n where-  Aux 'True _ = SBV.SInteger-  Aux 'False n = SBV.SInt n--type IsZero :: Nat -> Bool-type family IsZero n where-  IsZero 0 = 'True-  IsZero _ = 'False--type TermTy :: Nat -> Type -> Type-type family TermTy bitWidth b where-  TermTy _ Bool = SBV.SBool-  TermTy n Integer = Aux (IsZero n) n-  TermTy _ (IntN x) = SBV.SBV (SBV.IntN x)-  TermTy _ (WordN x) = SBV.SBV (SBV.WordN x)-  TermTy n (a =-> b) = TermTy n a -> TermTy n b-  TermTy n (a --> b) = TermTy n a -> TermTy n b-  TermTy _ v = v---- | Configures how to approximate unbounded values.------ For example, if we use @'Approx' ('Data.Proxy' :: 'Data.Proxy' 4)@ to--- approximate the following unbounded integer:------ > (+ a 9)------ We will get------ > (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 `+`.------ Note that this approximation may not be sound. See 'GrisetteSMTConfig' for--- more details.-data ApproximationConfig (n :: Nat) where-  NoApprox :: ApproximationConfig 0-  Approx ::-    (KnownNat n, IsZero n ~ 'False, SBV.BVIsNonZero n) =>-    p n ->-    ApproximationConfig n---- | Grisette specific extra configurations for the SBV backend.-data ExtraConfig (i :: Nat) = ExtraConfig-  { -- | Timeout in milliseconds for each solver call. CEGIS may call the-    -- solver multiple times and each call has its own timeout.-    timeout :: Maybe Int,-    -- | Configures how to approximate unbounded integer values.-    integerApprox :: ApproximationConfig i-  }--preciseExtraConfig :: ExtraConfig 0-preciseExtraConfig =-  ExtraConfig-    { timeout = Nothing,-      integerApprox = NoApprox-    }--approximateExtraConfig ::-  (KnownNat n, IsZero n ~ 'False, SBV.BVIsNonZero n) =>-  p n ->-  ExtraConfig n-approximateExtraConfig p =-  ExtraConfig-    { timeout = Nothing,-      integerApprox = Approx p-    }---- | Solver configuration for the Grisette SBV backend.--- A Grisette solver configuration consists of a SBV solver configuration and--- the reasoning precision.------ 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.--- However, the solvers are known to have bad performance on some unbounded--- integer operations, for example, when reason about non-linear integer--- algebraic (e.g., multiplication or division),--- the solver may not be able to get a result in a reasonable time.--- In contrast, reasoning about bounded integers is usually more efficient.------ To bridge the performance gap between the two types of integers, Grisette--- allows to model the system with unbounded integers, and evaluate them with--- 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@):------ > (declare-fun a () Int)           ; declare symbolic constant a--- > (define-fun c1 () Int 5)         ; define the concrete value 5--- > (define-fun t1 () Int (* c1 a))  ; define the term------ While with reasoning precision 4, it would be translated to the following--- SMT (the term is @t1@):------ > ; declare symbolic constant a, the type is a bit vector with bit width 4--- > (declare-fun a () (_ BitVec 4))--- > ; define the concrete value 1, translated to the bit vector #x1--- > (define-fun c1 () (_ BitVec 4) #x5)--- > ; define the term, using bit vector addition rather than integer addition--- > (define-fun t1 () (_ BitVec 4) (bvmul c1 a))------ This bounded translation can usually be solved faster than the unbounded--- one, and should work well when no overflow is possible, in which case the--- performance can be improved with almost no cost.------ We must note that the bounded translation is an approximation and is--- __/not sound/__. As the approximation happens only during the final--- translation, the symbolic evaluation may aggressively optimize the term based--- on the properties of mathematical integer arithmetic. This may cause the--- solver yield results that is incorrect under both unbounded or bounded--- semantics.------ The following is an example that is correct under bounded semantics, while is--- incorrect under the unbounded semantics:------ >>> :set -XTypeApplications -XOverloadedStrings -XDataKinds--- >>> let a = "a" :: SymInteger--- >>> solve (precise z3) $ a .> 7 .&& a .< 9--- Right (Model {a -> 8 :: Integer})--- >>> solve (approx (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.-  (KnownNat n, IsZero n ~ 'False, SBV.BVIsNonZero n) =>-  p n ->-  SBV.SMTConfig ->-  GrisetteSMTConfig n-approx p config = GrisetteSMTConfig config (approximateExtraConfig p)---- | Set the timeout for the solver configuration.-withTimeout :: Int -> GrisetteSMTConfig i -> GrisetteSMTConfig i-withTimeout t config =-  config {extraConfig = (extraConfig config) {timeout = Just t}}---- | Clear the timeout for the solver configuration.-clearTimeout :: GrisetteSMTConfig i -> GrisetteSMTConfig i-clearTimeout config =-  config {extraConfig = (extraConfig config) {timeout = Nothing}}---- | Set the reasoning precision for the solver configuration.-withApprox ::-  (KnownNat n, IsZero n ~ 'False, SBV.BVIsNonZero 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"-sbvCheckSatResult SBVC.Unsat = Unsat-sbvCheckSatResult SBVC.Unk = Unk---- | Apply the timeout to the configuration.-applyTimeout ::-  (MonadIO m, SBVTC.MonadQuery m) => GrisetteSMTConfig i -> m a -> m a-applyTimeout config q = case timeout (extraConfig config) of-  Nothing -> q-  Just t -> SBVTC.timeout t q---- | Incremental solver monad transformer with the SBV backend.-type SBVIncrementalT n m =-  ReaderT (GrisetteSMTConfig n) (StateT SymBiMap (SBVTC.QueryT m))---- | Incremental solver monad with the SBV backend.-type SBVIncremental n = SBVIncrementalT n IO---- | Run the incremental solver monad with a given configuration.-runSBVIncremental :: GrisetteSMTConfig n -> SBVIncremental n a -> IO a-runSBVIncremental = runSBVIncrementalT---- | Run the incremental solver monad transformer with a given configuration.-runSBVIncrementalT ::-  (SBVTC.ExtractIO m) =>-  GrisetteSMTConfig n ->-  SBVIncrementalT n m a ->-  m a-runSBVIncrementalT config sbvIncrementalT =-  SBVT.runSMTWith (sbvConfig config) $-    SBVTC.query $-      applyTimeout config $-        flip evalStateT emptySymBiMap $-          runReaderT sbvIncrementalT config--instance (MonadIO m) => MonadicSolver (SBVIncrementalT n m) where-  monadicSolverSolve (SymBool formula) = do-    symBiMap <- get-    config <- ask-    (newSymBiMap, lowered) <- lowerSinglePrimCached config formula symBiMap-    lift $ lift $ SBV.constrain lowered-    put newSymBiMap-    checkSatResult <- SBVTC.checkSat-    case checkSatResult of-      SBVC.Sat -> do-        sbvModel <- SBVTC.getModel-        let model = parseModel config sbvModel newSymBiMap-        return $ Right model-      r -> return $ Left $ sbvCheckSatResult r-  monadicSolverPush = SBVTC.push-  monadicSolverPop = SBVTC.pop--data SBVSolverStatus = SBVSolverNormal | SBVSolverTerminated---- | The handle type for the SBV solver.------ See 'ConfigurableSolver' and 'Solver' for the interfaces.-data SBVSolverHandle = SBVSolverHandle-  { sbvSolverHandleMonad :: Async (),-    sbvSolverHandleStatus :: TMVar SBVSolverStatus,-    sbvSolverHandleInChan :: TChan SolverCommand,-    sbvSolverHandleOutChan :: TChan (Either SolvingFailure Model)-  }--setTerminated :: TMVar SBVSolverStatus -> STM ()-setTerminated status = do-  _ <- tryTakeTMVar status-  putTMVar status SBVSolverTerminated--instance ConfigurableSolver (GrisetteSMTConfig n) SBVSolverHandle where-  newSolver config = do-    sbvSolverHandleInChan <- atomically newTChan-    sbvSolverHandleOutChan <- atomically newTChan-    sbvSolverHandleStatus <- newTMVarIO SBVSolverNormal-    sbvSolverHandleMonad <- async $ do-      let handler e =-            liftIO $-              atomically $ do-                setTerminated sbvSolverHandleStatus-                writeTChan sbvSolverHandleOutChan (Left (SolvingError e))-      handle handler $ runSBVIncremental config $ do-        let loop = do-              nextFormula <- liftIO $ atomically $ readTChan sbvSolverHandleInChan-              case nextFormula of-                SolverPush n -> monadicSolverPush n >> loop-                SolverPop n -> monadicSolverPop n >> loop-                SolverTerminate -> return ()-                SolverSolve formula -> do-                  r <- monadicSolverSolve formula-                  liftIO $ atomically $ writeTChan sbvSolverHandleOutChan r-                  loop-        loop-        liftIO $ atomically $ do-          setTerminated sbvSolverHandleStatus-          writeTChan sbvSolverHandleOutChan $ Left Terminated-    return $ SBVSolverHandle {..}--instance Solver SBVSolverHandle where-  solverRunCommand f handle@(SBVSolverHandle _ status inChan _) command = do-    st <- liftIO $ atomically $ takeTMVar status-    case st of-      SBVSolverNormal -> do-        liftIO $ atomically $ writeTChan inChan command-        r <- f handle-        liftIO $ atomically $ do-          currStatus <- tryReadTMVar status-          case currStatus of-            Nothing -> putTMVar status SBVSolverNormal-            Just _ -> return ()-        return r-      SBVSolverTerminated -> do-        liftIO $ atomically $ setTerminated status-        return $ Left Terminated-  solverSolve handle nextFormula =-    solverRunCommand-      ( \(SBVSolverHandle _ _ _ outChan) ->-          liftIO $ atomically $ readTChan outChan-      )-      handle-      $ SolverSolve nextFormula-  solverTerminate (SBVSolverHandle thread status inChan _) = do-    liftIO $ atomically $ do-      setTerminated status-      writeTChan inChan SolverTerminate-    wait thread-  solverForceTerminate (SBVSolverHandle thread status _ outChan) = do-    liftIO $ atomically $ do-      setTerminated status-      writeTChan outChan (Left Terminated)-    throwTo (asyncThreadId thread) ExitSuccess-    wait thread
− src/Grisette/Backend/SBV/Data/SMT/Solving.hs-boot 
@@ -1,54 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE StandaloneKindSignatures #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}--module Grisette.Backend.SBV.Data.SMT.Solving-  ( ApproximationConfig (..),-    ExtraConfig (..),-    GrisetteSMTConfig (..),-    TermTy,-  )-where--import Data.Kind (Type)-import qualified Data.SBV as SBV-import GHC.TypeNats (KnownNat, Nat)-import Grisette.Core.Data.BV (IntN, WordN)-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term-  ( type (-->),-  )-import Grisette.IR.SymPrim.Data.TabularFun (type (=->))--type Aux :: Bool -> Nat -> Type-type family Aux o n where-  Aux 'True _ = SBV.SInteger-  Aux 'False n = SBV.SInt n--type IsZero :: Nat -> Bool-type family IsZero n where-  IsZero 0 = 'True-  IsZero _ = 'False--type TermTy :: Nat -> Type -> Type-type family TermTy bitWidth b where-  TermTy _ Bool = SBV.SBool-  TermTy n Integer = Aux (IsZero n) n-  TermTy _ (IntN x) = SBV.SBV (SBV.IntN x)-  TermTy _ (WordN x) = SBV.SBV (SBV.WordN x)-  TermTy n (a =-> b) = TermTy n a -> TermTy n b-  TermTy n (a --> b) = TermTy n a -> TermTy n b-  TermTy _ v = v--data ApproximationConfig (n :: Nat) where-  NoApprox :: ApproximationConfig 0-  Approx :: (KnownNat n, IsZero n ~ 'False, SBV.BVIsNonZero n) => p n -> ApproximationConfig n--data ExtraConfig (i :: Nat) = ExtraConfig-  { timeout :: Maybe Int,-    integerApprox :: ApproximationConfig i-  }--data GrisetteSMTConfig (i :: Nat) = GrisetteSMTConfig {sbvConfig :: SBV.SMTConfig, extraConfig :: ExtraConfig i}
− src/Grisette/Backend/SBV/Data/SMT/SymBiMap.hs 
@@ -1,54 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}---- |--- Module      :   Grisette.Backend.SBV.Data.SMT.SymBiMap--- 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.Backend.SBV.Data.SMT.SymBiMap-  ( SymBiMap (..),-    emptySymBiMap,-    sizeBiMap,-    addBiMap,-    addBiMapIntermediate,-    findStringToSymbol,-    lookupTerm,-  )-where--import Data.Dynamic (Dynamic)-import qualified Data.HashMap.Strict as M-import GHC.Stack (HasCallStack)-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.SomeTerm-  ( SomeTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term-  ( SomeTypedSymbol,-  )--data SymBiMap = SymBiMap-  { biMapToSBV :: M.HashMap SomeTerm Dynamic,-    biMapFromSBV :: M.HashMap String SomeTypedSymbol-  }-  deriving (Show)--emptySymBiMap :: SymBiMap-emptySymBiMap = SymBiMap M.empty M.empty--sizeBiMap :: SymBiMap -> Int-sizeBiMap = M.size . biMapToSBV--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)--addBiMapIntermediate :: (HasCallStack) => SomeTerm -> Dynamic -> SymBiMap -> SymBiMap-addBiMapIntermediate s d (SymBiMap t f) = SymBiMap (M.insert s d t) f--findStringToSymbol :: String -> SymBiMap -> Maybe SomeTypedSymbol-findStringToSymbol s (SymBiMap _ f) = M.lookup s f--lookupTerm :: (HasCallStack) => SomeTerm -> SymBiMap -> Maybe Dynamic-lookupTerm t m = M.lookup t (biMapToSBV m)
src/Grisette/Core.hs view
@@ -1,1244 +1,1881 @@-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE Trustworthy #-}--- Disable this warning because we are re-exporting things.-{-# OPTIONS_GHC -Wno-missing-import-lists #-}---- |--- Module      :   Grisette.Core--- 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.Core-  ( -- * Note for the examples--    ----    -- | The examples may assume a [z3](https://github.com/Z3Prover/z3) solver available in @PATH@.--    -- * Symbolic values--    -- | Grisette is a tool for performing symbolic evaluation on programs.-    -- 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-    -- symbolic constraints over these values.-    -- These constraints can then be used to find concrete assignments to the-    -- 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-    -- 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.-    ---    -- 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-    -- 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-    -- can significantly reduce the number of paths that need to be explored.-    ---    -- For example, there are three symbolic Booleans @a@, @b@ and @c@, in the-    -- following code, and a symbolic Boolean @x@ is defined to be the result of-    -- a conditional expression:-    ---    -- > x = if a then b else c -- pseudo code, not real Grisette code-    ---    -- The result would be a single symbolic Boolean formula:-    ---    -- > -- result: x is (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))-    ---    -- __/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.-    -- The values of unsolvable types are __/partially/__ merged in a symbolic-    -- union, which is essentially an if-then-else tree.-    ---    -- For example, assume that the lists have the type-    -- @['Grisette.IR.SymPrim.SymBool']@.-    -- In the following example, the result shows that @[b]@ and @[c]@ can be-    -- merged together in the same symbolic union because they have the same-    -- length:-    ---    -- > x = if a then [b] else [c] -- pseudo code, not real Grisette code-    -- > -- result: Single [(ite a b c)]-    ---    -- 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])-    ---    -- 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])-    ---    -- 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:-    ---    -- > head (if a1 then [b] else if a2 then [c, d] else [f]) -- 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:-    ---    -- > -- final result: Single (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-    -- conditions larger and harder to solve. To have a good balance between-    -- 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.--    -- ** 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.IR.SymPrim.SymBool' (symbolic Booleans)-    -- * 'Grisette.IR.SymPrim.SymInteger' (symbolic unbounded integers)-    -- * @'Grisette.IR.SymPrim.SymIntN' n@ (symbolic signed bit vectors of length @n@)-    -- * @'Grisette.IR.SymPrim.SymWordN' n@ (symbolic unsigned bit vectors of length @n@)-    ---    -- The two bit vector types has their lengths checked at compile time.-    -- Grisette also provides runtime-checked versions of these types:-    -- 'Grisette.IR.SymPrim.SomeSymIntN' and 'Grisette.IR.SymPrim.SomeSymWordN'.-    ---    -- Values of a solvable type can consist of concrete values, symbolic-    -- constants (placeholders for concrete values that can be assigned by a-    -- solver to satisfy a formula), and complex symbolic formulas with-    -- symbolic operations. The `Solvable` type class provides a way to-    -- construct concrete values and symbolic constants.-    ---    -- __Examples:__-    ---    -- >>> import Grisette-    -- >>> con True :: SymBool -- a concrete value-    -- true-    -- >>> ssym "a" :: SymBool -- a symbolic constant-    -- a-    ---    -- With the @OverloadedStrings@ GHC extension enabled, symbolic constants-    -- can also be constructed from strings.-    ---    -- >>> :set -XOverloadedStrings-    -- >>> "a" :: SymBool-    -- a-    ---    -- Symbolic operations are provided through a set of type classes,-    -- such as 'SEq', 'SOrd', and 'Num'. Please check out the documentation for-    -- more details.-    ---    -- __Examples:__-    ---    -- >>> let a = "a" :: SymInteger-    -- >>> let b = "b" :: SymInteger-    -- >>> a .== b-    -- (= a b)--    -- *** Creation of solvable type values-    Solvable (..),-    pattern Con,-    slocsym,-    ilocsym,--    -- *** Symbolic operators--    -- | #symop#-    LogicalOp (..),-    ITEOp (..),-    SEq (..),-    SOrd (..),-    BV (..),-    bvExtract,-    SizedBV (..),-    sizedBVExtract,-    SignConversion (..),-    SafeDivision (..),-    SafeLinearArith (..),-    Function (..),-    Apply (..),--    -- ** Unsolvable types--    -- | 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/__.-    -- 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'.-    -- Two constructs are useful in constructing symbolic union values: 'mrgIf'-    -- and 'mrgSingle'.-    -- 'mrgSingle' unconditionally wraps a value in a symbolic union container,-    -- while 'mrgIf' models branching control flow semantics with symbolic-    -- conditions.-    -- Here are some examples of using 'mrgSingle' and 'mrgIf':-    ---    -- >>> mrgSingle ["a"] :: UnionM [SymInteger]-    -- {[a]}-    -- >>> mrgIf "a" (mrgSingle ["b"]) (mrgSingle ["c", "d"]) :: UnionM [SymInteger]-    -- {If a [b] [c,d]}-    ---    -- 'UnionM' 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-    -- modeled in Grisette with the combinators provided by Grisette, and the do-notation:-    ---    -- > x = if a then [b] else [b,c] -- pseudo code, not Grisette code-    -- > y = if d then [e] else [e,f]-    -- > return (x ++ y :: [SymInteger])-    ---    -- >>> :{-    --   ret :: UnionM [SymInteger]-    --   ret = do x <- mrgIf "a" (single ["b"]) (single ["b","c"])-    --            y <- mrgIf "d" (single ["e"]) (single ["e","f"])-    --            mrgReturn $ x ++ y -- we will explain mrgReturn later-    -- :}-    ---    -- When this code is evaluated, the result would be as follows:-    ---    -- >>> ret-    -- {If (&& a d) [b,e] (If (|| a d) [b,(ite a e c),(ite a f e)] [b,c,e,f])}-    ---    -- In the result, we can see that the results are reorganized and the two-    -- lists with the same length are merged together.-    -- 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-    -- 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),-    -- as the 'return' function from the 'Monad' type class cannot resolve-    -- extra constraints.-    -- Our solution to this problem with merging strategy caching is inspired-    -- 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',-    -- 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-    -- <1>-    -- >>> mrgReturn 1 :: UnionM Integer-    -- {1}-    -- >>> mrgIf "a" (return 1) (return 2) :: UnionM 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.-    ---    -- 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.-    -- Those functions that merges the results can also further propagate the-    -- cached merging strategy, note that 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-    -- {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-    -- 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-    --     deriving (Generic, Show)-    --     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:-    ---    -- >>> mrgIf "c1" (mrgSingle $ X "b" 1) (mrgIf "c2" (mrgSingle $ X "c" 2) (mrgSingle $ X "d" 1)) :: UnionM 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-    -- 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.-    ---    -- Here's an example using the 'Control.Monad.Except.ExceptT' transformer-    -- to model error handling in Grisette:-    ---    -- >>> import Control.Monad.Except-    -- >>> :{-    --   data Error = Fail-    --     deriving (Show, Generic)-    --     deriving (Mergeable) via (Default Error)-    -- :}-    ---    -- >>> mrgIf "a" (throwError Fail) (return "x") :: ExceptT Error UnionM 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.__-    -- __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.__-    ---    -- In Grisette, the symbolic union has the Ordered Guards (ORG)-    -- representation, which can be viewed as a nested if-then-else with some-    -- representation invariant.-    ---    -- For example, the following symbolic union represents a symbolic list of-    -- 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.-    -- \]-    ---    -- In Haskell syntax, the container is represented as the following nested-    -- if-then-else tree-    ---    -- > If c1 [a] (If c2 [b,b] [a,b,c])-    ---    -- The representations means that when @c1@ is true, then the value is a-    -- list @[a]@, or when @c1@ is false and @c2@ is true, the value is a list-    -- @[b,b]@, or otherwise the value is @[a,b,c]@.-    ---    -- This representation allows you to use-    -- the constructs that are not supported by the underlying solvers freely.-    -- For example, when applying 'head' on this structure, we can just-    -- 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}\\-    --     &\texttt{head [a,b,c]}&&\mathrm{otherwise}-    --   \end{aligned}\right.-    -- \]-    ---    -- or, equivalently-    ---    -- \[-    --   \left\{\begin{aligned}-    --     &\texttt{a}&&\mathrm{if}&&\texttt{c1}\\-    --     &\texttt{b}&&\mathrm{else~if}&&\texttt{c2}\\-    --     &\texttt{a}&&\mathrm{otherwise}-    --   \end{aligned}\right.-    -- \]-    ---    -- Further symbolic evaluation will also distribute computations-    -- over the branches in this result, and the identical branches will cause-    -- redundant computation. To mitigate this, Grisette would try to merge-    -- 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}\\-    --   \end{aligned}\right.-    -- \]-    ---    -- Note that if the contained type is symbolic Boolean, we may further merge-    -- the values into a single formula.-    ---    -- \[-    --   \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.-    -- 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-    -- example, the two ORG containers passed to the 'mrgIf' are sorted-    -- with the natural ordering on the integers. In the result, the values are-    -- also organized in a sorted way, and the path conditions are correctly-    -- 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}-    --   \end{aligned}\right.-    -- \]-    ---    -- So far, we have described ORG as a flat list of values.-    -- When the list is long, it is beneficial to partition the values and merge-    -- (some or all) partitions into nested ORG values.-    -- This hierarchical ORG representation is particularly useful for complex-    -- data types, such as tuples, which tend to yield long lists.-    ---    -- In the following example, @v*@ are values, while @t*@ are ORG containers.-    -- The values in the containers are first partitioned into three groups:-    -- @{v11, v12, v13}@, @{v2}@, and @{v13}@.-    -- In each group, the values share some common features, (e.g., they are-    -- constructed with the same data constructor).-    -- The values in each group are organized in a subtree, e.g., the first group-    -- is organized in the subtree @t1@.-    -- The hierarchical representation also keeps a representation invariant:-    -- at each level in the hierarchy, the values (or the subtrees) are also sorted-    -- by some criteria. Here, in the first level, the values are sorted by the-    -- constructor declaration order, and in the second level, the values are sorted-    -- by the concrete field in the constructor @A@.-    -- This criteria is given by the 'MergingStrategy' in the 'Mergeable' class,-    -- called the root merging strategy of the type.-    ---    -- > 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}&&-    --   \end{aligned}\right.-    -- \]-    ---    -- In Haskell syntax, it can be represented as follows:-    ---    -- > If      c1    (If c11 (A 1 a) (If c12 (A 3 b) (A 4 (&& x y))))-    -- >   (If   c2    B-    -- >               C)-    ---    -- All the symbolic unions in Grisette should maintain the hierarchical-    -- sorted invariant, and are sorted in the same way, with respect to the same-    -- merging strategy (the root merging strategy for the type).-    -- We can then merge the containers with a hierarchical-    -- merging algorithm: at each level, we align the values and subtrees, and merge-    -- the aligned ones. In the following example, 'mrgIf' resolves the root merging-    -- strategy @s@, and calls the function @mrgIf'@, which accepts the merging strategy-    -- as an argument. The symbolic union operands to the @mrgIf'@ function must be-    -- sorted with the merging strategy passed to the function.-    ---    -- Here we use the name of the subtrees and values to indicate the order of them:-    ---    -- * @t1@ should be placed before @v3@ in the @then@ branch,-    -- * @t1@ and @v4@ can be aligned with @t1'@ and @v4'@, respectively.-    ---    -- The aligned subtrees will be merged recursively with @mrgIf'@, with a-    -- __/sub-strategy/__ given by the merging strategy @s@ for the subtrees.-    -- For example, @t1@ and @t1'@ will be merged with the sub-strategy @s'@.-    -- The aligned values will be merged with a merging function, also given by-    -- the merging strategy @s@. For example, @v4@ and @v4'@ will be merged with-    -- the merging function @f'@.-    ---    -- The ordering and the sub-strategies are abstracted with 'SortedStrategy',-    -- and the merging functions will be wrapped in 'SimpleStrategy'.-    -- The merging algorithm can then be configured by implementing the merging-    -- strategies for the types contained in a symbolic union. See the documentation-    -- 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}-    --       \end{aligned}\right.-    --   \end{aligned}-    -- \]-    ---    -- For more details of the algorithm, please refer to-    -- [Grisette's paper](https://lsrcz.github.io/files/POPL23.pdf).--    -- *** UnionM Monad-    UnionM,-    IsConcrete,-    makeUnionWrapper,-    makeUnionWrapper',-    liftToMonadUnion,-    unionSize,--    -- *** Merging--    -- **** Mergeable-    Mergeable (..),-    Mergeable1 (..),-    rootStrategy1,-    Mergeable2 (..),-    rootStrategy2,-    Mergeable3 (..),-    rootStrategy3,--    -- **** Merging strategy-    MergingStrategy (..),-    derivedRootStrategy,--    -- **** Manual merging strategy construction-    wrapStrategy,-    product2Strategy,-    DynamicSortedIdx (..),-    StrategyList (..),-    buildStrategyList,-    resolveStrategy,-    resolveStrategy',--    -- **** Simple mergeable types-    SimpleMergeable (..),-    SimpleMergeable1 (..),-    mrgIte1,-    SimpleMergeable2 (..),-    mrgIte2,--    -- **** UnionLike operations-    UnionLike (..),-    mrgIf,-    merge,-    mrgSingle,-    UnionPrjOp (..),-    pattern Single,-    pattern If,-    MonadUnion,-    MonadParallelUnion (..),-    simpleMerge,-    onUnion,-    onUnion2,-    onUnion3,-    onUnion4,-    (.#),--    -- * Conversion between Concrete and Symbolic values-    ToCon (..),-    ToSym (..),--    -- * Pretty printing-    GPretty (..),--    -- * Symbolic Generation--    -- | It is usually useful to generate complex symbolic values. For example,-    -- in program synthesis task, we may want to generate symbolic programs-    -- to represent the search space given some specification.-    ---    -- To help with this, we provide a set of classes and functions. The core-    -- of the symbolic generation is the 'Fresh' monad, the 'GenSymSimple' class,-    -- and the 'GenSym' class.-    ---    -- The 'Fresh' monad is a combination of specialized state and reader-    -- monads. It keeps an identifier, and an index. The generated symbolic-    -- constants would be constructed with both the identifier and the index.-    -- Each time a new symbolic constant is generated, the index would be-    -- incremented. This keeps that the generated symbolic constants are unique.-    ---    -- The 'GenSymSimple' class helps generate symbolic values that do not require-    -- a symbolic union, for example, symbolic Booleans.-    -- It provides the 'simpleFresh' function, which accepts a specification-    -- for the symbolic values to generate.-    ---    -- We do not need any specification to generate a symbolic Boolean, so-    -- we provide a unit value as the specification:-    ---    -- >>> runFresh (simpleFresh ()) "x" :: SymBool-    -- x@0-    ---    -- We can generate a list of symbolic Booleans by specifying the length-    -- of the list, and the specification for the elements. The two elements-    -- in the generated list are unique as they have different indices.-    ---    -- >>> runFresh (simpleFresh (SimpleListSpec 2 ())) "x" :: [SymBool]-    -- [x@0,x@1]-    -- >>> runFresh (simpleFresh (SimpleListSpec 2 (SimpleListSpec 1 ()))) "x" :: [[SymBool]]-    -- [[x@0],[x@1]]-    ---    -- The 'GenSym' class helps generate symbolic values that require a symbolic-    -- union, for example, lists with different lengths.-    -- It provides the 'fresh' function, which accepts a specification-    -- for the symbolic values to generate.-    ---    -- 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]-    -- {If x@2 [] (If x@3 [x@1] [x@0,x@1])}-    ---    -- We can generate many symbolic values at once with the 'Fresh' monad.-    -- The symbolic constants are ensured to be unique:-    ---    -- >>> :set -XScopedTypeVariables-    -- >>> :{-    --   flip runFresh "x" $ do-    --     a :: SymBool <- simpleFresh ()-    --     b :: UnionM [SymBool] <- fresh (ListSpec 0 2 ())-    --     return (a, b)-    -- :}-    -- (x@0,{If x@3 [] (If x@4 [x@2] [x@1,x@2])})-    ---    -- When you are just generating a symbolic value, and do not need to compose-    -- multiple 'simpleFresh' or 'fresh' calls, you can use the 'genSym' and-    -- 'genSymSimple' functions instead.-    ---    -- >>> genSymSimple (SimpleListSpec 2 ()) "x" :: [SymBool]-    -- [x@0,x@1]-    -- >>> genSym (ListSpec 0 2 ()) "x" :: UnionM [SymBool]-    -- {If x@2 [] (If x@3 [x@1] [x@0,x@1])}-    ---    -- Symbolic choices from a list of symbolic values is very useful.-    -- With the 'chooseFresh' function,-    -- we can generate a symbolic value by choosing from a list of-    -- alternative values.-    -- Grisette would generate symbolic Boolean guards to perform the symbolic-    -- choice.-    ---    -- >>> :{-    --   (flip runFresh "x" $ do-    --     a <- simpleFresh ()-    --     b <- simpleFresh ()-    --     chooseFresh [[a],[a,b],[a,a,b]]) :: UnionM [SymBool]-    -- :}-    -- {If x@2 [x@0] (If x@3 [x@0,x@1] [x@0,x@0,x@1])}--    -- ** Symbolic Generation Context-    FreshIndex (..),-    FreshIdent (..),-    name,-    nameWithInfo,-    FileLocation (..),-    nameWithLoc,--    -- ** Symbolic Generation Monad-    MonadFresh (..),-    nextFreshIndex,-    liftFresh,-    Fresh,-    FreshT (..),-    runFresh,-    runFreshT,-    mrgRunFreshT,--    -- ** Symbolic Generation Class-    GenSym (..),-    GenSymSimple (..),-    genSym,-    genSymSimple,--    -- ** Symbolic Generation Class Derivation-    derivedNoSpecFresh,-    derivedNoSpecSimpleFresh,-    derivedSameShapeSimpleFresh,--    -- ** Symbolic choice-    chooseFresh,-    chooseSimpleFresh,-    chooseUnionFresh,-    choose,-    chooseSimple,-    chooseUnion,--    -- ** Useful specifications-    EnumGenBound (..),-    EnumGenUpperBound (..),-    ListSpec (..),-    SimpleListSpec (..),--    -- * Error Handling--    -- |-    -- Grisette supports using 'Control.Monad.Except.ExceptT' to handle errors,-    -- and provides the @mrg*@ variants for the combinators in "Grisette.Lib.Mtl",-    -- for example, 'Grisette.Lib.Control.Monad.Except.mrgThrowError'.-    ---    -- >>> import Control.Monad.Except-    -- >>> import Grisette.Lib.Control.Monad.Except-    -- >>> mrgThrowError AssertionError :: ExceptT AssertionError UnionM ()-    -- ExceptT {Left AssertionError}-    ---    -- You can define your own error types, and reason about them with the-    -- solver APIs.-    ---    -- >>> :set -XDerivingVia -XDeriveGeneric -XDerivingStrategies -XLambdaCase-    -- >>> import GHC.Generics-    -- >>> import Grisette.Backend.SBV-    -- >>> :{-    --   data Error = Error1 | Error2 | Error3-    --     deriving (Show, Generic)-    --     deriving (Mergeable) via Default Error-    -- :}-    ---    -- >>> let [a,b,c] = ["a","b","c"] :: [SymBool]-    -- >>> res = mrgIf a (throwError Error1) (mrgIf b (return c) (throwError Error2)) :: ExceptT Error UnionM 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-    -- 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).-    ---    -- For those who prefer to encode errors as assertions and assumptions,-    -- we provide the 'symAssert' and 'symAssume' functions. These functions-    -- relies on the 'TransformError' type class to transform the assertions-    -- and assumptions to the user-defined error type.-    -- See their documentation for details.--    -- | #errors#--    -- ** Predefined errors-    AssertionError (..),-    VerificationConditions (..),--    -- ** Error transformation-    TransformError (..),-    symAssert,-    symAssume,-    symAssertWith,-    symAssertTransformableError,-    symThrowTransformableError,--    -- ** Simulate CBMC error handling-    CBMCEither (..),-    CBMCExceptT (..),-    cbmcExcept,-    mapCBMCExceptT,-    withCBMCExceptT,--    -- * Solver backend--    -- | #solver#--    -- | Grisette abstracts the solver backend with the 'Solver' type class,-    -- and the most basic solver call is the 'solve' function.-    ---    -- In the following code, we will search for the integer solutions to two-    -- equation systems.-    -- The first equation system, as shown below, has the solution @(x, y) = (13, -7)@.-    ---    -- \[-    --   \left\{-    --     \begin{aligned}-    --       x + y &= 6 \\-    --       x - y &= 20-    --     \end{aligned}-    --   \right.-    -- \]-    ---    -- The second equation system, as shown below, has no integer solutions.-    ---    -- \[-    --   \left\{-    --     \begin{aligned}-    --       x + y &= 6 \\-    --       x - y &= 19-    --     \end{aligned}-    --   \right.-    -- \]-    ---    -- >>> import Grisette.IR.SymPrim-    -- >>> import Grisette.Backend.SBV-    -- >>> let x = "x" :: SymInteger-    -- >>> let y = "y" :: SymInteger-    -- >>> solve (precise z3) (x + y .== 6 .&& x - y .== 20)-    -- Right (Model {x -> 13 :: Integer, y -> -7 :: Integer})-    -- >>> solve (precise 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 second parameter is the formula to be solved. It have 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,-    -- as shown in the following example.-    ---    -- > Right (Model {x -> 13 :: Integer, y -> -7 :: Integer})-    ---    -- This model maps x to 13, and y to -7. With this model, we can then-    -- 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)-    -- -91-    ---    -- You may notice that the first argument to the 'evaluateSym' 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-    -- preserve any symbolic constants that does not appear in the model, and-    -- partially evaluate the expression. When the argument is 'True', the-    -- evaluation would assign a default value to the symbolic constants that-    -- does not appear in the model, e.g., 0 for integers, and the evaluation-    -- result would become a concrete value -91.-    ---    -- >>> let z = "z" :: SymInteger-    -- >>> evaluateSym False m (x * y + z)-    -- (+ -91 z)-    -- >>> evaluateSym True m (x * y + z)-    -- -91-    ---    -- Grisette also provides convenient functions to solve problems with error-    -- handling. The lambda case function used in the following code means that-    -- we would like the solver to find path that would not lead to an error.-    -- This is done by mapping left values (failed paths) to false, and right-    -- values (successful paths) to true.-    ---    -- The following example finds bugs in a program in the hard way. It is an-    -- overkill for such a simple program, but it is a good example to show how-    -- to use Grisette to solve problems with error handling.-    ---    -- We can first define the error type used in the program.-    ---    -- >>> :set -XLambdaCase -XDeriveGeneric -XDerivingStrategies -XDerivingVia-    -- >>> import Control.Monad.Except-    -- >>> import Control.Exception-    -- >>> import GHC.Generics-    -- >>> :{-    -- data Error = Arith | Assert-    --   deriving (Show, Generic)-    --   deriving (Mergeable, SEq) via (Default Error)-    -- :}-    ---    -- Then we can perform the symbolic evaluation. The `divs` function throws-    -- 'ArithException' when the divisor is 0, which would be transformed to-    -- @Arith@, and the `symAssert` function would throw 'AssertionError' when-    -- the condition is false, which would be transformed to @Assert@.-    ---    -- >>> let x = "x" :: SymInteger-    -- >>> let y = "y" :: SymInteger-    -- >>> assert = symAssertWith Assert-    -- >>> sdiv = safeDiv' (const Arith)-    -- >>> :{-    --   -- equivalent concrete program:-    --   -- let x = x `div` y-    --   -- if z > 0 then assert (x >= y) else return ()-    --   res :: ExceptT Error UnionM ()-    --   res = do-    --     z <- x `sdiv` y-    --     mrgIf (z .> 0) (assert (x .>= y)) (return ())-    -- :}-    ---    -- Then we can ask the solver to find a counter-example that would lead to-    -- an assertion violation error, but do not trigger the division by zero-    -- error.-    -- This can be done by asking the solver to find a path that produce-    -- @Left Assert@.-    ---    -- >>> res-    -- ExceptT {If (|| (= y 0) (&& (< 0 (div x y)) (! (<= y x)))) (If (= y 0) (Left Arith) (Left Assert)) (Right ())}-    ---    -- > >>> solveExcept (UnboundedReasoning z3) (.== Left Assert) res-    -- > Right (Model {x -> -6 :: Integer, y -> -3 :: Integer}) -- possible output-    ---    -- Grisette also provide implementation for counter-example guided inductive-    -- synthesis (CEGIS) algorithm. See the documentation for 'CEGISSolver' for-    -- more details.--    -- ** Solver interfaces-    SolvingFailure (..),-    MonadicSolver (..),-    SolverCommand (..),-    ConfigurableSolver (..),-    Solver (..),-    withSolver,-    solve,-    solveMulti,--    -- ** Union with exceptions-    UnionWithExcept (..),-    solveExcept,-    solveMultiExcept,--    -- ** Generic Counter-example Guided Inductive Synthesis (CEGIS) interface-    SynthesisConstraintFun,-    VerifierResult (..),-    StatefulVerifierFun,-    CEGISResult (..),-    genericCEGIS,--    -- ** CEGIS interfaces with pre/post conditions-    CEGISCondition (..),-    cegisPostCond,-    cegisPrePost,-    cegisMultiInputs,-    cegis,-    cegisExcept,-    cegisExceptStdVC,-    cegisExceptVC,-    cegisExceptMultiInputs,-    cegisExceptStdVCMultiInputs,-    cegisExceptVCMultiInputs,-    cegisForAll,-    cegisForAllExcept,-    cegisForAllExceptStdVC,-    cegisForAllExceptVC,--    -- ** Symbolic constant extraction--    -- Grisette supports the extraction of the symbolic constant symbols from a-    -- symbolic value. This is useful for manipulating the models returned by-    -- the solver. The builtin CEGIS procedure relies on this.-    SymbolSetOps (..),-    SymbolSetRep (..),-    ExtractSymbolics (..),--    -- ** Evaluation with a model--    -- |-    -- When given a satisfiable formula, a solver can return a model that specifies-    -- the concrete assignments of the variables in the formula to make the formula-    -- true. We can use this model to evaluate some symbolic values by substituting-    -- the symbolic constants with the concrete assignments.-    ModelOps (..),-    ModelRep (..),-    EvaluateSym (..),-    evaluateSymToCon,--    -- ** Substitution of a symbol-    SubstituteSym (..),-    SubstituteSym' (..),--    -- * Type Class Derivation-    Default (..),-    Default1 (..),--    -- * Utilities--    -- ** Memoization-    htmemo,-    htmemo2,-    htmemo3,-    htmup,-    htmemoFix,--    -- ** Bundled Constructor Wrappers-    mrgTrue,-    mrgFalse,-    mrgUnit,-    mrgTuple2,-    mrgTuple3,-    mrgJust,-    mrgNothing,-    mrgLeft,-    mrgRight,-    mrgInL,-    mrgInR,-    mrgAssertionViolation,-    mrgAssumptionViolation,-  )-where--import Generics.Deriving (Default (..), Default1 (..))-import Grisette.Core.BuiltinUnionWrappers-  ( mrgAssertionViolation,-    mrgAssumptionViolation,-    mrgFalse,-    mrgInL,-    mrgInR,-    mrgJust,-    mrgLeft,-    mrgNothing,-    mrgRight,-    mrgTrue,-    mrgTuple2,-    mrgTuple3,-    mrgUnit,-  )-import Grisette.Core.Control.Exception-  ( AssertionError (..),-    VerificationConditions (..),-  )-import Grisette.Core.Control.Monad.CBMCExcept-  ( CBMCEither (..),-    CBMCExceptT (..),-    cbmcExcept,-    mapCBMCExceptT,-    withCBMCExceptT,-  )-import Grisette.Core.Control.Monad.Class.MonadParallelUnion-  ( MonadParallelUnion (..),-  )-import Grisette.Core.Control.Monad.Union (MonadUnion)-import Grisette.Core.Control.Monad.UnionM-  ( IsConcrete,-    UnionM,-    liftToMonadUnion,-    unionSize,-    (.#),-  )-import Grisette.Core.Data.Class.BitVector-  ( BV (..),-    SizedBV (..),-    bvExtract,-    sizedBVExtract,-  )-import Grisette.Core.Data.Class.CEGISSolver-  ( CEGISCondition (..),-    CEGISResult (..),-    StatefulVerifierFun,-    SynthesisConstraintFun,-    VerifierResult (..),-    cegis,-    cegisExcept,-    cegisExceptMultiInputs,-    cegisExceptStdVC,-    cegisExceptStdVCMultiInputs,-    cegisExceptVC,-    cegisExceptVCMultiInputs,-    cegisForAll,-    cegisForAllExcept,-    cegisForAllExceptStdVC,-    cegisForAllExceptVC,-    cegisMultiInputs,-    cegisPostCond,-    cegisPrePost,-    genericCEGIS,-  )-import Grisette.Core.Data.Class.Error-  ( TransformError (..),-    symAssert,-    symAssertTransformableError,-    symAssertWith,-    symAssume,-    symThrowTransformableError,-  )-import Grisette.Core.Data.Class.EvaluateSym-  ( EvaluateSym (..),-    evaluateSymToCon,-  )-import Grisette.Core.Data.Class.ExtractSymbolics-  ( ExtractSymbolics (..),-  )-import Grisette.Core.Data.Class.Function (Apply (..), Function (..))-import Grisette.Core.Data.Class.GPretty (GPretty (..))-import Grisette.Core.Data.Class.GenSym-  ( EnumGenBound (..),-    EnumGenUpperBound (..),-    Fresh,-    FreshIdent (..),-    FreshIndex (..),-    FreshT (..),-    GenSym (..),-    GenSymSimple (..),-    ListSpec (..),-    MonadFresh (..),-    SimpleListSpec (..),-    choose,-    chooseFresh,-    chooseSimple,-    chooseSimpleFresh,-    chooseUnion,-    chooseUnionFresh,-    derivedNoSpecFresh,-    derivedNoSpecSimpleFresh,-    derivedSameShapeSimpleFresh,-    genSym,-    genSymSimple,-    liftFresh,-    mrgRunFreshT,-    name,-    nameWithInfo,-    nextFreshIndex,-    runFresh,-    runFreshT,-  )-import Grisette.Core.Data.Class.ITEOp (ITEOp (..))-import Grisette.Core.Data.Class.LogicalOp (LogicalOp (..))-import Grisette.Core.Data.Class.Mergeable-  ( DynamicSortedIdx (..),-    Mergeable (..),-    Mergeable1 (..),-    Mergeable2 (..),-    Mergeable3 (..),-    MergingStrategy (..),-    StrategyList (..),-    buildStrategyList,-    derivedRootStrategy,-    product2Strategy,-    resolveStrategy,-    resolveStrategy',-    rootStrategy1,-    rootStrategy2,-    rootStrategy3,-    wrapStrategy,-  )-import Grisette.Core.Data.Class.ModelOps-  ( ModelOps (..),-    ModelRep (..),-    SymbolSetOps (..),-    SymbolSetRep (..),-  )-import Grisette.Core.Data.Class.SEq (SEq (..))-import Grisette.Core.Data.Class.SOrd (SOrd (..))-import Grisette.Core.Data.Class.SafeDivision (SafeDivision (..))-import Grisette.Core.Data.Class.SafeLinearArith (SafeLinearArith (..))-import Grisette.Core.Data.Class.SignConversion (SignConversion (..))-import Grisette.Core.Data.Class.SimpleMergeable-  ( SimpleMergeable (..),-    SimpleMergeable1 (..),-    SimpleMergeable2 (..),-    UnionLike (..),-    UnionPrjOp (..),-    merge,-    mrgIf,-    mrgIte1,-    mrgIte2,-    mrgSingle,-    onUnion,-    onUnion2,-    onUnion3,-    onUnion4,-    simpleMerge,-    pattern If,-    pattern Single,-  )-import Grisette.Core.Data.Class.Solvable (Solvable (..), pattern Con)-import Grisette.Core.Data.Class.Solver-  ( ConfigurableSolver (..),-    MonadicSolver (..),-    Solver (..),-    SolverCommand (..),-    SolvingFailure (..),-    UnionWithExcept (..),-    solve,-    solveExcept,-    solveMulti,-    solveMultiExcept,-    withSolver,-  )-import Grisette.Core.Data.Class.SubstituteSym-  ( SubstituteSym (..),-    SubstituteSym' (..),-  )-import Grisette.Core.Data.Class.ToCon (ToCon (..))-import Grisette.Core.Data.Class.ToSym (ToSym (..))-import Grisette.Core.Data.FileLocation-  ( FileLocation (..),-    ilocsym,-    nameWithLoc,-    slocsym,-  )-import Grisette.Core.Data.MemoUtils-  ( htmemo,-    htmemo2,-    htmemo3,-    htmemoFix,-    htmup,-  )-import Grisette.Core.TH (makeUnionWrapper, makeUnionWrapper')---- $setup--- >>> import Grisette.Core--- >>> import Grisette.Lib.Base--- >>> import Grisette.IR.SymPrim--- >>> :set -XDataKinds--- >>> :set -XBinaryLiterals--- >>> :set -XFlexibleContexts--- >>> :set -XFlexibleInstances--- >>> :set -XFunctionalDependencies+{-# LANGUAGE CPP #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE Trustworthy #-}+-- Disable this warning because we are re-exporting things.+{-# OPTIONS_GHC -Wno-missing-import-lists #-}++-- |+-- Module      :   Grisette.Core+-- 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+  ( -- * 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., 'PPrint')+    -- * 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.++    -- * Note for the examples in the documentation++    -- | The examples may assume a [z3](https://github.com/Z3Prover/z3) solver+    -- available in @PATH@.++    -- * 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+    -- symbolic constraints over these values.+    -- These constraints can then be used to find concrete assignments to the+    -- symbolic values that meet certain criteria, such as triggering a bug in+    -- a verification task or satisfying a specification in a synthesis task.+    --+    -- 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. 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 (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+    -- can significantly reduce the number of paths that need to be explored.+    --+    -- For example, there are three symbolic Booleans @a@, @b@ and @c@, in the+    -- following code, and a symbolic Boolean @x@ is defined to be the result of+    -- a conditional expression:+    --+    -- > x = if a then b else c -- pseudo code, not real Grisette code+    --+    -- The result would be a single symbolic integer formula:+    --+    -- >>> 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 value:+    --+    -- >>> 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 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.+    --+    -- For example, assume that the lists have the type+    -- @['Grisette.SymPrim.SymBool']@.+    -- In the following example, the result shows that @[b]@ and @[c]@ can be+    -- merged together in the same symbolic union because they have the same+    -- length:+    --+    -- > x = if a then [b] else [c] -- pseudo code, not real Grisette code+    --+    -- 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+    --+    -- 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.+    --+    -- > 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, and we will distribute 'head' among the+    -- branches:+    --+    -- > 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)+    --+    -- 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:+    --+    -- >>> 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+    -- conditions larger and harder to solve. To have a good balance between+    -- 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 (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++    -- |+    -- Grisette currently provides an implementation for the following solvable+    -- types:+    --+    -- * '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.SymAlgReal' ('Grisette.SymPrim.AlgReal'), symbolic+    --   algebraic real numbers.+    -- * @'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 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+    -- constants (placeholders for concrete values that can be assigned by a+    -- solver to satisfy a formula), and complex symbolic formulas with+    -- symbolic operations. The `Solvable` type class provides a way to+    -- construct concrete values and symbolic constants.+    --+    -- __Examples:__+    --+    -- >>> 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+    --+    -- With the @OverloadedStrings@ GHC extension enabled, symbolic constants+    -- can also be constructed from strings.+    --+    -- >>> "a" :: SymBool+    -- a+    --+    -- Symbolic operations are provided through a set of type classes,+    -- such as 'SymEq', 'SymOrd', and 'Num'. Please check out the documentation for+    -- more details.+    --+    -- __Examples:__+    --+    -- >>> let a = "a" :: SymInteger+    -- >>> let b = "b" :: SymInteger+    -- >>> a .== b+    -- (= a b)++    -- ** 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+    SExpr (..),+    showsSExprWithParens,+    fileLocation,+    Identifier (..),+    Symbol (..),+    identifier,+    AsMetadata (..),+    pattern Metadata,+    withMetadata,+    mapMetadata,+    withLocation,+    uniqueIdentifier,+    simple,+    indexed,+    symbolIdentifier,+    mapIdentifier,++    -- ** Creation and extraction of solvable values+    Solvable (..),+    pattern Con,+    slocsym,+    ilocsym,++    -- * Basic symbolic operations #symops#++    -- ** Basic logical operators+    LogicalOp (..),+    ITEOp (..),++    -- ** Symbolic equality+    SymEq (..),+    SymEq1 (..),+    symEq1,+    SymEq2 (..),+    symEq2,++    -- ** Supplemental operation for 'Eq'+    distinct,++    -- ** Symbolic comparison+    SymOrd (..),+    SymOrd1 (..),+    symCompare1,+    SymOrd2 (..),+    symCompare2,+    symMax,+    symMin,+    mrgMax,+    mrgMin,++    -- ** Bit-vectors+    BV (..),+    bvExtract,+    SizedBV (..),+    sizedBVExtract,+    SymShift (..),+    SafeSymShift (..),+    SymRotate (..),+    SafeSymRotate (..),+    SignConversion (..),+    lsb,+    msb,+    setBitTo,+    bitBlast,+    FromBits (..),+    SymFiniteBits (..),+    symBitBlast,+    symLsb,+    symMsb,+    symPopCount,+    symCountLeadingZeros,+    symCountTrailingZeros,++    -- ** Safe operation for Numbers+    DivOr (..),+    divOrZero,+    modOrDividend,+    quotOrZero,+    remOrDividend,+    divModOrZeroDividend,+    quotRemOrZeroDividend,+    SafeDiv (..),+    SafeLinearArith (..),+    FdivOr (..),+    fdivOrZero,+    recipOrZero,+    SafeFdiv (..),+    LogBaseOr (..),+    logBaseOrZero,+    SafeLogBase (..),++    -- ** Functions+    Function (..),+    Apply (..),++    -- ** IEEE Floating points+    fpIsNaN,+    fpIsPositiveZero,+    fpIsNegativeZero,+    fpIsPositiveInfinite,+    fpIsNegativeInfinite,+    fpIsPositive,+    fpIsNegative,+    fpIsInfinite,+    fpIsZero,+    fpIsNormal,+    fpIsSubnormal,+    fpIsPoint,+    SymIEEEFPTraits (..),+    IEEEFPConstants (..),+    IEEEFPRoundingMode (..),+    IEEEFPOp (..),+    IEEEFPRoundingOp (..),+    IEEEFPConvertible (..),+    IEEEFPToAlgReal (..),++    -- ** Conversion between Concrete and Symbolic values+    ToCon (..),+    ToCon1 (..),+    toCon1,+    ToCon2 (..),+    toCon2,+    ToSym (..),+    ToSym1 (..),+    toSym1,+    ToSym2 (..),+    toSym2,++    -- ** Conversion between different symbolic types+    BitCast (..),+    BitCastCanonical (..),+    BitCastOr (..),+    BitCastOrCanonical,+    bitCastOrCanonical,+    SafeBitCast (..),+    SymFromIntegral (..),++    -- * 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.++    -- ** '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,+    -- while 'mrgIf' models branching control flow semantics with symbolic+    -- conditions.+    -- Here are some examples of using 'mrgSingle' and 'mrgIf':+    --+    -- >>> mrgSingle ["a"] :: Union [SymInteger]+    -- {[a]}+    -- >>> mrgIf "a" (mrgSingle ["b"]) (mrgSingle ["c", "d"]) :: Union [SymInteger]+    -- {If a [b] [c,d]}+    --+    -- '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+    -- modeled in Grisette with the combinators provided by Grisette, and the do-notation:+    --+    -- > x = if a then [b] else [b,c] -- pseudo code, not Grisette code+    -- > y = if d then [e] else [e,f]+    -- > return (x ++ y :: [SymInteger])+    --+    -- >>> :{+    --   ret :: Union [SymInteger]+    --   ret = do x <- mrgIf "a" (return ["b"]) (return ["b","c"])+    --            y <- mrgIf "d" (return ["e"]) (return ["e","f"])+    --            -- 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:+    --+    -- >>> ret+    -- {If (&& a d) [b,e] (If (|| a d) [b,(ite a e c),(ite a f e)] [b,c,e,f])}+    --+    -- In the result, we can see that the results are reorganized and the two+    -- lists with the same length are merged together.+    -- This is important for scaling symbolic evaluation to real-world+    -- problems.+    --+    -- 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),+    -- as the 'return' function from the 'Monad' type class cannot resolve+    -- extra constraints.+    -- Our solution to this problem with merging strategy caching is inspired+    -- 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 '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 :: Union Integer+    -- <1>+    -- >>> mrgReturn 1 :: Union Integer+    -- {1}+    -- >>> mrgIf "a" (return 1) (return 2) :: Union Integer+    -- {If a 1 2}+    --+    -- 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 '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, see how the result is merged:+    --+    -- >>> 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 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:+    --+    -- >>> import GHC.Generics+    -- >>> :{+    --   data X = X SymInteger Integer+    --     deriving (Generic, Show)+    --     deriving (Mergeable) via (Default X)+    -- :}+    --+    -- Grisette also provide 'Grisette.derive' template haskell procedure to+    -- derive all the instances for the classes that are relevant. This include+    -- 'Show', 'Mergeable', 'Mergeable1', etc.+    --+    -- >>> :{+    -- data X = X SymInteger Integer+    -- derive [''X] [''Show, ''Mergeable]+    -- :}+    --+    -- 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)}+    --+    -- __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+    -- '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:+    --+    -- >>> import Control.Monad.Except+    -- >>> :{+    --   data Error = Fail+    --   derive [''Error] allClasses0+    -- :}+    --+    -- >>> 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.++    -- ** 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.__+    --+    -- In Grisette, the symbolic union has the Ordered Guards (ORG)+    -- representation, which can be viewed as a nested if-then-else with some+    -- representation invariant.+    --+    -- For example, the following symbolic union represents a symbolic list of+    -- 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.+    -- \]+    --+    -- In Haskell syntax, the container is represented as the following nested+    -- if-then-else tree+    --+    -- > If c1 [a] (If c2 [b,b] [a,b,c])+    --+    -- The representations means that when @c1@ is true, then the value is a+    -- list @[a]@, or when @c1@ is false and @c2@ is true, the value is a list+    -- @[b,b]@, or otherwise the value is @[a,b,c]@.+    --+    -- This representation allows you to use+    -- the constructs that are not supported by the underlying solvers freely.+    -- For example, when applying 'head' on this structure, we can just+    -- 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}\\%+    --     &\texttt{head [a,b,c]}&&\mathrm{otherwise}+    --   \end{aligned}\right.+    -- \]+    --+    -- or, equivalently+    --+    -- \[+    --   \left\{\begin{aligned}%+    --     &\texttt{a}&&\mathrm{if}&&\texttt{c1}\\%+    --     &\texttt{b}&&\mathrm{else~if}&&\texttt{c2}\\%+    --     &\texttt{a}&&\mathrm{otherwise}%+    --   \end{aligned}\right.+    -- \]+    --+    -- Further symbolic evaluation will also distribute computations+    -- over the branches in this result, and the identical branches will cause+    -- redundant computation. To mitigate this, Grisette would try to merge+    -- 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}\\%+    --   \end{aligned}\right.+    -- \]+    --+    -- Note that if the contained type is symbolic Boolean, we may further merge+    -- the values into a single formula.+    --+    -- \[+    --   \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+    -- `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+    -- example, the two ORG containers passed to the 'mrgIf' are sorted+    -- with the natural ordering on the integers. In the result, the values are+    -- also organized in a sorted way, and the path conditions are correctly+    -- 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}%+    --   \end{aligned}\right.+    -- \]+    --+    -- So far, we have described ORG as a flat list of values.+    -- When the list is long, it is beneficial to partition the values and merge+    -- (some or all) partitions into nested ORG values.+    -- This hierarchical ORG representation is particularly useful for complex+    -- data types, such as tuples, which tend to yield long lists.+    --+    -- In the following example, @v*@ are values, while @t*@ are ORG containers.+    -- The values in the containers are first partitioned into three groups:+    -- @{v11, v12, v13}@, @{v2}@, and @{v13}@.+    -- In each group, the values share some common features, (e.g., they are+    -- constructed with the same data constructor).+    -- The values in each group are organized in a subtree, e.g., the first group+    -- is organized in the subtree @t1@.+    -- The hierarchical representation also keeps a representation invariant:+    -- at each level in the hierarchy, the values (or the subtrees) are also sorted+    -- by some criteria. Here, in the first level, the values are sorted by the+    -- constructor declaration order, and in the second level, the values are sorted+    -- by the concrete field in the constructor @A@.+    -- This criteria is given by the 'MergingStrategy' in the 'Mergeable' class,+    -- called the root merging strategy of the type.+    --+    -- > 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}&&%+    --   \end{aligned}\right.+    -- \]+    --+    -- In Haskell syntax, it can be represented as follows:+    --+    -- > If      c1    (If c11 (A 1 a) (If c12 (A 3 b) (A 4 (&& x y))))+    -- >   (If   c2    B+    -- >               C)+    --+    -- All the symbolic unions in Grisette should maintain the hierarchical+    -- sorted invariant, and are sorted in the same way, with respect to the same+    -- merging strategy (the root merging strategy for the type).+    -- We can then merge the containers with a hierarchical+    -- merging algorithm: at each level, we align the values and subtrees, and merge+    -- the aligned ones. In the following example, 'mrgIf' resolves the root merging+    -- strategy @s@, and calls the function @mrgIf'@, which accepts the merging strategy+    -- as an argument. The symbolic union operands to the @mrgIf'@ function must be+    -- sorted with the merging strategy passed to the function.+    --+    -- Here we use the name of the subtrees and values to indicate the order of them:+    --+    -- * @t1@ should be placed before @v3@ in the @then@ branch,+    -- * @t1@ and @v4@ can be aligned with @t1'@ and @v4'@, respectively.+    --+    -- The aligned subtrees will be merged recursively with @mrgIf'@, with a+    -- __/sub-strategy/__ given by the merging strategy @s@ for the subtrees.+    -- For example, @t1@ and @t1'@ will be merged with the sub-strategy @s'@.+    -- The aligned values will be merged with a merging function, also given by+    -- the merging strategy @s@. For example, @v4@ and @v4'@ will be merged with+    -- the merging function @f'@.+    --+    -- The ordering and the sub-strategies are abstracted with 'SortedStrategy',+    -- and the merging functions will be wrapped in 'SimpleStrategy'.+    -- The merging algorithm can then be configured by implementing the merging+    -- strategies for the types contained in a symbolic union. See the documentation+    -- 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}%+    --       \end{aligned}\right.+    --   \end{aligned}+    -- \]+    --+    -- For more details of the algorithm, please refer to+    -- [Grisette's paper](https://lsrcz.github.io/files/POPL23.pdf).++    -- ** Use symbolic types as concrete key based on structural term equality+    AsKey (..),+    AsKey1 (..),+    KeyEq (..),+    KeyEq1 (..),+    KeyHashable (..),+    KeyHashable1 (..),+    KeyOrd (..),+    KeyOrd1 (..),++    -- ** Union Monad+    Union (unionMergingStrategy),+    UnionKey,+    unionUnaryOp,+    unionBinOp,+    unionSize,++    -- ** Tag for concrete types+    Concrete,++    -- ** Mergeable+    Mergeable (..),+    Mergeable1 (..),+    rootStrategy1,+    Mergeable2 (..),+    rootStrategy2,+    Mergeable3 (..),+    rootStrategy3,++    -- ** Merging strategy+    MergingStrategy (..),+    MergingIndex,++    -- ** Manual merging strategy construction+    wrapStrategy,+    product2Strategy,+    DynamicSortedIdx (..),+    StrategyList (..),+    buildStrategyList,+    resolveStrategy,+    resolveStrategy',++    -- ** Simple mergeable types+    SimpleMergeable (..),+    SimpleMergeable1 (..),+    mrgIte1,+    SimpleMergeable2 (..),+    mrgIte2,++    -- ** Symbolic branching+    SymBranching (..),+    mrgIf,+    mergeWithStrategy,+    merge,+    MonadUnion,++    -- ** TryMerge operations+    MonadTryMerge,+    TryMerge (..),+    mrgSingle,+    mrgSingleWithStrategy,+    tryMerge,++    -- ** UnionView operations+    UnionView (..),+    IfViewResult (..),+    pattern Single,+    pattern If,+    simpleMerge,+    (.#),+    onUnion,+    onUnion2,+    onUnion3,+    onUnion4,+    liftUnion,+    liftToMonadUnion,++    -- * Pretty printing+    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,+    -- in program synthesis task, we may want to generate symbolic programs+    -- to represent the search space given some specification.+    --+    -- To help with this, we provide a set of classes and functions. The core+    -- of the symbolic generation is the 'Fresh' monad, the 'GenSymSimple' class,+    -- and the 'GenSym' class.+    --+    -- The 'Fresh' monad is a combination of specialized state and reader+    -- monads. It keeps an identifier, and an index. The generated symbolic+    -- constants would be constructed with both the identifier and the index.+    -- Each time a new symbolic constant is generated, the index would be+    -- incremented. This keeps that the generated symbolic constants are unique.+    --+    -- The 'GenSymSimple' class helps generate symbolic values that do not require+    -- a symbolic union, for example, symbolic Booleans.+    -- It provides the 'simpleFresh' function, which accepts a specification+    -- for the symbolic values to generate.+    --+    -- We do not need any specification to generate a symbolic Boolean, so+    -- we provide a unit value as the specification:+    --+    -- >>> runFresh (simpleFresh ()) "x" :: SymBool+    -- x@0+    --+    -- We can generate a list of symbolic Booleans by specifying the length+    -- of the list, and the specification for the elements. The two elements+    -- in the generated list are unique as they have different indices.+    --+    -- >>> runFresh (simpleFresh (SimpleListSpec 2 ())) "x" :: [SymBool]+    -- [x@0,x@1]+    -- >>> runFresh (simpleFresh (SimpleListSpec 2 (SimpleListSpec 1 ()))) "x" :: [[SymBool]]+    -- [[x@0],[x@1]]+    --+    -- The 'GenSym' class helps generate symbolic values that require a symbolic+    -- union, for example, lists with different lengths.+    -- It provides the 'fresh' function, which accepts a specification+    -- for the symbolic values to generate.+    --+    -- 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" :: 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.+    -- The symbolic constants are ensured to be unique:+    --+    -- >>> :{+    --   flip runFresh "x" $ do+    --     a :: SymBool <- simpleFresh ()+    --     b :: Union [SymBool] <- fresh (ListSpec 0 2 ())+    --     return (a, b)+    -- :}+    -- (x@0,{If x@3 [] (If x@4 [x@2] [x@1,x@2])})+    --+    -- When you are just generating a symbolic value, and do not need to compose+    -- multiple 'simpleFresh' or 'fresh' calls, you can use the 'genSym' and+    -- 'genSymSimple' functions instead.+    --+    -- >>> genSymSimple (SimpleListSpec 2 ()) "x" :: [SymBool]+    -- [x@0,x@1]+    -- >>> 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.+    -- With the 'chooseFresh' function,+    -- we can generate a symbolic value by choosing from a list of+    -- alternative values.+    -- Grisette would generate symbolic Boolean guards to perform the symbolic+    -- choice.+    --+    -- >>> :{+    --   (flip runFresh "x" $ do+    --     a <- simpleFresh ()+    --     b <- simpleFresh ()+    --     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])}++    -- ** Symbolic Generation Context+    FreshIndex (..),++    -- ** Symbolic Generation Monad+    MonadFresh (..),+    nextFreshIndex,+    liftFresh,+    Fresh,+    FreshT (..),+    runFresh,+    runFreshT,+    mrgRunFreshT,+    freshString,++    -- ** Symbolic Generation Class+    GenSym (..),+    GenSymSimple (..),+    genSym,+    genSymSimple,++    -- ** Symbolic Generation Class Derivation+    derivedNoSpecFresh,+    derivedNoSpecSimpleFresh,+    derivedSameShapeSimpleFresh,++    -- ** Symbolic choice+    chooseFresh,+    chooseSimpleFresh,+    chooseUnionFresh,+    choose,+    chooseSimple,+    chooseUnion,++    -- ** Useful specifications+    EnumGenBound (..),+    EnumGenUpperBound (..),+    ListSpec (..),+    SimpleListSpec (..),++    -- * Error Handling #errors#++    -- |+    -- Grisette supports using 'Control.Monad.Except.ExceptT' to handle errors,+    -- and provides the @mrg*@ variants for the combinators in "Grisette.Lib.Mtl",+    -- for example, 'Grisette.Lib.Control.Monad.Except.mrgThrowError'.+    --+    -- >>> import Control.Monad.Except+    -- >>> import Grisette.Lib.Control.Monad.Except+    -- >>> mrgThrowError AssertionError :: ExceptT AssertionError Union ()+    -- ExceptT {Left AssertionError}+    --+    -- You can define your own error types, and reason about them with the+    -- solver APIs.+    --+    -- >>> import GHC.Generics+    -- >>> :{+    --   data Error = Error1 | Error2 | Error3+    --     deriving (Show, Generic)+    --     deriving (Mergeable) via Default Error+    -- :}+    --+    -- >>> let [a,b,c] = ["a","b","c"] :: [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 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](#g:solver).+    --+    -- For those who prefer to encode errors as assertions and assumptions,+    -- we provide the 'symAssert' and 'symAssume' functions. These functions+    -- relies on the 'TransformError' type class to transform the assertions+    -- and assumptions to the user-defined error type.+    -- See their documentation for details.++    -- ** Predefined errors+    AssertionError (..),+    VerificationConditions (..),++    -- ** Error transformation+    TransformError (..),+    symAssert,+    symAssume,+    symAssertWith,+    symAssertTransformableError,+    symThrowTransformableError,++    -- ** Simulate CBMC error handling+    CBMCEither (..),+    CBMCExceptT (..),+    cbmcExcept,+    mapCBMCExceptT,+    withCBMCExceptT,++    -- * Solver backend #solver#++    -- | Grisette abstracts the solver backend with the 'Solver' type class,+    -- and the most basic solver call is the 'solve' function.+    --+    -- In the following code, we will search for the integer solutions to two+    -- equation systems.+    -- The first equation system, as shown below, has the solution @(x, y) = (13, -7)@.+    --+    -- \[+    --   \left\{+    --     \begin{aligned}+    --       x + y &= 6 \\+    --       x - y &= 20+    --     \end{aligned}+    --   \right.+    -- \]+    --+    -- The second equation system, as shown below, has no integer solutions.+    --+    -- \[+    --   \left\{+    --     \begin{aligned}+    --       x + y &= 6 \\+    --       x - y &= 19+    --     \end{aligned}+    --   \right.+    -- \]+    --+    -- >>> import Grisette.SymPrim+    -- >>> import Grisette.Backend+    -- >>> let x = "x" :: SymInteger+    -- >>> let y = "y" :: SymInteger+    -- >>> solve z3 (x + y .== 6 .&& x - y .== 20)+    -- Right (Model {x -> 13 :: Integer, y -> -7 :: Integer})+    -- >>> solve z3 (x + y .== 6 .&& x - y .== 19)+    -- Left Unsat+    --+    -- 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 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,+    -- as shown in the following example.+    --+    -- > Right (Model {x -> 13 :: Integer, y -> -7 :: Integer})+    --+    -- This model maps x to 13, and y to -7. With this model, we can then+    -- evaluate symbolic values. The following code evaluates the product of+    -- x and y under the solution of the equation system.+    --+    -- >>> 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 '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+    -- preserve any symbolic constants that does not appear in the model, and+    -- partially evaluate the expression. When the argument is 'True', the+    -- evaluation would assign a default value to the symbolic constants that+    -- does not appear in the model, e.g., 0 for integers, and the evaluation+    -- result would become a concrete value -91.+    --+    -- >>> let z = "z" :: SymInteger+    -- >>> evalSym False m (x * y + z)+    -- (+ -91 z)+    -- >>> evalSym True m (x * y + z)+    -- -91+    --+    -- Grisette also provides convenient functions to solve problems with error+    -- handling. The lambda case function used in the following code means that+    -- we would like the solver to find path that would not lead to an error.+    -- This is done by mapping left values (failed paths) to false, and right+    -- values (successful paths) to true.+    --+    -- The following example finds bugs in a program in the hard way. It is an+    -- overkill for such a simple program, but it is a good example to show how+    -- to use Grisette to solve problems with error handling.+    --+    -- We can first define the error type used in the program.+    --+    -- >>> import Control.Monad.Except+    -- >>> import Grisette.Lib.Control.Monad.Trans.Except+    -- >>> import Control.Exception+    -- >>> import GHC.Generics+    -- >>> :{+    -- data Error = Arith | Assert+    --   deriving (Show, Generic)+    --   deriving (Mergeable, SymEq) via (Default Error)+    -- :}+    --+    -- Then we can perform the symbolic evaluation. The `divs` function throws+    -- 'ArithException' when the divisor is 0, which would be transformed to+    -- @Arith@, and the `symAssert` function would throw 'AssertionError' when+    -- the condition is false, which would be transformed to @Assert@.+    --+    -- >>> let x = "x" :: SymInteger+    -- >>> let y = "y" :: SymInteger+    -- >>> 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 Union ()+    --   res = do+    --     z <- x `sdiv` y+    --     mrgIf (z .> 0) (assert (x .>= y)) (return ())+    -- :}+    --+    -- Then we can ask the solver to find a counter-example that would lead to+    -- an assertion violation error, but do not trigger the division by zero+    -- error.+    -- This can be done by asking the solver to find a path that produce+    -- @Left Assert@.+    --+    -- >>> res+    -- ExceptT {If (|| (= y 0) (&& (< 0 (div x y)) (! (<= y x)))) (If (= y 0) (Left Arith) (Left Assert)) (Right ())}+    --+    -- > >>> solveExcept (UnboundedReasoning z3) (.== Left Assert) res+    -- > Right (Model {x -> -6 :: Integer, y -> -3 :: Integer}) -- possible output+    --+    -- Grisette also provide implementation for counter-example guided inductive+    -- synthesis (CEGIS) algorithm. See the documentation for 'CEGISSolver' for+    -- more details.++    -- ** Solver interfaces+    SolvingFailure (..),+    MonadicSolver (..),+    monadicSolverSolve,+    SolverCommand (..),+    ConfigurableSolver (..),+    Solver (..),+    solverSolve,+    withSolver,+    solve,+    solverSolveMulti,+    solveMulti,++    -- ** Union with exceptions+    UnionWithExcept (..),+    solverSolveExcept,+    solveExcept,+    solverSolveMultiExcept,+    solveMultiExcept,++    -- ** Generic Counter-example Guided Inductive Synthesis (CEGIS) interface+    VerifierResult (..),+    SynthesisConstraintFun,+    VerifierFun,+    CEGISResult (..),+    solverGenericCEGIS,+    solverGenericCEGISWithRefinement,+    genericCEGIS,+    genericCEGISWithRefinement,++    -- ** CEGIS interfaces with pre/post conditions+    CEGISCondition (..),+    solverCegisMultiInputs,+    solverCegis,+    solverCegisExcept,+    solverCegisExceptStdVC,+    solverCegisExceptVC,+    solverCegisExceptMultiInputs,+    solverCegisExceptStdVCMultiInputs,+    solverCegisExceptVCMultiInputs,+    solverCegisForAll,+    solverCegisForAllExcept,+    solverCegisForAllExceptStdVC,+    solverCegisForAllExceptVC,+    cegisPostCond,+    cegisPrePost,+    cegisMultiInputs,+    cegis,+    cegisExcept,+    cegisExceptStdVC,+    cegisExceptVC,+    cegisExceptMultiInputs,+    cegisExceptStdVCMultiInputs,+    cegisExceptVCMultiInputs,+    cegisForAll,+    cegisForAllExcept,+    cegisForAllExceptStdVC,+    cegisForAllExceptVC,++    -- * Substitutions for symbolic values given solver models++    -- ** Symbolic constant extraction++    -- Grisette supports the extraction of the symbolic constant symbols from a+    -- symbolic value. This is useful for manipulating the models returned by+    -- the solver. The builtin CEGIS procedure relies on this.+    SymbolSetOps (..),+    SymbolSetRep (..),+    ExtractSym (..),+    ExtractSym1 (..),+    extractSym1,+    extractSymMaybe1,+    ExtractSym2 (..),+    extractSym2,+    extractSymMaybe2,++    -- ** Evaluation with a model++    -- |+    -- When given a satisfiable formula, a solver can return a model that specifies+    -- the concrete assignments of the variables in the formula to make the formula+    -- true. We can use this model to evaluate some symbolic values by substituting+    -- the symbolic constants with the concrete assignments.+    ModelOps (..),+    ModelRep (..),+    EvalSym (..),+    evalSymToCon,+    EvalSym1 (..),+    evalSym1,+    evalSymToCon1,+    EvalSym2 (..),+    evalSym2,+    evalSymToCon2,++    -- ** Substitution of a symbol+    SubstSym (..),+    SubstSym1 (..),+    substSym1,+    SubstSym2 (..),+    substSym2,++    -- * Utilities #utils#++    -- ** Memoization+    stableMemo,+    stableMemo2,+    stableMemo3,+    stableMup,+    stableMemoFix,+    weakStableMemo,+    weakStableMemo2,+    weakStableMemo3,+    weakStableMup,+    weakStableMemoFix,+    htmemo,+    htmemo2,+    htmemo3,+    htmemoFix,+    htmup,++    -- ** 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,+    unionToCon,++    -- *** 'ToSym'+    ToSymArgs (..),+    GToSym (..),+    genericToSym,+    genericLiftToSym,+    mrgToSym,+    toUnionSym,++    -- *** 'EvalSym'+    EvalSymArgs (..),+    GEvalSym (..),+    genericEvalSym,+    genericLiftEvalSym,++    -- *** 'ExtractSym'+    ExtractSymArgs (..),+    GExtractSym (..),+    genericExtractSymMaybe,+    genericLiftExtractSymMaybe,++    -- *** 'SubstSym'+    SubstSymArgs (..),+    GSubstSym (..),+    genericSubstSym,+    genericLiftSubstSym,++    -- *** 'PPrint'+    genericPFormatPrec,+    genericLiftPFormatPrec,+    genericPFormatList,+    genericLiftPFormatList,+    PPrintArgs (..),+    GPPrint (..),+    PPrintType (..),+  )+where++#if MIN_VERSION_prettyprinter(1,7,0)+import Prettyprinter+#else+import Data.Text.Prettyprint.Doc as Prettyprinter+#endif++import Generics.Deriving (Default (..), Default1 (..))+import Grisette.Internal.Core.Control.Exception+  ( AssertionError (..),+    VerificationConditions (..),+  )+import Grisette.Internal.Core.Control.Monad.CBMCExcept+  ( CBMCEither (..),+    CBMCExceptT (..),+    cbmcExcept,+    mapCBMCExceptT,+    withCBMCExceptT,+  )+import Grisette.Internal.Core.Control.Monad.Class.Union (MonadUnion)+import Grisette.Internal.Core.Control.Monad.Union+  ( Union (unionMergingStrategy),+    UnionKey,+    unionBinOp,+    unionSize,+    unionUnaryOp,+  )+import Grisette.Internal.Core.Data.Class.AsKey+  ( AsKey (..),+    AsKey1 (..),+    KeyEq (..),+    KeyEq1 (..),+    KeyHashable (..),+    KeyHashable1 (..),+    KeyOrd (..),+    KeyOrd1 (..),+  )+import Grisette.Internal.Core.Data.Class.BitCast+  ( BitCast (..),+    BitCastCanonical (..),+    BitCastOr (..),+    BitCastOrCanonical,+    bitCastOrCanonical,+  )+import Grisette.Internal.Core.Data.Class.BitVector+  ( BV (..),+    SizedBV (..),+    bvExtract,+    sizedBVExtract,+  )+import Grisette.Internal.Core.Data.Class.CEGISSolver+  ( CEGISCondition (..),+    CEGISResult (..),+    SynthesisConstraintFun,+    VerifierFun,+    VerifierResult (..),+    cegis,+    cegisExcept,+    cegisExceptMultiInputs,+    cegisExceptStdVC,+    cegisExceptStdVCMultiInputs,+    cegisExceptVC,+    cegisExceptVCMultiInputs,+    cegisForAll,+    cegisForAllExcept,+    cegisForAllExceptStdVC,+    cegisForAllExceptVC,+    cegisMultiInputs,+    cegisPostCond,+    cegisPrePost,+    genericCEGIS,+    genericCEGISWithRefinement,+    solverCegis,+    solverCegisExcept,+    solverCegisExceptMultiInputs,+    solverCegisExceptStdVC,+    solverCegisExceptStdVCMultiInputs,+    solverCegisExceptVC,+    solverCegisExceptVCMultiInputs,+    solverCegisForAll,+    solverCegisForAllExcept,+    solverCegisForAllExceptStdVC,+    solverCegisForAllExceptVC,+    solverCegisMultiInputs,+    solverGenericCEGIS,+    solverGenericCEGISWithRefinement,+  )+import Grisette.Internal.Core.Data.Class.Concrete (Concrete)+import Grisette.Internal.Core.Data.Class.Error+  ( TransformError (..),+    symAssert,+    symAssertTransformableError,+    symAssertWith,+    symAssume,+    symThrowTransformableError,+  )+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.ExtractSym+  ( ExtractSym (..),+    ExtractSym1 (..),+    ExtractSym2 (..),+    ExtractSymArgs (..),+    GExtractSym (..),+    extractSym1,+    extractSym2,+    extractSymMaybe1,+    extractSymMaybe2,+    genericExtractSymMaybe,+    genericLiftExtractSymMaybe,+  )+import Grisette.Internal.Core.Data.Class.Function (Apply (..), Function (..))+import Grisette.Internal.Core.Data.Class.GenSym+  ( EnumGenBound (..),+    EnumGenUpperBound (..),+    Fresh,+    FreshIndex (..),+    FreshT (..),+    GenSym (..),+    GenSymSimple (..),+    ListSpec (..),+    MonadFresh (..),+    SimpleListSpec (..),+    choose,+    chooseFresh,+    chooseSimple,+    chooseSimpleFresh,+    chooseUnion,+    chooseUnionFresh,+    derivedNoSpecFresh,+    derivedNoSpecSimpleFresh,+    derivedSameShapeSimpleFresh,+    freshString,+    genSym,+    genSymSimple,+    liftFresh,+    mrgRunFreshT,+    nextFreshIndex,+    runFresh,+    runFreshT,+  )+import Grisette.Internal.Core.Data.Class.IEEEFP+  ( IEEEFPConstants (..),+    IEEEFPConvertible (..),+    IEEEFPOp (..),+    IEEEFPRoundingMode (..),+    IEEEFPRoundingOp (..),+    IEEEFPToAlgReal (..),+    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,+    genericLiftRootStrategy,+    genericRootStrategy,+    product2Strategy,+    resolveStrategy,+    resolveStrategy',+    rootStrategy1,+    rootStrategy2,+    rootStrategy3,+    wrapStrategy,+  )+import Grisette.Internal.Core.Data.Class.ModelOps+  ( ModelOps (..),+    ModelRep (..),+    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.SafeBitCast (SafeBitCast (..))+import Grisette.Internal.Core.Data.Class.SafeDiv+  ( DivOr (..),+    SafeDiv (..),+    divModOrZeroDividend,+    divOrZero,+    modOrDividend,+    quotOrZero,+    quotRemOrZeroDividend,+    remOrDividend,+  )+import Grisette.Internal.Core.Data.Class.SafeFdiv+  ( FdivOr (..),+    SafeFdiv (..),+    fdivOrZero,+    recipOrZero,+  )+import Grisette.Internal.Core.Data.Class.SafeLinearArith (SafeLinearArith (..))+import Grisette.Internal.Core.Data.Class.SafeLogBase+  ( LogBaseOr (..),+    SafeLogBase (..),+    logBaseOrZero,+  )+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+  ( GSimpleMergeable (..),+    SimpleMergeable (..),+    SimpleMergeable1 (..),+    SimpleMergeable2 (..),+    SimpleMergeableArgs (..),+    SymBranching (..),+    genericLiftMrgIte,+    genericMrgIte,+    merge,+    mergeWithStrategy,+    mrgIf,+    mrgIte1,+    mrgIte2,+  )+import Grisette.Internal.Core.Data.Class.Solvable+  ( Solvable (..),+    ilocsym,+    slocsym,+    pattern Con,+  )+import Grisette.Internal.Core.Data.Class.Solver+  ( ConfigurableSolver (..),+    MonadicSolver (..),+    Solver (..),+    SolverCommand (..),+    SolvingFailure (..),+    UnionWithExcept (..),+    monadicSolverSolve,+    solve,+    solveExcept,+    solveMulti,+    solveMultiExcept,+    solverSolve,+    solverSolveExcept,+    solverSolveMulti,+    solverSolveMultiExcept,+    withSolver,+  )+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 (..),+    distinct,+    genericLiftSymEq,+    genericSymEq,+    symEq1,+    symEq2,+  )+import Grisette.Internal.Core.Data.Class.SymFiniteBits+  ( FromBits (..),+    SymFiniteBits (..),+    bitBlast,+    lsb,+    msb,+    setBitTo,+    symBitBlast,+    symCountLeadingZeros,+    symCountTrailingZeros,+    symLsb,+    symMsb,+    symPopCount,+  )+import Grisette.Internal.Core.Data.Class.SymFromIntegral+  ( SymFromIntegral (..),+  )+import Grisette.Internal.Core.Data.Class.SymIEEEFP+  ( SymIEEEFPTraits (..),+  )+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+  ( 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 (..),+    mrgSingle,+    mrgSingleWithStrategy,+    mrgToSym,+    toUnionSym,+    tryMerge,+  )+import Grisette.Internal.Core.Data.Class.UnionView+  ( IfViewResult (..),+    UnionView (..),+    liftToMonadUnion,+    liftUnion,+    onUnion,+    onUnion2,+    onUnion3,+    onUnion4,+    simpleMerge,+    unionToCon,+    (.#),+    pattern If,+    pattern Single,+  )+import Grisette.Internal.Core.Data.MemoUtils+  ( htmemo,+    htmemo2,+    htmemo3,+    htmemoFix,+    htmup,+    stableMemo,+    stableMemo2,+    stableMemo3,+    stableMemoFix,+    stableMup,+    weakStableMemo,+    weakStableMemo2,+    weakStableMemo3,+    weakStableMemoFix,+    weakStableMup,+  )+import Grisette.Internal.Core.Data.SExpr+  ( SExpr (..),+    fileLocation,+    showsSExprWithParens,+  )+import Grisette.Internal.Core.Data.Symbol+  ( AsMetadata (..),+    Identifier (..),+    Symbol (..),+    identifier,+    indexed,+    mapIdentifier,+    mapMetadata,+    simple,+    symbolIdentifier,+    uniqueIdentifier,+    withLocation,+    withMetadata,+    pattern Metadata,+  )+import Grisette.Internal.Internal.Decl.Core.Data.Class.Mergeable (MergingIndex)+import Instances.TH.Lift ()++-- $setup+-- >>> import Grisette+-- >>> import Grisette.Core+-- >>> import Grisette.Lib.Base+-- >>> import Grisette.SymPrim+-- >>> import Grisette.TH
− src/Grisette/Core/BuiltinUnionWrappers.hs 
@@ -1,45 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE Trustworthy #-}---- |--- Module      :   Grisette.Core.BuiltinUnionWrapper--- 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.Core.BuiltinUnionWrappers-  ( -- * Builtin constructor wrappers for some common data types-    mrgTrue,-    mrgFalse,-    mrgUnit,-    mrgTuple2,-    mrgTuple3,-    mrgJust,-    mrgNothing,-    mrgLeft,-    mrgRight,-    mrgInL,-    mrgInR,-    mrgAssertionViolation,-    mrgAssumptionViolation,-  )-where--import Data.Functor.Sum (Sum)-import Grisette.Core.Control.Exception (VerificationConditions)-import Grisette.Core.Data.Class.SimpleMergeable (mrgSingle)-import Grisette.Core.TH (makeUnionWrapper, makeUnionWrapper')--$(makeUnionWrapper "mrg" ''Bool)-$(makeUnionWrapper' ["mrgUnit"] ''())-$(makeUnionWrapper' ["mrgTuple2"] ''(,))-$(makeUnionWrapper' ["mrgTuple3"] ''(,,))-$(makeUnionWrapper "mrg" ''Maybe)-$(makeUnionWrapper "mrg" ''Either)-$(makeUnionWrapper "mrg" ''Sum)-$(makeUnionWrapper "mrg" ''VerificationConditions)
− src/Grisette/Core/Control/Exception.hs 
@@ -1,47 +0,0 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingVia #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE Trustworthy #-}---- |--- Module      :   Grisette.Core.Control.Exception--- 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.Core.Control.Exception-  ( -- * Predefined exceptions-    AssertionError (..),-    VerificationConditions (..),-  )-where--import Control.DeepSeq (NFData)-import GHC.Generics (Generic)---- import Grisette.Core.Data.Class.Mergeable (Mergeable)--- import Grisette.Core.Data.Class.SimpleMergeable---   ( SimpleMergeable,---   )---- $setup--- >>> import Grisette.Core--- >>> import Grisette.Lib.Base--- >>> import Grisette.IR.SymPrim--- >>> import Control.Monad.Trans.Except---- | Assertion error.-data AssertionError = AssertionError-  deriving (Show, Eq, Ord, Generic, NFData)---- | Verification conditions.--- A crashed program path can terminate with either assertion violation errors or assumption violation errors.-data VerificationConditions-  = AssertionViolation-  | AssumptionViolation-  deriving (Show, Eq, Ord, Generic, NFData)
− src/Grisette/Core/Control/Monad/CBMCExcept.hs 
@@ -1,475 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveLift #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE UndecidableInstances #-}---- |--- Module      :   Grisette.Core.Control.Monad.CBMCExcept--- 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.Core.Control.Monad.CBMCExcept-  ( -- * CBMC-like error handling-    CBMCEither (..),-    CBMCExceptT (..),-    cbmcExcept,-    mapCBMCExceptT,-    withCBMCExceptT,-    OrigExcept.MonadError (..),-  )-where--#if MIN_VERSION_base(4,18,0)-import Control.Applicative-  ( Alternative (empty, (<|>)),-  )-#else-import Control.Applicative-  ( Alternative (empty, (<|>)),-    Applicative (liftA2),-  )-#endif-import Control.DeepSeq (NFData)-import Control.Monad (MonadPlus (mplus, mzero))-import qualified Control.Monad.Except as OrigExcept-import qualified Control.Monad.Fail as Fail-import Control.Monad.Fix (MonadFix (mfix))-import Control.Monad.Trans (MonadIO (liftIO), MonadTrans (lift))-import Control.Monad.Zip (MonadZip (mzipWith))-import Data.Functor.Classes-  ( Eq1 (liftEq),-    Ord1 (liftCompare),-    Read1 (liftReadList, liftReadsPrec),-    Show1 (liftShowList, liftShowsPrec),-    compare1,-    eq1,-    readsData,-    readsPrec1,-    readsUnaryWith,-    showsPrec1,-    showsUnaryWith,-  )-import Data.Functor.Contravariant (Contravariant (contramap))-import Data.Hashable (Hashable)-import GHC.Generics (Generic, Generic1)-import Grisette.Core.Control.Monad.UnionM (UnionM)-import Grisette.Core.Data.Class.EvaluateSym (EvaluateSym (evaluateSym))-import Grisette.Core.Data.Class.ExtractSymbolics-  ( ExtractSymbolics (extractSymbolics),-  )-import Grisette.Core.Data.Class.GenSym-  ( GenSym (fresh),-    GenSymSimple (simpleFresh),-    derivedNoSpecFresh,-    derivedSameShapeSimpleFresh,-  )-import Grisette.Core.Data.Class.Mergeable-  ( Mergeable (rootStrategy),-    Mergeable1 (liftRootStrategy),-    MergingStrategy (NoStrategy, SimpleStrategy, SortedStrategy),-    rootStrategy1,-    wrapStrategy,-  )-import Grisette.Core.Data.Class.SEq (SEq ((.==)))-import Grisette.Core.Data.Class.SOrd (SOrd (symCompare, (.<), (.<=), (.>), (.>=)))-import Grisette.Core.Data.Class.SimpleMergeable-  ( SimpleMergeable (mrgIte),-    SimpleMergeable1 (liftMrgIte),-    UnionLike (mergeWithStrategy, mrgIfWithStrategy, single, unionIf),-    merge,-    mrgIf,-  )-import Grisette.Core.Data.Class.Solver (UnionWithExcept (extractUnionExcept))-import Grisette.Core.Data.Class.ToCon (ToCon (toCon))-import Grisette.Core.Data.Class.ToSym (ToSym (toSym))-import Language.Haskell.TH.Syntax (Lift)-import Unsafe.Coerce (unsafeCoerce)---- | A wrapper type for 'Either'. Uses different merging strategies.-newtype CBMCEither a b = CBMCEither {runCBMCEither :: Either a b}-  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 (EvaluateSym a, EvaluateSym b) => EvaluateSym (CBMCEither a b)--deriving newtype instance-  (ExtractSymbolics a, ExtractSymbolics b) =>-  ExtractSymbolics (CBMCEither a b)--instance-  ( GenSymSimple a a,-    Mergeable a,-    GenSymSimple b b,-    Mergeable b-  ) =>-  GenSym (CBMCEither a b) (CBMCEither a b)--instance-  ( GenSymSimple a a,-    GenSymSimple b b-  ) =>-  GenSymSimple (CBMCEither a b) (CBMCEither a b)-  where-  simpleFresh = derivedSameShapeSimpleFresh--instance-  (GenSym () a, Mergeable a, GenSym () b, Mergeable b) =>-  GenSym () (CBMCEither a b)-  where-  fresh = derivedNoSpecFresh--deriving newtype instance (SOrd a, SOrd b) => SOrd (CBMCEither a b)--deriving newtype instance (ToCon e1 e2, ToCon a1 a2) => ToCon (Either e1 a1) (CBMCEither e2 a2)--instance (ToCon e1 e2, ToCon a1 a2) => ToCon (CBMCEither e1 a1) (CBMCEither e2 a2) where-  toCon (CBMCEither a) = CBMCEither <$> toCon a--instance (ToCon e1 e2, ToCon a1 a2) => ToCon (CBMCEither e1 a1) (Either e2 a2) where-  toCon (CBMCEither a) = toCon a--deriving newtype instance (ToSym e1 e2, ToSym a1 a2) => ToSym (Either e1 a1) (CBMCEither e2 a2)--instance (ToSym e1 e2, ToSym a1 a2) => ToSym (CBMCEither e1 a1) (CBMCEither e2 a2) where-  toSym (CBMCEither a) = CBMCEither $ toSym a--instance (ToSym e1 e2, ToSym a1 a2) => ToSym (CBMCEither e1 a1) (Either e2 a2) where-  toSym (CBMCEither a) = toSym a--data EitherIdx idx = L idx | R deriving (Eq, Ord, Show)--instance (Mergeable e, Mergeable a) => Mergeable (CBMCEither e a) where-  rootStrategy = rootStrategy1--instance (Mergeable e) => Mergeable1 (CBMCEither e) where-  liftRootStrategy ms = case rootStrategy of-    SimpleStrategy m ->-      SortedStrategy-        ( \(CBMCEither e) -> case e of-            Left _ -> False-            Right _ -> True-        )-        ( \case-            False -> SimpleStrategy $-              \cond (CBMCEither le) (CBMCEither re) -> case (le, re) of-                (Left l, Left r) -> CBMCEither $ Left $ m cond l r-                _ -> error "impossible"-            True -> wrapStrategy ms (CBMCEither . Right) (\case (CBMCEither (Right x)) -> x; _ -> error "impossible")-        )-    NoStrategy ->-      SortedStrategy-        ( \(CBMCEither e) -> case e of-            Left _ -> False-            Right _ -> True-        )-        ( \case-            False -> NoStrategy-            True -> wrapStrategy ms (CBMCEither . Right) (\case (CBMCEither (Right x)) -> x; _ -> error "impossible")-        )-    SortedStrategy idx sub ->-      SortedStrategy-        ( \(CBMCEither e) -> case e of-            Left v -> L $ idx v-            Right _ -> R-        )-        ( \case-            L i -> wrapStrategy (sub i) (CBMCEither . Left) (\case (CBMCEither (Left x)) -> x; _ -> error "impossible")-            R -> wrapStrategy ms (CBMCEither . Right) (\case (CBMCEither (Right x)) -> x; _ -> error "impossible")-        )--cbmcEither :: forall a c b. (a -> c) -> (b -> c) -> CBMCEither a b -> c-cbmcEither l r v = either l r (unsafeCoerce v)---- | Wrap an 'Either' value in 'CBMCExceptT'-cbmcExcept :: (Monad m) => Either e a -> CBMCExceptT e m a-cbmcExcept m = CBMCExceptT (return $ CBMCEither m)---- | Map the error and values in a 'CBMCExceptT'-mapCBMCExceptT :: (m (Either e a) -> n (Either e' b)) -> CBMCExceptT e m a -> CBMCExceptT e' n b-mapCBMCExceptT f m = CBMCExceptT $ (unsafeCoerce . f . unsafeCoerce) (runCBMCExceptT m)---- | Map the error in a 'CBMCExceptT'-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.-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-  liftEq eq (CBMCExceptT x) (CBMCExceptT y) = liftEq (liftEq eq) x y-  {-# INLINE liftEq #-}--instance (Ord e, Ord1 m) => Ord1 (CBMCExceptT e m) where-  liftCompare comp (CBMCExceptT x) (CBMCExceptT y) =-    liftCompare (liftCompare comp) x y-  {-# INLINE liftCompare #-}--instance (Read e, Read1 m) => Read1 (CBMCExceptT e m) where-  liftReadsPrec rp rl =-    readsData $-      readsUnaryWith (liftReadsPrec rp' rl') "CBMCExceptT" CBMCExceptT-    where-      rp' = liftReadsPrec rp rl-      rl' = liftReadList rp rl--instance (Show e, Show1 m) => Show1 (CBMCExceptT e m) where-  liftShowsPrec sp sl d (CBMCExceptT m) =-    showsUnaryWith (liftShowsPrec sp' sl') "CBMCExceptT" d m-    where-      sp' = liftShowsPrec sp sl-      sl' = liftShowList sp sl--instance (Eq e, Eq1 m, Eq a) => Eq (CBMCExceptT e m a) where-  (==) = eq1--instance (Ord e, Ord1 m, Ord a) => Ord (CBMCExceptT e m a) where-  compare = compare1--instance (Read e, Read1 m, Read a) => Read (CBMCExceptT e m a) where-  readsPrec = readsPrec1--instance (Show e, Show1 m, Show a) => Show (CBMCExceptT e m a) where-  showsPrec = showsPrec1--instance (Functor m) => Functor (CBMCExceptT e m) where-  fmap f = CBMCExceptT . fmap (fmap f) . runCBMCExceptT-  {-# INLINE fmap #-}--instance (Foldable f) => Foldable (CBMCExceptT e f) where-  foldMap f (CBMCExceptT a) = foldMap (cbmcEither (const mempty) f) a-  {-# INLINE foldMap #-}--instance (Traversable f) => Traversable (CBMCExceptT e f) where-  traverse f (CBMCExceptT a) =-    CBMCExceptT <$> traverse (cbmcEither (pure . CBMCEither . Left) (fmap (CBMCEither . Right) . f)) a-  {-# INLINE traverse #-}--instance (Functor m, Monad m) => Applicative (CBMCExceptT e m) where-  pure a = CBMCExceptT $ return (CBMCEither . Right $ a)-  {-# INLINE pure #-}-  CBMCExceptT f <*> CBMCExceptT v = CBMCExceptT $ do-    mf <- f-    case mf of-      CBMCEither (Left e) -> return (CBMCEither . Left $ e)-      CBMCEither (Right k) -> do-        mv <- v-        case mv of-          CBMCEither (Left e) -> return (CBMCEither . Left $ e)-          CBMCEither (Right x) -> return (CBMCEither . Right $ k x)-  {-# INLINEABLE (<*>) #-}-  m *> k = m >> k-  {-# INLINE (*>) #-}--instance (Functor m, Monad m, Monoid e) => Alternative (CBMCExceptT e m) where-  empty = CBMCExceptT $ return (CBMCEither . Left $ mempty)-  {-# INLINE empty #-}-  CBMCExceptT mx <|> CBMCExceptT my = CBMCExceptT $ do-    ex <- mx-    case ex of-      CBMCEither (Left e) -> fmap (cbmcEither (CBMCEither . Left . mappend e) (CBMCEither . Right)) my-      CBMCEither (Right x) -> return (CBMCEither . Right $ x)-  {-# INLINEABLE (<|>) #-}--instance (Monad m) => Monad (CBMCExceptT e m) where-  m >>= k = CBMCExceptT $ do-    a <- runCBMCExceptT m-    case a of-      CBMCEither (Left e) -> return (CBMCEither $ Left e)-      CBMCEither (Right x) -> runCBMCExceptT (k x)-  {-# INLINE (>>=) #-}--instance (Fail.MonadFail m) => Fail.MonadFail (CBMCExceptT e m) where-  fail = CBMCExceptT . Fail.fail-  {-# INLINE fail #-}--instance (Monad m, Monoid e) => MonadPlus (CBMCExceptT e m) where-  mzero = CBMCExceptT $ return (CBMCEither $ Left mempty)-  {-# INLINE mzero #-}-  CBMCExceptT mx `mplus` CBMCExceptT my = CBMCExceptT $ do-    ex <- mx-    case ex of-      CBMCEither (Left e) -> fmap (cbmcEither (CBMCEither . Left . mappend e) (CBMCEither . Right)) my-      CBMCEither (Right x) -> return (CBMCEither $ Right x)-  {-# INLINEABLE mplus #-}--instance (MonadFix m) => MonadFix (CBMCExceptT e m) where-  mfix f = CBMCExceptT (mfix (runCBMCExceptT . f . cbmcEither (const bomb) id))-    where-      bomb = error "mfix (CBMCExceptT): inner computation returned Left value"-  {-# INLINE mfix #-}--instance MonadTrans (CBMCExceptT e) where-  lift = CBMCExceptT . fmap (CBMCEither . Right)-  {-# INLINE lift #-}--instance (MonadIO m) => MonadIO (CBMCExceptT e m) where-  liftIO = lift . liftIO-  {-# INLINE liftIO #-}--instance (MonadZip m) => MonadZip (CBMCExceptT e m) where-  mzipWith f (CBMCExceptT a) (CBMCExceptT b) = CBMCExceptT $ mzipWith (liftA2 f) a b-  {-# INLINE mzipWith #-}--instance (Contravariant m) => Contravariant (CBMCExceptT e m) where-  contramap f = CBMCExceptT . contramap (fmap f) . runCBMCExceptT-  {-# INLINE contramap #-}--throwE :: (Monad m) => e -> CBMCExceptT e m a-throwE = CBMCExceptT . return . CBMCEither . Left-{-# INLINE throwE #-}--catchE ::-  (Monad m) =>-  CBMCExceptT e m a ->-  (e -> CBMCExceptT e' m a) ->-  CBMCExceptT e' m a-m `catchE` h = CBMCExceptT $ do-  a <- runCBMCExceptT m-  case a of-    CBMCEither (Left l) -> runCBMCExceptT (h l)-    CBMCEither (Right r) -> return (CBMCEither . Right $ r)-{-# INLINE catchE #-}--instance (Monad m) => OrigExcept.MonadError e (CBMCExceptT e m) where-  throwError = throwE-  {-# INLINE throwError #-}-  catchError = catchE-  {-# INLINE catchError #-}--instance (SEq (m (CBMCEither e a))) => SEq (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-  (ExtractSymbolics (m (CBMCEither e a))) =>-  ExtractSymbolics (CBMCExceptT e m a)-  where-  extractSymbolics (CBMCExceptT v) = extractSymbolics v--instance-  (Mergeable1 m, Mergeable e, Mergeable a) =>-  Mergeable (CBMCExceptT e m a)-  where-  rootStrategy = wrapStrategy rootStrategy1 CBMCExceptT runCBMCExceptT-  {-# INLINE rootStrategy #-}--instance (Mergeable1 m, Mergeable e) => Mergeable1 (CBMCExceptT e m) where-  liftRootStrategy m = wrapStrategy (liftRootStrategy (liftRootStrategy m)) CBMCExceptT runCBMCExceptT-  {-# INLINE liftRootStrategy #-}--instance-  {-# OVERLAPPABLE #-}-  ( GenSym spec (m (CBMCEither a b)),-    Mergeable1 m,-    Mergeable a,-    Mergeable b-  ) =>-  GenSym spec (CBMCExceptT a m b)-  where-  fresh v = do-    x <- fresh v-    return $ merge . fmap CBMCExceptT $ x--instance-  {-# OVERLAPPABLE #-}-  ( GenSymSimple spec (m (CBMCEither a b))-  ) =>-  GenSymSimple spec (CBMCExceptT a m b)-  where-  simpleFresh v = CBMCExceptT <$> simpleFresh v--instance-  {-# OVERLAPPING #-}-  ( GenSymSimple (m (CBMCEither e a)) (m (CBMCEither e a))-  ) =>-  GenSymSimple (CBMCExceptT e m a) (CBMCExceptT e m a)-  where-  simpleFresh (CBMCExceptT v) = CBMCExceptT <$> simpleFresh v--instance-  {-# OVERLAPPING #-}-  ( GenSymSimple (m (CBMCEither e a)) (m (CBMCEither e a)),-    Mergeable1 m,-    Mergeable e,-    Mergeable a-  ) =>-  GenSym (CBMCExceptT e m a) (CBMCExceptT e m a)--instance-  (UnionLike m, Mergeable e, Mergeable a) =>-  SimpleMergeable (CBMCExceptT e m a)-  where-  mrgIte = mrgIf-  {-# INLINE mrgIte #-}--instance-  (UnionLike m, Mergeable e) =>-  SimpleMergeable1 (CBMCExceptT e m)-  where-  liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m)-  {-# INLINE liftMrgIte #-}--instance-  (UnionLike m, Mergeable e) =>-  UnionLike (CBMCExceptT e m)-  where-  mergeWithStrategy s (CBMCExceptT v) = CBMCExceptT $ mergeWithStrategy (liftRootStrategy s) v-  {-# INLINE mergeWithStrategy #-}-  mrgIfWithStrategy s cond (CBMCExceptT t) (CBMCExceptT f) = CBMCExceptT $ mrgIfWithStrategy (liftRootStrategy s) cond t f-  {-# INLINE mrgIfWithStrategy #-}-  single = CBMCExceptT . single . return-  {-# INLINE single #-}-  unionIf cond (CBMCExceptT l) (CBMCExceptT r) = CBMCExceptT $ unionIf cond l r-  {-# INLINE unionIf #-}--instance (SOrd (m (CBMCEither e a))) => SOrd (CBMCExceptT e m a) where-  (CBMCExceptT l) .<= (CBMCExceptT r) = l .<= r-  (CBMCExceptT l) .< (CBMCExceptT r) = l .< r-  (CBMCExceptT l) .>= (CBMCExceptT r) = l .>= r-  (CBMCExceptT l) .> (CBMCExceptT r) = l .> r-  symCompare (CBMCExceptT l) (CBMCExceptT r) = symCompare l r--instance-  (ToCon (m1 (CBMCEither e1 a)) (m2 (CBMCEither e2 b))) =>-  ToCon (CBMCExceptT e1 m1 a) (CBMCExceptT e2 m2 b)-  where-  toCon (CBMCExceptT v) = CBMCExceptT <$> toCon v--instance-  (ToCon (m1 (CBMCEither e1 a)) (Either e2 b)) =>-  ToCon (CBMCExceptT e1 m1 a) (Either e2 b)-  where-  toCon (CBMCExceptT v) = toCon v--instance-  (ToSym (m1 (CBMCEither e1 a)) (m2 (CBMCEither e2 b))) =>-  ToSym (CBMCExceptT e1 m1 a) (CBMCExceptT e2 m2 b)-  where-  toSym (CBMCExceptT v) = CBMCExceptT $ toSym v--instance-  (Monad u, UnionLike u, Mergeable e, Mergeable v) =>-  UnionWithExcept (CBMCExceptT e u v) u e v-  where-  extractUnionExcept = merge . fmap runCBMCEither . runCBMCExceptT--instance UnionWithExcept (UnionM (CBMCEither e v)) UnionM e v where-  extractUnionExcept = fmap runCBMCEither
− src/Grisette/Core/Control/Monad/Class/MonadParallelUnion.hs 
@@ -1,124 +0,0 @@-{-# LANGUAGE LambdaCase #-}---- |--- Module      :   Grisette.Core.Control.Monad.Class.MonadParallelUnion--- Copyright   :   (c) Sirui Lu 2023--- License     :   BSD-3-Clause (see the LICENSE file)------ Maintainer  :   siruilu@cs.washington.edu--- Stability   :   Experimental--- Portability :   GHC only-module Grisette.Core.Control.Monad.Class.MonadParallelUnion-  ( MonadParallelUnion (..),-  )-where--import Control.DeepSeq (NFData)-import Control.Monad.Except (ExceptT (ExceptT), runExceptT)-import Control.Monad.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 Grisette.Core.Data.Class.Mergeable (Mergeable)-import Grisette.Core.Data.Class.SimpleMergeable-  ( UnionLike,-    merge,-  )---- | Parallel union monad.------ With the @QualifiedDo@ extension and the "Grisette.Qualified.ParallelUnionDo"--- module, one can execute the paths in parallel and merge the results with:------ > :set -XQualifiedDo -XOverloadedStrings--- > import Grisette--- > import qualified Grisette.Qualified.ParallelUnionDo as P--- > P.do--- >   x <- mrgIf "a" (return 1) (return 2) :: UnionM Int--- >   return $ x + 1--- >--- > -- {If a 2 3}-class (UnionLike m, Monad m) => MonadParallelUnion m where-  parBindUnion :: (Mergeable b, NFData b) => m a -> (a -> m b) -> m b--instance (MonadParallelUnion m) => MonadParallelUnion (MaybeT m) where-  parBindUnion (MaybeT x) f =-    MaybeT $-      x `parBindUnion` \case-        Nothing -> return Nothing-        Just x'' -> runMaybeT $ f x''-  {-# INLINE parBindUnion #-}--instance (MonadParallelUnion m, Mergeable e, NFData e) => MonadParallelUnion (ExceptT e m) where-  parBindUnion (ExceptT x) f =-    ExceptT $-      x `parBindUnion` \case-        Left e -> return $ Left e-        Right x'' -> runExceptT $ f x''-  {-# INLINE parBindUnion #-}--instance (MonadParallelUnion m, Mergeable s, NFData s) => MonadParallelUnion (StateLazy.StateT s m) where-  parBindUnion (StateLazy.StateT x) f = StateLazy.StateT $ \s ->-    x s `parBindUnion` \case-      ~(a, s') -> StateLazy.runStateT (f a) s'-  {-# INLINE parBindUnion #-}--instance (MonadParallelUnion m, Mergeable s, NFData s) => MonadParallelUnion (StateStrict.StateT s m) where-  parBindUnion (StateStrict.StateT x) f = StateStrict.StateT $ \s ->-    x s `parBindUnion` \case-      (a, s') -> StateStrict.runStateT (f a) s'-  {-# INLINE parBindUnion #-}--instance (MonadParallelUnion m, Mergeable s, Monoid s, NFData s) => MonadParallelUnion (WriterLazy.WriterT s m) where-  parBindUnion (WriterLazy.WriterT x) f =-    WriterLazy.WriterT $-      x `parBindUnion` \case-        ~(a, w) ->-          WriterLazy.runWriterT (f a) `parBindUnion` \case-            ~(b, w') -> return (b, w <> w')-  {-# INLINE parBindUnion #-}--instance (MonadParallelUnion m, Mergeable s, Monoid s, NFData s) => MonadParallelUnion (WriterStrict.WriterT s m) where-  parBindUnion (WriterStrict.WriterT x) f =-    WriterStrict.WriterT $-      x `parBindUnion` \case-        (a, w) ->-          WriterStrict.runWriterT (f a) `parBindUnion` \case-            (b, w') -> return (b, w <> w')-  {-# INLINE parBindUnion #-}--instance (MonadParallelUnion m, Mergeable a, NFData a) => MonadParallelUnion (ReaderT a m) where-  parBindUnion (ReaderT x) f = ReaderT $ \a ->-    x a `parBindUnion` \a' -> runReaderT (f a') a-  {-# INLINE parBindUnion #-}--instance (MonadParallelUnion m) => MonadParallelUnion (IdentityT m) where-  parBindUnion (IdentityT x) f = IdentityT $ x `parBindUnion` (merge . runIdentityT . f)-  {-# INLINE parBindUnion #-}--instance-  (MonadParallelUnion m, Mergeable s, Mergeable r, Mergeable w, Monoid w, NFData r, NFData w, NFData s) =>-  MonadParallelUnion (RWSStrict.RWST r w s m)-  where-  parBindUnion m k = RWSStrict.RWST $ \r s ->-    RWSStrict.runRWST m r s `parBindUnion` \case-      (a, s', w) ->-        RWSStrict.runRWST (k a) r s' `parBindUnion` \case-          (b, s'', w') -> return (b, s'', w <> w')-  {-# INLINE parBindUnion #-}--instance-  (MonadParallelUnion m, Mergeable s, Mergeable r, Mergeable w, Monoid w, NFData r, NFData w, NFData s) =>-  MonadParallelUnion (RWSLazy.RWST r w s m)-  where-  parBindUnion m k = RWSLazy.RWST $ \r s ->-    RWSLazy.runRWST m r s `parBindUnion` \case-      ~(a, s', w) ->-        RWSLazy.runRWST (k a) r s' `parBindUnion` \case-          ~(b, s'', w') -> return (b, s'', w <> w')-  {-# INLINE parBindUnion #-}
− src/Grisette/Core/Control/Monad/Union.hs 
@@ -1,29 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE UndecidableInstances #-}---- |--- Module      :   Grisette.Core.Control.Monad.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.Core.Control.Monad.Union-  ( -- * MonadUnion-    MonadUnion,-  )-where--import Grisette.Core.Data.Class.SimpleMergeable (UnionLike)---- $setup--- >>> import Grisette.Core--- >>> import Grisette.IR.SymPrim---- | Class for monads that support union-like operations and 'Grisette.Core.Data.Class.Mergeable' knowledge propagation.-type MonadUnion u = (UnionLike u, Monad u)
− src/Grisette/Core/Control/Monad/UnionM.hs 
@@ -1,608 +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 #-}---- {-# OPTIONS_GHC -fno-full-laziness #-}---- |--- Module      :   Grisette.Core.Control.Monad.UnionM--- 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.Core.Control.Monad.UnionM-  ( -- * UnionM and helpers-    UnionM (..),-    liftToMonadUnion,-    underlyingUnion,-    isMerged,-    (.#),-    IsConcrete,-    unionSize,-  )-where--import Control.DeepSeq (NFData (rnf), NFData1 (liftRnf), force, rnf1)-import Control.Parallel.Strategies (rpar, rseq, runEval)-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.Core.Control.Monad.Class.MonadParallelUnion-  ( MonadParallelUnion (parBindUnion),-  )-import Grisette.Core.Control.Monad.Union (MonadUnion)-import Grisette.Core.Data.BV (IntN, WordN)-import Grisette.Core.Data.Class.EvaluateSym (EvaluateSym (evaluateSym))-import Grisette.Core.Data.Class.ExtractSymbolics-  ( ExtractSymbolics (extractSymbolics),-  )-import Grisette.Core.Data.Class.Function (Function (Arg, Ret, (#)))-import Grisette.Core.Data.Class.GPretty-  ( GPretty (gpretty),-    groupedEnclose,-  )-import Grisette.Core.Data.Class.ITEOp (ITEOp (symIte))-import Grisette.Core.Data.Class.LogicalOp-  ( LogicalOp (symImplies, symNot, symXor, (.&&), (.||)),-  )-import Grisette.Core.Data.Class.Mergeable-  ( Mergeable (rootStrategy),-    Mergeable1 (liftRootStrategy),-    MergingStrategy (SimpleStrategy),-  )-import Grisette.Core.Data.Class.SEq (SEq ((.==)))-import Grisette.Core.Data.Class.SimpleMergeable-  ( SimpleMergeable (mrgIte),-    SimpleMergeable1 (liftMrgIte),-    UnionLike (mergeWithStrategy, mrgIfWithStrategy, single, unionIf),-    UnionPrjOp (ifView, leftMost, singleView),-    merge,-    mrgIf,-    mrgSingle,-    simpleMerge,-    (.#),-  )-import Grisette.Core.Data.Class.Solvable-  ( Solvable (con, conView, iinfosym, isym, sinfosym, ssym),-    pattern Con,-  )-import Grisette.Core.Data.Class.Solver (UnionWithExcept (extractUnionExcept))-import Grisette.Core.Data.Class.SubstituteSym (SubstituteSym (substituteSym))-import Grisette.Core.Data.Class.ToCon (ToCon (toCon))-import Grisette.Core.Data.Class.ToSym (ToSym (toSym))-import Grisette.Core.Data.Union-  ( Union (UnionIf, UnionSingle),-    fullReconstruct,-    ifWithStrategy,-  )-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term-  ( LinkedRep,-    SupportedPrim,-    type (-->),-  )-import Grisette.IR.SymPrim.Data.SymPrim-  ( AllSyms (allSymsS),-    SymBool,-    SymIntN,-    SymInteger,-    SymWordN,-    type (-~>),-    type (=~>),-  )-import Grisette.IR.SymPrim.Data.TabularFun (type (=->))-import Language.Haskell.TH.Syntax (Lift (lift, liftTyped))-import Language.Haskell.TH.Syntax.Compat (unTypeSplice)---- $setup--- >>> import Grisette.Core--- >>> import Grisette.IR.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}------ 'unionIf' cannot resolve the 'Mergeable' constraint.------ >>> unionIf "a" (return 1) (unionIf "b" (return 1) (return 2)) :: UnionM Integer--- <If a 1 (If b 1 2)>------ But 'unionIf' is able to merge the result if some of the branches are merged:------ >>> unionIf "a" (return 1) (unionIf "b" (mrgReturn 1) (return 2)) :: UnionM Integer--- {If (|| a b) 1 2}------ The '>>=' operator uses 'unionIf' internally. When the final statement in a do-block--- merges the values, the system can then merge the final result.------ >>> :{---   do---     x <- unionIf (ssym "a") (return 1) (unionIf (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 <- unionIf (ssym "a") (return 1) (unionIf (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 UnionPrjOp 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 #-}-  leftMost = leftMost . underlyingUnion-  {-# INLINE leftMost #-}--instance Functor UnionM where-  fmap f fa = fa >>= return . f-  {-# INLINE fmap #-}--instance Applicative UnionM where-  pure = single-  {-# 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' =-  unionIf cond (bindUnion ifTrue f') (bindUnion ifFalse f')-{-# INLINE bindUnion #-}--instance Monad UnionM where-  a >>= f = bindUnion (underlyingUnion a) f-  {-# INLINE (>>=) #-}--parBindUnion'' :: (Mergeable b, NFData b) => Union a -> (a -> UnionM b) -> UnionM b-parBindUnion'' (UnionSingle a) f = merge $ f a-parBindUnion'' u f = parBindUnion' u f--parBindUnion' :: (Mergeable b, NFData b) => Union a -> (a -> UnionM b) -> UnionM b-parBindUnion' (UnionSingle a') f' = f' a'-parBindUnion' (UnionIf _ _ cond ifTrue ifFalse) f' = runEval $ do-  l <- rpar $ force $ parBindUnion' ifTrue f'-  r <- rpar $ force $ parBindUnion' ifFalse f'-  l' <- rseq l-  r' <- rseq r-  rseq $ mrgIf cond l' r'-{-# INLINE parBindUnion' #-}--instance MonadParallelUnion UnionM where-  parBindUnion = parBindUnion'' . underlyingUnion-  {-# INLINE parBindUnion #-}--instance (Mergeable a) => Mergeable (UnionM a) where-  rootStrategy = SimpleStrategy $ \cond t f -> unionIf cond t f >>= mrgSingle-  {-# INLINE rootStrategy #-}--instance (Mergeable a) => SimpleMergeable (UnionM a) where-  mrgIte = mrgIf-  {-# INLINE mrgIte #-}--instance Mergeable1 UnionM where-  liftRootStrategy m = SimpleStrategy $-    \cond t f -> unionIf cond t f >>= (UMrg m . UnionSingle)-  {-# INLINE liftRootStrategy #-}--instance SimpleMergeable1 UnionM where-  liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m)-  {-# INLINE liftMrgIte #-}--instance UnionLike UnionM where-  mergeWithStrategy _ m@(UMrg _ _) = m-  mergeWithStrategy s (UAny u) = UMrg s $ fullReconstruct s u-  {-# INLINE mergeWithStrategy #-}-  mrgIfWithStrategy s (Con c) l r = if c then mergeWithStrategy s l else mergeWithStrategy s r-  mrgIfWithStrategy s cond l r =-    mergeWithStrategy s $ unionIf cond l r-  {-# INLINE mrgIfWithStrategy #-}-  single = UAny . single-  {-# INLINE single #-}-  unionIf cond (UAny a) (UAny b) = UAny $ unionIf cond a b-  unionIf cond (UMrg m a) (UAny b) = UMrg m $ ifWithStrategy m cond a b-  unionIf cond a (UMrg m b) = UMrg m $ ifWithStrategy m cond (underlyingUnion a) b-  {-# INLINE unionIf #-}--instance (SEq a) => SEq (UnionM a) where-  x .== y = simpleMerge $ do-    x1 <- x-    y1 <- y-    mrgSingle $ x1 .== y1---- | Lift the 'UnionM' to any 'MonadUnion'.-liftToMonadUnion :: (Mergeable a, MonadUnion u) => UnionM a -> u a-liftToMonadUnion u = go (underlyingUnion u)-  where-    go (UnionSingle v) = mrgSingle v-    go (UnionIf _ _ c t f) = mrgIf c (go t) (go f)--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 = merge . 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 ca, SupportedPrim 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) => ToCon (UnionM a) b where-  toCon v = go $ underlyingUnion v-    where-      go (UnionSingle x) = toCon x-      go _ = Nothing--instance (ToCon a b, Mergeable b) => ToCon (UnionM a) (UnionM b) where-  toCon v = go $ underlyingUnion 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 x = x >>= (mrgSingle . negate)-  x + y = x >>= \x1 -> y >>= \y1 -> mrgSingle $ x1 + y1-  x - y = x >>= \x1 -> y >>= \y1 -> mrgSingle $ x1 - y1-  x * y = x >>= \x1 -> y >>= \y1 -> mrgSingle $ x1 * y1-  abs x = x >>= mrgSingle . abs-  signum x = x >>= mrgSingle . signum--instance (ITEOp a, Mergeable a) => ITEOp (UnionM a) where-  symIte = mrgIf--instance (LogicalOp a, Mergeable a) => LogicalOp (UnionM a) where-  a .|| b = do-    a1 <- a-    b1 <- b-    mrgSingle $ a1 .|| b1-  a .&& b = do-    a1 <- a-    b1 <- b-    mrgSingle $ a1 .&& b1-  symNot x = do-    x1 <- x-    mrgSingle $ symNot x1-  symXor a b = do-    a1 <- a-    b1 <- b-    mrgSingle $ a1 `symXor` b1-  symImplies a b = do-    a1 <- a-    b1 <- b-    mrgSingle $ a1 `symImplies` b1--instance (Solvable c t, Mergeable t) => Solvable c (UnionM t) where-  con = mrgSingle . con-  {-# INLINE con #-}-  ssym = mrgSingle . ssym-  {-# INLINE ssym #-}-  isym i s = mrgSingle $ isym i s-  {-# INLINE isym #-}-  sinfosym s info = mrgSingle $ sinfosym s info-  {-# INLINE sinfosym #-}-  iinfosym i s info = mrgSingle $ iinfosym i s info-  {-# INLINE iinfosym #-}-  conView v = do-    c <- singleView v-    conView c-  {-# INLINE conView #-}--instance-  (Function f, Mergeable f, Mergeable a, Ret f ~ a) =>-  Function (UnionM f)-  where-  type Arg (UnionM f) = Arg f-  type Ret (UnionM f) = UnionM (Ret f)-  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 (single True)--- 1--- >>> unionSize (mrgIf "a" (single 1) (single 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
− src/Grisette/Core/Data/BV.hs 
@@ -1,844 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveLift #-}-{-# LANGUAGE DerivingVia #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskellQuotes #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}-{-# OPTIONS_GHC -funbox-strict-fields #-}---- |--- Module      :   Grisette.Core.Data.BV--- 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.Core.Data.BV-  ( BitwidthMismatch (..),-    IntN (..),-    WordN (..),-    SomeIntN (..),-    SomeWordN (..),-    unarySomeIntN,-    unarySomeIntNR1,-    binSomeIntN,-    binSomeIntNR1,-    binSomeIntNR2,-    unarySomeWordN,-    unarySomeWordNR1,-    binSomeWordN,-    binSomeWordNR1,-    binSomeWordNR2,-  )-where--import Control.Applicative (Alternative ((<|>)))-import Control.DeepSeq (NFData (rnf))-import Control.Exception-  ( ArithException (Overflow),-    Exception (displayException),-    throw,-  )-import Data.Bits-  ( Bits-      ( bit,-        bitSize,-        bitSizeMaybe,-        clearBit,-        complement,-        complementBit,-        isSigned,-        popCount,-        rotate,-        rotateL,-        rotateR,-        setBit,-        shift,-        shiftL,-        shiftR,-        testBit,-        unsafeShiftL,-        unsafeShiftR,-        xor,-        zeroBits,-        (.&.),-        (.|.)-      ),-    FiniteBits (countLeadingZeros, countTrailingZeros, finiteBitSize),-  )-import Data.Hashable (Hashable (hashWithSalt))-import Data.Maybe (fromMaybe, isJust)-import Data.Proxy (Proxy (Proxy))-import Data.Typeable (type (:~:) (Refl))-import GHC.Enum-  ( boundedEnumFrom,-    boundedEnumFromThen,-    predError,-    succError,-    toEnumError,-  )-import GHC.Generics (Generic)-import GHC.Read-  ( Read (readListPrec, readPrec),-    parens,-    readListDefault,-    readListPrecDefault,-    readNumber,-  )-import GHC.Real ((%))-import GHC.TypeNats-  ( KnownNat,-    Nat,-    natVal,-    sameNat,-    type (+),-    type (<=),-  )-import Grisette.Core.Data.Class.BitVector-  ( BV (bvConcat, bvExt, bvSelect, bvSext, bvZext),-    SizedBV-      ( sizedBVConcat,-        sizedBVExt,-        sizedBVSelect,-        sizedBVSext,-        sizedBVZext-      ),-  )-import Grisette.Core.Data.Class.SignConversion-  ( SignConversion (toSigned, toUnsigned),-  )-import Grisette.Core.Data.Class.SymRotate-  ( DefaultFiniteBitsSymRotate (DefaultFiniteBitsSymRotate),-    SymRotate,-  )-import Grisette.Core.Data.Class.SymShift-  ( DefaultFiniteBitsSymShift (DefaultFiniteBitsSymShift),-    SymShift,-  )-import Grisette.Utils.Parameterized-  ( KnownProof (KnownProof),-    LeqProof (LeqProof),-    knownAdd,-    leqAddPos,-    unsafeKnownProof,-    unsafeLeqProof,-  )-import Language.Haskell.TH.Syntax (Lift (liftTyped))-import Numeric (showHex, showIntAtBase)-import qualified Test.QuickCheck as QC-import Text.ParserCombinators.ReadP (string)-import Text.ParserCombinators.ReadPrec-  ( ReadPrec,-    get,-    look,-    pfail,-  )-import Text.Read (lift)-import qualified Text.Read.Lex as L--data BitwidthMismatch = BitwidthMismatch-  deriving (Show, Eq, Ord, Generic)--instance Exception BitwidthMismatch where-  displayException BitwidthMismatch = "Bit width does not match"---- |--- Symbolic unsigned bit vectors.-newtype WordN (n :: Nat) = WordN {unWordN :: Integer}-  deriving (Eq, Ord, Generic, Lift, Hashable, NFData)---- |--- A non-indexed version of 'WordN'.-data SomeWordN where-  SomeWordN :: (KnownNat n, 1 <= n) => WordN n -> SomeWordN--unarySomeWordN :: (forall n. (KnownNat n, 1 <= n) => WordN n -> r) -> SomeWordN -> r-unarySomeWordN op (SomeWordN (w :: WordN w)) = op w-{-# INLINE unarySomeWordN #-}--unarySomeWordNR1 :: (forall n. (KnownNat n, 1 <= n) => WordN n -> WordN n) -> SomeWordN -> SomeWordN-unarySomeWordNR1 op (SomeWordN (w :: WordN w)) = SomeWordN $ op w-{-# INLINE unarySomeWordNR1 #-}--binSomeWordN :: (forall n. (KnownNat n, 1 <= n) => WordN n -> WordN n -> r) -> SomeWordN -> SomeWordN -> r-binSomeWordN op (SomeWordN (l :: WordN l)) (SomeWordN (r :: WordN r)) =-  case sameNat (Proxy @l) (Proxy @r) of-    Just Refl -> op l r-    Nothing -> throw BitwidthMismatch-{-# INLINE binSomeWordN #-}--binSomeWordNR1 :: (forall n. (KnownNat n, 1 <= n) => WordN n -> WordN n -> WordN n) -> SomeWordN -> SomeWordN -> SomeWordN-binSomeWordNR1 op (SomeWordN (l :: WordN l)) (SomeWordN (r :: WordN r)) =-  case sameNat (Proxy @l) (Proxy @r) of-    Just Refl -> SomeWordN $ op l r-    Nothing -> throw BitwidthMismatch-{-# INLINE binSomeWordNR1 #-}--binSomeWordNR2 :: (forall n. (KnownNat n, 1 <= n) => WordN n -> WordN n -> (WordN n, WordN n)) -> SomeWordN -> SomeWordN -> (SomeWordN, SomeWordN)-binSomeWordNR2 op (SomeWordN (l :: WordN l)) (SomeWordN (r :: WordN r)) =-  case sameNat (Proxy @l) (Proxy @r) of-    Just Refl ->-      case op l r of-        (a, b) -> (SomeWordN a, SomeWordN b)-    Nothing -> throw BitwidthMismatch-{-# INLINE binSomeWordNR2 #-}--instance Eq SomeWordN where-  SomeWordN (l :: WordN l) == SomeWordN (r :: WordN r) =-    case sameNat (Proxy @l) (Proxy @r) of-      Just Refl -> l == r-      Nothing -> False-  {-# INLINE (==) #-}-  SomeWordN (l :: WordN l) /= SomeWordN (r :: WordN r) =-    case sameNat (Proxy @l) (Proxy @r) of-      Just Refl -> l /= r-      Nothing -> True-  {-# INLINE (/=) #-}--instance Ord SomeWordN where-  (<=) = binSomeWordN (<=)-  {-# INLINE (<=) #-}-  (<) = binSomeWordN (<)-  {-# INLINE (<) #-}-  (>=) = binSomeWordN (>=)-  {-# INLINE (>=) #-}-  (>) = binSomeWordN (>)-  {-# INLINE (>) #-}-  max = binSomeWordNR1 max-  {-# INLINE max #-}-  min = binSomeWordNR1 min-  {-# INLINE min #-}-  compare = binSomeWordN compare-  {-# INLINE compare #-}--instance Lift SomeWordN where-  liftTyped (SomeWordN w) = [||SomeWordN w||]--instance Hashable SomeWordN where-  s `hashWithSalt` (SomeWordN (w :: WordN n)) = s `hashWithSalt` natVal (Proxy @n) `hashWithSalt` w--instance NFData SomeWordN where-  rnf (SomeWordN w) = rnf w--instance (KnownNat n, 1 <= n) => Show (WordN n) where-  show (WordN w) = if (bitwidth `mod` 4) == 0 then hexRepPre ++ hexRep else binRepPre ++ binRep-    where-      bitwidth = natVal (Proxy :: Proxy n)-      hexRepPre = "0x" ++ replicate (fromIntegral (bitwidth `div` 4) - length hexRep) '0'-      hexRep = showHex w ""-      binRepPre = "0b" ++ replicate (fromIntegral bitwidth - length binRep) '0'-      binRep = showIntAtBase 2 (\x -> if x == 0 then '0' else '1') w ""--convertInt :: (Num a) => L.Lexeme -> ReadPrec a-convertInt (L.Number n)-  | Just i <- L.numberToInteger n = return (fromInteger i)-convertInt _ = pfail--readBinary :: (Num a) => ReadPrec a-readBinary = parens $ do-  r0 <- look-  case r0 of-    ('-' : _) -> do-      _ <- get-      negate <$> parens parse0b-    _ -> parse0b-  where-    isDigit c = isJust (valDig c)-    valDigit c = fromMaybe 0 (valDig c)-    valDig '0' = Just 0-    valDig '1' = Just 1-    valDig _ = Nothing-    parse0b = do-      _ <- Text.Read.lift $ string "0b"-      fromInteger <$> Text.Read.lift (L.readIntP 2 isDigit valDigit)--instance (KnownNat n, 1 <= n) => Read (WordN n) where-  readPrec = readNumber convertInt <|> readBinary-  readListPrec = readListPrecDefault-  readList = readListDefault--instance Show SomeWordN where-  show (SomeWordN w) = show w---- |--- Symbolic signed bit vectors.-newtype IntN (n :: Nat) = IntN {unIntN :: Integer}-  deriving (Eq, Generic, Lift, Hashable, NFData)---- |--- A non-indexed version of 'IntN'.-data SomeIntN where-  SomeIntN :: (KnownNat n, 1 <= n) => IntN n -> SomeIntN--unarySomeIntN :: (forall n. (KnownNat n, 1 <= n) => IntN n -> r) -> SomeIntN -> r-unarySomeIntN op (SomeIntN (w :: IntN w)) = op w-{-# INLINE unarySomeIntN #-}--unarySomeIntNR1 :: (forall n. (KnownNat n, 1 <= n) => IntN n -> IntN n) -> SomeIntN -> SomeIntN-unarySomeIntNR1 op (SomeIntN (w :: IntN w)) = SomeIntN $ op w-{-# INLINE unarySomeIntNR1 #-}--binSomeIntN :: (forall n. (KnownNat n, 1 <= n) => IntN n -> IntN n -> r) -> SomeIntN -> SomeIntN -> r-binSomeIntN op (SomeIntN (l :: IntN l)) (SomeIntN (r :: IntN r)) =-  case sameNat (Proxy @l) (Proxy @r) of-    Just Refl -> op l r-    Nothing -> throw BitwidthMismatch-{-# INLINE binSomeIntN #-}--binSomeIntNR1 :: (forall n. (KnownNat n, 1 <= n) => IntN n -> IntN n -> IntN n) -> SomeIntN -> SomeIntN -> SomeIntN-binSomeIntNR1 op (SomeIntN (l :: IntN l)) (SomeIntN (r :: IntN r)) =-  case sameNat (Proxy @l) (Proxy @r) of-    Just Refl -> SomeIntN $ op l r-    Nothing -> throw BitwidthMismatch-{-# INLINE binSomeIntNR1 #-}--binSomeIntNR2 :: (forall n. (KnownNat n, 1 <= n) => IntN n -> IntN n -> (IntN n, IntN n)) -> SomeIntN -> SomeIntN -> (SomeIntN, SomeIntN)-binSomeIntNR2 op (SomeIntN (l :: IntN l)) (SomeIntN (r :: IntN r)) =-  case sameNat (Proxy @l) (Proxy @r) of-    Just Refl ->-      case op l r of-        (a, b) -> (SomeIntN a, SomeIntN b)-    Nothing -> throw BitwidthMismatch-{-# INLINE binSomeIntNR2 #-}--instance Eq SomeIntN where-  SomeIntN (l :: IntN l) == SomeIntN (r :: IntN r) =-    case sameNat (Proxy @l) (Proxy @r) of-      Just Refl -> l == r-      Nothing -> False-  {-# INLINE (==) #-}-  SomeIntN (l :: IntN l) /= SomeIntN (r :: IntN r) =-    case sameNat (Proxy @l) (Proxy @r) of-      Just Refl -> l /= r-      Nothing -> True-  {-# INLINE (/=) #-}--instance Ord SomeIntN where-  (<=) = binSomeIntN (<=)-  {-# INLINE (<=) #-}-  (<) = binSomeIntN (<)-  {-# INLINE (<) #-}-  (>=) = binSomeIntN (>=)-  {-# INLINE (>=) #-}-  (>) = binSomeIntN (>)-  {-# INLINE (>) #-}-  max = binSomeIntNR1 max-  {-# INLINE max #-}-  min = binSomeIntNR1 min-  {-# INLINE min #-}-  compare = binSomeIntN compare-  {-# INLINE compare #-}--instance Lift SomeIntN where-  liftTyped (SomeIntN w) = [||SomeIntN w||]--instance Hashable SomeIntN where-  s `hashWithSalt` (SomeIntN (w :: IntN n)) = s `hashWithSalt` natVal (Proxy @n) `hashWithSalt` w--instance NFData SomeIntN where-  rnf (SomeIntN w) = rnf w--instance (KnownNat n, 1 <= n) => Show (IntN n) where-  show (IntN w) = if (bitwidth `mod` 4) == 0 then hexRepPre ++ hexRep else binRepPre ++ binRep-    where-      bitwidth = natVal (Proxy :: Proxy n)-      hexRepPre = "0x" ++ replicate (fromIntegral (bitwidth `div` 4) - length hexRep) '0'-      hexRep = showHex w ""-      binRepPre = "0b" ++ replicate (fromIntegral bitwidth - length binRep) '0'-      binRep = showIntAtBase 2 (\x -> if x == 0 then '0' else '1') w ""--instance (KnownNat n, 1 <= n) => Read (IntN n) where-  readPrec = readNumber convertInt <|> readBinary-  readListPrec = readListPrecDefault-  readList = readListDefault--instance Show SomeIntN where-  show (SomeIntN w) = show w--instance (KnownNat n, 1 <= n) => Bits (WordN n) where-  WordN a .&. WordN b = WordN (a .&. b)-  WordN a .|. WordN b = WordN (a .|. b)-  WordN a `xor` WordN b = WordN (a `xor` b)-  complement a = maxBound `xor` a--  -- shift use default implementation-  -- rotate use default implementation-  zeroBits = WordN 0-  bit i-    | i < 0 || i >= fromIntegral (natVal (Proxy :: Proxy n)) = zeroBits-    | otherwise = WordN (bit i)--  -- setBit use default implementation-  clearBit (WordN a) i = WordN (clearBit a i)--  -- complementBit use default implementation-  testBit (WordN a) = testBit a-  bitSizeMaybe = Just . finiteBitSize-  bitSize = finiteBitSize-  isSigned _ = False-  shiftL w i | i >= finiteBitSize w = 0-  shiftL (WordN a) i = WordN (a `shiftL` i) .&. maxBound--  -- unsafeShiftL use default implementation-  shiftR w i | i >= finiteBitSize w = 0-  shiftR (WordN a) i = WordN (a `shiftR` i)--  -- unsafeShiftR use default implementation-  rotateL a 0 = a-  rotateL (WordN a) k-    | k >= n = rotateL (WordN a) (k `mod` n)-    | otherwise = WordN $ l + h-    where-      n = fromIntegral $ natVal (Proxy :: Proxy n)-      s = n - k-      l = a `shiftR` s-      h = (a - (l `shiftL` s)) `shiftL` k-  rotateR a 0 = a-  rotateR (WordN a) k-    | k >= n = rotateR (WordN a) (k `mod` n)-    | otherwise = WordN $ l + h-    where-      n = fromIntegral $ natVal (Proxy :: Proxy n)-      s = n - k-      l = a `shiftR` k-      h = (a - (l `shiftL` k)) `shiftL` s-  popCount (WordN n) = popCount n--instance Bits SomeWordN where-  (.&.) = binSomeWordNR1 (.&.)-  (.|.) = binSomeWordNR1 (.|.)-  xor = binSomeWordNR1 xor-  complement = unarySomeWordNR1 complement-  shift s i = unarySomeWordNR1 (`shift` i) s-  rotate s i = unarySomeWordNR1 (`rotate` i) s-  zeroBits = error "zeroBits is not defined for SomeWordN as no bitwidth is known"-  bit = error "bit is not defined for SomeWordN as no bitwidth is known"-  setBit s i = unarySomeWordNR1 (`setBit` i) s-  clearBit s i = unarySomeWordNR1 (`clearBit` i) s-  complementBit s i = unarySomeWordNR1 (`complementBit` i) s-  testBit s i = unarySomeWordN (`testBit` i) s-  bitSizeMaybe = Just . finiteBitSize-  bitSize = finiteBitSize-  isSigned _ = False-  shiftL s i = unarySomeWordNR1 (`shiftL` i) s-  unsafeShiftL s i = unarySomeWordNR1 (`unsafeShiftL` i) s-  shiftR s i = unarySomeWordNR1 (`shiftR` i) s-  unsafeShiftR s i = unarySomeWordNR1 (`unsafeShiftR` i) s-  rotateL s i = unarySomeWordNR1 (`rotateL` i) s-  rotateR s i = unarySomeWordNR1 (`rotateR` i) s-  popCount = unarySomeWordN popCount--instance (KnownNat n, 1 <= n) => FiniteBits (WordN n) where-  finiteBitSize _ = fromIntegral (natVal (Proxy :: Proxy n))--instance FiniteBits SomeWordN where-  finiteBitSize (SomeWordN (n :: WordN n)) = fromIntegral $ natVal n-  countLeadingZeros = unarySomeWordN countLeadingZeros-  countTrailingZeros = unarySomeWordN countTrailingZeros--instance (KnownNat n, 1 <= n) => Bounded (WordN n) where-  maxBound = WordN ((1 `shiftL` fromIntegral (natVal (Proxy :: Proxy n))) - 1)-  minBound = WordN 0--instance (KnownNat n, 1 <= n) => Enum (WordN n) where-  succ x-    | x /= maxBound = x + 1-    | otherwise = succError $ "WordN " ++ show (natVal (Proxy :: Proxy n))-  pred x-    | x /= minBound = x - 1-    | otherwise = predError $ "WordN " ++ show (natVal (Proxy :: Proxy n))-  toEnum i-    | i >= 0 && toInteger i <= toInteger (maxBound :: WordN n) = WordN (toInteger i)-    | otherwise = toEnumError ("WordN " ++ show (natVal (Proxy :: Proxy n))) i (minBound :: WordN n, maxBound :: WordN n)-  fromEnum (WordN n) = fromEnum n-  enumFrom = boundedEnumFrom-  {-# INLINE enumFrom #-}-  enumFromThen = boundedEnumFromThen-  {-# INLINE enumFromThen #-}--instance Enum SomeWordN where-  toEnum = error "SomeWordN is not really a Enum type as the bit width is unknown, please consider using WordN instead"-  fromEnum = error "SomeWordN is not really a Enum type as the bit width is unknown, please consider using WordN instead"--instance (KnownNat n, 1 <= n) => Real (WordN n) where-  toRational (WordN n) = n % 1--instance Real SomeWordN where-  toRational = unarySomeWordN toRational--instance (KnownNat n, 1 <= n) => Integral (WordN n) where-  quot (WordN x) (WordN y) = WordN (x `quot` y)-  rem (WordN x) (WordN y) = WordN (x `rem` y)-  quotRem (WordN x) (WordN y) = case quotRem x y of-    (q, r) -> (WordN q, WordN r)-  div = quot-  mod = rem-  divMod = quotRem-  toInteger (WordN n) = n--instance Integral SomeWordN where-  quot = binSomeWordNR1 quot-  rem = binSomeWordNR1 rem-  quotRem = binSomeWordNR2 quotRem-  div = binSomeWordNR1 div-  mod = binSomeWordNR1 mod-  divMod = binSomeWordNR2 divMod-  toInteger = unarySomeWordN toInteger--instance (KnownNat n, 1 <= n) => Num (WordN n) where-  WordN x + WordN y = WordN (x + y) .&. maxBound-  WordN x * WordN y = WordN (x * y) .&. maxBound-  WordN x - WordN y-    | x >= y = WordN (x - y)-    | otherwise = WordN ((1 `shiftL` fromIntegral (natVal (Proxy :: Proxy n))) + x - y)-  negate (WordN 0) = WordN 0-  negate a = complement a + WordN 1-  abs x = x-  signum (WordN 0) = 0-  signum _ = 1-  fromInteger !x-    | x == 0 = WordN 0-    | x > 0 = WordN (x .&. unWordN (maxBound :: WordN n))-    | otherwise = -fromInteger (-x)--instance Num SomeWordN where-  (+) = binSomeWordNR1 (+)-  (-) = binSomeWordNR1 (-)-  (*) = binSomeWordNR1 (*)-  negate = unarySomeWordNR1 negate-  abs = unarySomeWordNR1 abs-  signum = unarySomeWordNR1 signum-  fromInteger = error "fromInteger is not defined for SomeWordN as no bitwidth is known"--instance (KnownNat n, 1 <= n) => QC.Arbitrary (WordN n) where-  arbitrary = QC.arbitrarySizedBoundedIntegral--  -- QC.shrinkIntegral assumes that 2 is representable by the number, which is-  -- not the case for 1-bit bit vector.-  shrink i-    | i == 0 = []-    | i == 1 = [0]-    | otherwise = QC.shrinkIntegral i--minusOneIntN :: forall proxy n. (KnownNat n) => proxy n -> IntN n-minusOneIntN _ = IntN (1 `shiftL` fromIntegral (natVal (Proxy :: Proxy n)) - 1)--instance (KnownNat n, 1 <= n) => Bits (IntN n) where-  IntN a .&. IntN b = IntN (a .&. b)-  IntN a .|. IntN b = IntN (a .|. b)-  IntN a `xor` IntN b = IntN (a `xor` b)-  complement a = minusOneIntN (Proxy :: Proxy n) `xor` a--  -- shift use default implementation-  -- rotate use default implementation-  zeroBits = IntN 0-  bit i = IntN (unWordN (bit i :: WordN n))--  -- setBit use default implementation-  clearBit (IntN a) i = IntN (clearBit a i)--  -- complementBit use default implementation-  testBit (IntN a) = testBit a-  bitSizeMaybe = Just . finiteBitSize-  bitSize = finiteBitSize-  isSigned _ = True--  shiftL (IntN a) i = IntN (unWordN $ (WordN a :: WordN n) `shiftL` i)--  -- unsafeShiftL use default implementation-  shiftR i 0 = i-  shiftR (IntN i) k-    | k >= n = if b then IntN (maxi - 1) else IntN 0-    | otherwise = if b then IntN (maxi - noi + (i `shiftR` k)) else IntN (i `shiftR` k)-    where-      b = testBit i (n - 1)-      n = fromIntegral $ natVal (Proxy :: Proxy n)-      maxi = (1 :: Integer) `shiftL` n-      noi = (1 :: Integer) `shiftL` (n - k)--  -- unsafeShiftR use default implementation-  rotateL (IntN i) k = IntN $ unWordN $ rotateL (WordN i :: WordN n) k-  rotateR (IntN i) k = IntN $ unWordN $ rotateR (WordN i :: WordN n) k-  popCount (IntN i) = popCount i--instance Bits SomeIntN where-  (.&.) = binSomeIntNR1 (.&.)-  (.|.) = binSomeIntNR1 (.|.)-  xor = binSomeIntNR1 xor-  complement = unarySomeIntNR1 complement-  shift s i = unarySomeIntNR1 (`shift` i) s-  rotate s i = unarySomeIntNR1 (`rotate` i) s-  zeroBits = error "zeroBits is not defined for SomeIntN as no bitwidth is known"-  bit = error "bit is not defined for SomeIntN as no bitwidth is known"-  setBit s i = unarySomeIntNR1 (`setBit` i) s-  clearBit s i = unarySomeIntNR1 (`clearBit` i) s-  complementBit s i = unarySomeIntNR1 (`complementBit` i) s-  testBit s i = unarySomeIntN (`testBit` i) s-  bitSizeMaybe = Just . finiteBitSize-  bitSize = finiteBitSize-  isSigned _ = False-  shiftL s i = unarySomeIntNR1 (`shiftL` i) s-  unsafeShiftL s i = unarySomeIntNR1 (`unsafeShiftL` i) s-  shiftR s i = unarySomeIntNR1 (`shiftR` i) s-  unsafeShiftR s i = unarySomeIntNR1 (`unsafeShiftR` i) s-  rotateL s i = unarySomeIntNR1 (`rotateL` i) s-  rotateR s i = unarySomeIntNR1 (`rotateR` i) s-  popCount = unarySomeIntN popCount--instance (KnownNat n, 1 <= n) => FiniteBits (IntN n) where-  finiteBitSize _ = fromIntegral (natVal (Proxy :: Proxy n))--instance FiniteBits SomeIntN where-  finiteBitSize (SomeIntN (n :: IntN n)) = fromIntegral $ natVal n-  countLeadingZeros = unarySomeIntN countLeadingZeros-  countTrailingZeros = unarySomeIntN countTrailingZeros--instance (KnownNat n, 1 <= n) => Bounded (IntN n) where-  maxBound = IntN (1 `shiftL` (fromIntegral (natVal (Proxy :: Proxy n)) - 1) - 1)-  minBound = maxBound + 1--instance (KnownNat n, 1 <= n) => Enum (IntN n) where-  succ x-    | x /= maxBound = x + 1-    | otherwise = succError $ "IntN " ++ show (natVal (Proxy :: Proxy n))-  pred x-    | x /= minBound = x - 1-    | otherwise = predError $ "IntN " ++ show (natVal (Proxy :: Proxy n))-  toEnum i-    | i >= fromIntegral (minBound :: IntN n) && i <= fromIntegral (maxBound :: IntN n) = fromIntegral i-    | otherwise = toEnumError ("IntN " ++ show (natVal (Proxy :: Proxy n))) i (minBound :: WordN n, maxBound :: WordN n)-  fromEnum = fromEnum . toInteger-  enumFrom = boundedEnumFrom-  {-# INLINE enumFrom #-}-  enumFromThen = boundedEnumFromThen-  {-# INLINE enumFromThen #-}--instance Enum SomeIntN where-  toEnum = error "SomeIntN is not really a Enum type as the bit width is unknown, please consider using IntN instead"-  fromEnum = error "SomeIntN is not really a Enum type as the bit width is unknown, please consider using IntN instead"--instance (KnownNat n, 1 <= n) => Real (IntN n) where-  toRational i = toInteger i % 1--instance Real SomeIntN where-  toRational = unarySomeIntN toRational--instance (KnownNat n, 1 <= n) => Integral (IntN n) where-  quot x y =-    if x == minBound && y == -1-      then throw Overflow-      else fromInteger (toInteger x `quot` toInteger y)-  rem x y = fromInteger (toInteger x `rem` toInteger y)-  quotRem x y =-    if x == minBound && y == -1-      then throw Overflow-      else case quotRem (toInteger x) (toInteger y) of-        (q, r) -> (fromInteger q, fromInteger r)-  div x y =-    if x == minBound && y == -1-      then throw Overflow-      else fromInteger (toInteger x `div` toInteger y)-  mod x y = fromInteger (toInteger x `mod` toInteger y)-  divMod x y =-    if x == minBound && y == -1-      then throw Overflow-      else case divMod (toInteger x) (toInteger y) of-        (q, r) -> (fromInteger q, fromInteger r)-  toInteger i@(IntN n) = case signum i of-    0 -> 0-    -1 ->-      let x = negate i-       in if signum x == -1 then -n else negate (toInteger x)-    1 -> n-    _ -> undefined--instance Integral SomeIntN where-  quot = binSomeIntNR1 quot-  rem = binSomeIntNR1 rem-  quotRem = binSomeIntNR2 quotRem-  div = binSomeIntNR1 div-  mod = binSomeIntNR1 mod-  divMod = binSomeIntNR2 divMod-  toInteger = unarySomeIntN toInteger--instance (KnownNat n, 1 <= n) => Num (IntN n) where-  IntN x + IntN y = IntN (x + y) .&. minusOneIntN (Proxy :: Proxy n)-  IntN x * IntN y = IntN (x * y) .&. minusOneIntN (Proxy :: Proxy n)-  IntN x - IntN y-    | x >= y = IntN (x - y)-    | otherwise = IntN ((1 `shiftL` fromIntegral (natVal (Proxy :: Proxy n))) + x - y)-  negate (IntN 0) = IntN 0-  negate a = complement a + IntN 1-  abs x = if testBit x (fromIntegral $ natVal (Proxy :: Proxy n) - 1) then negate x else x-  signum (IntN 0) = IntN 0-  signum i = if testBit i (fromIntegral $ natVal (Proxy :: Proxy n) - 1) then -1 else 1-  fromInteger !x = IntN $ if v >= 0 then v else (1 `shiftL` n) + v-    where-      v = unWordN (fromInteger (x + maxn) :: WordN n) - maxn-      n = fromIntegral (natVal (Proxy :: Proxy n))-      maxn = 1 `shiftL` (n - 1) - 1--instance Num SomeIntN where-  (+) = binSomeIntNR1 (+)-  (-) = binSomeIntNR1 (-)-  (*) = binSomeIntNR1 (*)-  negate = unarySomeIntNR1 negate-  abs = unarySomeIntNR1 abs-  signum = unarySomeIntNR1 signum-  fromInteger = error "fromInteger is not defined for SomeIntN as no bitwidth is known"--instance (KnownNat n, 1 <= n) => Ord (IntN n) where-  IntN a <= IntN b-    | as && not bs = True-    | not as && bs = False-    | otherwise = a <= b-    where-      n = fromIntegral (natVal (Proxy :: Proxy n))-      as = testBit a (n - 1)-      bs = testBit b (n - 1)--instance (KnownNat n, 1 <= n) => QC.Arbitrary (IntN n) where-  arbitrary = QC.arbitrarySizedBoundedIntegral--  -- QC.shrinkIntegral assumes that 2 is representable by the number, which is-  -- not the case for 1-bit bit vector.-  shrink i-    | i == 0 = []-    | i == 1 = [0]-    | otherwise = QC.shrinkIntegral i--instance SizedBV WordN where-  sizedBVConcat :: forall l r. (KnownNat l, KnownNat r, 1 <= l, 1 <= r) => WordN l -> WordN r -> WordN (l + r)-  sizedBVConcat (WordN a) (WordN b) = WordN ((a `shiftL` fromIntegral (natVal (Proxy :: Proxy r))) .|. b)-  sizedBVZext _ (WordN v) = WordN v-  sizedBVSext :: forall l r proxy. (KnownNat l, KnownNat r, 1 <= l, KnownNat r, l <= r) => proxy r -> WordN l -> WordN r-  sizedBVSext pr (WordN v) = if s then WordN (maxi - noi + v) else WordN v-    where-      r = fromIntegral $ natVal pr-      l = fromIntegral $ natVal (Proxy :: Proxy l)-      s = testBit v (l - 1)-      maxi = (1 :: Integer) `shiftL` r-      noi = (1 :: Integer) `shiftL` l-  sizedBVExt = sizedBVZext-  sizedBVSelect ::-    forall n ix w p q.-    (KnownNat n, KnownNat ix, KnownNat w, 1 <= n, 1 <= w, ix + w <= n) =>-    p ix ->-    q w ->-    WordN n ->-    WordN w-  sizedBVSelect pix pw (WordN v) = WordN ((v `shiftR` ix) .&. mask)-    where-      ix = fromIntegral $ natVal pix-      w = fromIntegral $ natVal pw-      mask = (1 `shiftL` w) - 1--instance SizedBV IntN where-  sizedBVConcat :: forall l r. (KnownNat l, KnownNat r, 1 <= l, 1 <= r) => IntN l -> IntN r -> IntN (l + r)-  sizedBVConcat (IntN a) (IntN b) = IntN $ unWordN $ sizedBVConcat (WordN a :: WordN l) (WordN b :: WordN r)-  sizedBVZext _ (IntN v) = IntN v-  sizedBVSext :: forall l r proxy. (KnownNat l, KnownNat r, 1 <= l, KnownNat r, l <= r) => proxy r -> IntN l -> IntN r-  sizedBVSext pr (IntN v) = IntN $ unWordN $ sizedBVSext pr (WordN v :: WordN l)-  sizedBVExt = sizedBVSext-  sizedBVSelect ::-    forall n ix w p q.-    (KnownNat n, KnownNat ix, KnownNat w, 1 <= n, 1 <= w, ix + w <= n) =>-    p ix ->-    q w ->-    IntN n ->-    IntN w-  sizedBVSelect pix pw (IntN v) = IntN $ unWordN $ sizedBVSelect pix pw (WordN v :: WordN n)--instance BV SomeWordN where-  bvConcat (SomeWordN (a :: WordN l)) (SomeWordN (b :: WordN r)) =-    case (leqAddPos (Proxy @l) (Proxy @r), knownAdd @l @r KnownProof KnownProof) of-      (LeqProof, KnownProof) ->-        SomeWordN $ sizedBVConcat a b-  {-# INLINE bvConcat #-}-  bvZext l (SomeWordN (a :: WordN n))-    | l < n = error "bvZext: trying to zero extend a value to a smaller size"-    | otherwise = res (Proxy @n)-    where-      n = fromIntegral $ natVal (Proxy @n)-      res :: forall (l :: Nat). Proxy l -> SomeWordN-      res p =-        case (unsafeKnownProof @l (fromIntegral l), unsafeLeqProof @1 @l, unsafeLeqProof @n @l) of-          (KnownProof, LeqProof, LeqProof) -> SomeWordN $ sizedBVZext p a-  bvSext l (SomeWordN (a :: WordN n))-    | l < n = error "bvSext: trying to zero extend a value to a smaller size"-    | otherwise = res (Proxy @n)-    where-      n = fromIntegral $ natVal (Proxy @n)-      res :: forall (l :: Nat). Proxy l -> SomeWordN-      res p =-        case (unsafeKnownProof @l (fromIntegral l), unsafeLeqProof @1 @l, unsafeLeqProof @n @l) of-          (KnownProof, LeqProof, LeqProof) -> SomeWordN $ sizedBVSext p a-  bvExt = bvZext-  bvSelect ix w (SomeWordN (a :: WordN n))-    | ix + w > n = error "bvSelect: trying to select a bitvector outside the bounds of the input"-    | w == 0 = error "bvSelect: trying to select a bitvector of size 0"-    | otherwise = res (Proxy @n) (Proxy @n)-    where-      n = fromIntegral $ natVal (Proxy @n)-      res :: forall (w :: Nat) (ix :: Nat). Proxy w -> Proxy ix -> SomeWordN-      res _ _ =-        case ( unsafeKnownProof @ix (fromIntegral ix),-               unsafeKnownProof @w (fromIntegral w),-               unsafeLeqProof @1 @w,-               unsafeLeqProof @(ix + w) @n-             ) of-          (KnownProof, KnownProof, LeqProof, LeqProof) ->-            SomeWordN $ sizedBVSelect (Proxy @ix) (Proxy @w) a--instance BV SomeIntN where-  bvConcat l r = toSigned $ bvConcat (toUnsigned l) (toUnsigned r)-  {-# INLINE bvConcat #-}-  bvZext l = toSigned . bvZext l . toUnsigned-  {-# INLINE bvZext #-}-  bvSext l = toSigned . bvSext l . toUnsigned-  {-# INLINE bvSext #-}-  bvExt l = toSigned . bvExt l . toUnsigned-  {-# INLINE bvExt #-}-  bvSelect ix w = toSigned . bvSelect ix w . toUnsigned-  {-# INLINE bvSelect #-}--instance (KnownNat n, 1 <= n) => SignConversion (WordN n) (IntN n) where-  toSigned (WordN i) = IntN i-  toUnsigned (IntN i) = WordN i--instance SignConversion SomeWordN SomeIntN where-  toSigned (SomeWordN i) = SomeIntN $ toSigned i-  toUnsigned (SomeIntN i) = SomeWordN $ toUnsigned i--deriving via-  (DefaultFiniteBitsSymShift (IntN n))-  instance-    (KnownNat n, 1 <= n) => SymShift (IntN n)--deriving via-  (DefaultFiniteBitsSymShift (WordN n))-  instance-    (KnownNat n, 1 <= n) => SymShift (WordN n)--deriving via-  (DefaultFiniteBitsSymRotate (IntN n))-  instance-    (KnownNat n, 1 <= n) => SymRotate (IntN n)--deriving via-  (DefaultFiniteBitsSymRotate (WordN n))-  instance-    (KnownNat n, 1 <= n) => SymRotate (WordN n)
− src/Grisette/Core/Data/Class/BitVector.hs 
@@ -1,234 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeOperators #-}---- |--- Module      :   Grisette.Core.Data.Class.BitVector--- 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.Core.Data.Class.BitVector-  ( -- * Bit vector operations-    BV (..),-    bvExtract,-    SizedBV (..),-    sizedBVExtract,-  )-where--import Data.Proxy (Proxy (Proxy))-import GHC.TypeNats (KnownNat, type (+), type (-), type (<=))-import Grisette.Utils.Parameterized-  ( KnownProof (KnownProof),-    LeqProof (LeqProof),-    addNat,-    hasRepr,-    natRepr,-    subNat,-    unsafeLeqProof,-  )---- $setup--- >>> import Grisette.Core--- >>> import Grisette.IR.SymPrim--- >>> import Grisette.Utils.Parameterized--- >>> :set -XDataKinds--- >>> :set -XBinaryLiterals--- >>> :set -XFlexibleContexts--- >>> :set -XFlexibleInstances--- >>> :set -XFunctionalDependencies---- | Bit vector operations. Including concatenation ('bvConcat'),--- extension ('bvZext', 'bvSext', 'bvExt'), and selection--- ('bvSelect').-class BV bv where-  -- | Concatenation of two bit vectors.-  ---  -- >>> bvConcat (SomeSymWordN (0b101 :: SymWordN 3)) (SomeSymWordN (0b010 :: SymWordN 3))-  -- 0b101010-  bvConcat :: bv -> bv -> bv--  -- | Zero extension of a bit vector.-  ---  -- >>> bvZext 6 (SomeSymWordN (0b101 :: SymWordN 3))-  -- 0b000101-  bvZext ::-    -- | Desired output length-    Int ->-    -- | Bit vector to extend-    bv ->-    bv--  -- | Sign extension of a bit vector.-  ---  -- >>> bvSext 6 (SomeSymWordN (0b101 :: SymWordN 3))-  -- 0b111101-  bvSext ::-    -- | Desired output length-    Int ->-    -- | Bit vector to extend-    bv ->-    bv--  -- | Extension of a bit vector.-  -- Signedness is determined by the input bit vector type.-  ---  -- >>> bvExt 6 (SomeSymIntN (0b101 :: SymIntN 3))-  -- 0b111101-  -- >>> bvExt 6 (SomeSymIntN (0b001 :: SymIntN 3))-  -- 0b000001-  -- >>> bvExt 6 (SomeSymWordN (0b101 :: SymWordN 3))-  -- 0b000101-  -- >>> bvExt 6 (SomeSymWordN (0b001 :: SymWordN 3))-  -- 0b000001-  bvExt ::-    -- | Desired output length-    Int ->-    -- | Bit vector to extend-    bv ->-    bv--  -- | Slicing out a smaller bit vector from a larger one,-  -- selecting a slice with width @w@ starting from index @ix@.-  ---  -- The least significant bit is indexed as 0.-  ---  -- >>> bvSelect 1 3 (SomeSymIntN (0b001010 :: SymIntN 6))-  -- 0b101-  bvSelect ::-    -- | Index of the least significant bit of the slice-    Int ->-    -- | Desired output width, @ix + w <= n@ must hold where @n@ is-    -- the size of the input bit vector-    Int ->-    -- | Bit vector to select from-    bv ->-    bv---- | Slicing out a smaller bit vector from a larger one, extract a slice from--- bit @i@ down to @j@.------ The least significant bit is indexed as 0.------ >>> bvExtract 4 2 (SomeSymIntN (0b010100 :: SymIntN 6))--- 0b101-bvExtract ::-  (BV bv) =>-  -- | The start position to extract from, @i < n@ must hold where @n@ is-  -- the size of the output bit vector-  Int ->-  -- | The end position to extract from, @j <= i@ must hold-  Int ->-  -- | Bit vector to extract from-  bv ->-  bv-bvExtract i j = bvSelect j (i - j + 1)-{-# INLINE bvExtract #-}---- | Sized bit vector operations. Including concatenation ('sizedBVConcat'),--- extension ('sizedBVZext', 'sizedBVSext', 'sizedBVExt'), and selection--- ('sizedBVSelect').-class SizedBV bv where-  -- | Concatenation of two bit vectors.-  ---  -- >>> sizedBVConcat (0b101 :: SymIntN 3) (0b010 :: SymIntN 3)-  -- 0b101010-  sizedBVConcat :: (KnownNat l, KnownNat r, 1 <= l, 1 <= r) => bv l -> bv r -> bv (l + r)--  -- | Zero extension of a bit vector.-  ---  -- >>> sizedBVZext (Proxy @6) (0b101 :: SymIntN 3)-  -- 0b000101-  sizedBVZext ::-    (KnownNat l, KnownNat r, 1 <= l, KnownNat r, l <= r) =>-    -- | Desired output width-    proxy r ->-    -- | Bit vector to extend-    bv l ->-    bv r--  -- | Signed extension of a bit vector.-  ---  -- >>> sizedBVSext (Proxy @6) (0b101 :: SymIntN 3)-  -- 0b111101-  sizedBVSext ::-    (KnownNat l, KnownNat r, 1 <= l, KnownNat r, l <= r) =>-    -- | Desired output width-    proxy r ->-    -- | Bit vector to extend-    bv l ->-    bv r--  -- | Extension of a bit vector.-  -- Signedness is determined by the input bit vector type.-  ---  -- >>> sizedBVExt (Proxy @6) (0b101 :: SymIntN 3)-  -- 0b111101-  -- >>> sizedBVExt (Proxy @6) (0b001 :: SymIntN 3)-  -- 0b000001-  -- >>> sizedBVExt (Proxy @6) (0b101 :: SymWordN 3)-  -- 0b000101-  -- >>> sizedBVExt (Proxy @6) (0b001 :: SymWordN 3)-  -- 0b000001-  sizedBVExt ::-    (KnownNat l, KnownNat r, 1 <= l, KnownNat r, l <= r) =>-    -- | Desired output width-    proxy r ->-    -- | Bit vector to extend-    bv l ->-    bv r--  -- | Slicing out a smaller bit vector from a larger one, selecting a slice with-  -- width @w@ starting from index @ix@.-  ---  -- The least significant bit is indexed as 0.-  ---  -- >>> sizedBVSelect (Proxy @2) (Proxy @3) (con 0b010100 :: SymIntN 6)-  -- 0b101-  sizedBVSelect ::-    (KnownNat n, KnownNat ix, KnownNat w, 1 <= n, 1 <= w, ix + w <= n) =>-    -- | Index of the least significant bit of the slice-    p ix ->-    -- | Desired output width, @ix + w <= n@ must hold where @n@ is-    -- the size of the input bit vector-    q w ->-    -- | Bit vector to select from-    bv n ->-    bv w---- | Slicing out a smaller bit vector from a larger one, extract a slice from--- bit @i@ down to @j@.------ The least significant bit is indexed as 0.------ >>> sizedBVExtract (Proxy @4) (Proxy @2) (con 0b010100 :: SymIntN 6)--- 0b101-sizedBVExtract ::-  forall p i q j n bv.-  (SizedBV bv, KnownNat n, KnownNat i, KnownNat j, 1 <= n, i + 1 <= n, j <= i) =>-  -- | The start position to extract from, @i < n@ must hold where @n@ is-  -- the size of the output bit vector-  p i ->-  -- | The end position to extract from, @j <= i@ must hold-  q j ->-  -- | Bit vector to extract from-  bv n ->-  bv (i - j + 1)-sizedBVExtract _ _ =-  case ( hasRepr (addNat (subNat (natRepr @i) (natRepr @j)) (natRepr @1)),-         unsafeLeqProof @(j + (i - j + 1)) @n,-         unsafeLeqProof @1 @(i - j + 1)-       ) of-    (KnownProof, LeqProof, LeqProof) ->-      sizedBVSelect (Proxy @j) (Proxy @(i - j + 1))-{-# INLINE sizedBVExtract #-}
− src/Grisette/Core/Data/Class/CEGISSolver.hs 
@@ -1,614 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingVia #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE Trustworthy #-}---- |--- Module      :   Grisette.Core.Data.Class.CEGISSolver--- 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.Core.Data.Class.CEGISSolver-  ( -- * Note for the examples--    ----    -- | The examples assumes that the [z3](https://github.com/Z3Prover/z3)-    -- solver is available in @PATH@.--    -- * Generic CEGIS interface-    SynthesisConstraintFun,-    VerifierResult (..),-    StatefulVerifierFun,-    CEGISResult (..),-    genericCEGIS,--    -- * CEGIS interfaces with pre/post conditions-    CEGISCondition (..),-    cegisPostCond,-    cegisPrePost,-    cegisMultiInputs,-    cegis,-    cegisExcept,-    cegisExceptStdVC,-    cegisExceptVC,-    cegisExceptMultiInputs,-    cegisExceptStdVCMultiInputs,-    cegisExceptVCMultiInputs,-    cegisForAll,-    cegisForAllExcept,-    cegisForAllExceptStdVC,-    cegisForAllExceptVC,-  )-where--import Control.Monad (foldM, unless)-import Data.List (partition)-import GHC.Generics (Generic)-import Generics.Deriving (Default (Default))-import Grisette.Core.Control.Exception-  ( VerificationConditions (AssertionViolation, AssumptionViolation),-  )-import Grisette.Core.Data.Class.EvaluateSym (EvaluateSym, evaluateSym)-import Grisette.Core.Data.Class.ExtractSymbolics-  ( ExtractSymbolics,-    extractSymbolics,-  )-import Grisette.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.&&)))-import Grisette.Core.Data.Class.Mergeable (Mergeable)-import Grisette.Core.Data.Class.ModelOps-  ( ModelOps (exact, exceptFor),-    SymbolSetOps (isEmptySet),-  )-import Grisette.Core.Data.Class.SEq (SEq)-import Grisette.Core.Data.Class.SimpleMergeable-  ( SimpleMergeable,-    UnionPrjOp,-    simpleMerge,-  )-import Grisette.Core.Data.Class.Solvable (Solvable (con))-import Grisette.Core.Data.Class.Solver-  ( ConfigurableSolver,-    Solver (solverSolve),-    SolvingFailure (Unsat),-    UnionWithExcept (extractUnionExcept),-    solve,-    withSolver,-  )-import Grisette.IR.SymPrim.Data.Prim.Model (Model)-import Grisette.IR.SymPrim.Data.SymPrim (SymBool)---- $setup--- >>> import Grisette.Core--- >>> import Grisette.Lib.Base--- >>> import Grisette.IR.SymPrim--- >>> import Grisette.Backend.SBV---- | Synthesis constraint function.------ The first argument is the iteration number, for angelic programs, you can use--- it to instantiate the angelic variables in the program.------ The second argument is the counter-example generated by the verifier.------ The synthesizer will try to find a program that is true for all the synthesis--- constraints.-type SynthesisConstraintFun input = Int -> input -> IO SymBool---- | The result of the verifier.-data VerifierResult input exception-  = CEGISVerifierFoundCex input-  | CEGISVerifierNoCex-  | CEGISVerifierException exception---- | The verifier function.------ The first argument is the state of the verifier.------ The second argument is the candidate model proposed by the synthesizer.-type StatefulVerifierFun state input exception =-  state -> Model -> IO (state, VerifierResult input exception)---- | The result of the CEGIS procedure.-data CEGISResult exception-  = CEGISSuccess Model-  | CEGISVerifierFailure exception-  | CEGISSolverFailure SolvingFailure-  deriving (Show)---- | Generic CEGIS procedure.------ The CEGIS procedure will try to find a model that satisfies the initial--- synthesis constraint, and satisfies all the inputs generated by the verifier.-genericCEGIS ::-  (ConfigurableSolver config handle) =>-  -- | Configuration of the solver.-  config ->-  -- | The initial synthesis constraint.-  SymBool ->-  -- | The synthesis constraint function.-  SynthesisConstraintFun input ->-  -- | The initial state of the verifier.-  verifierState ->-  -- | The verifier function.-  StatefulVerifierFun verifierState input exception ->-  IO ([input], CEGISResult exception)-genericCEGIS config initConstr synthConstr initVerifierState verifier =-  withSolver config $ \solver -> do-    firstResult <- solverSolve solver initConstr-    case firstResult of-      Left err -> return ([], CEGISSolverFailure err)-      Right model -> go solver model 0 initVerifierState-  where-    go solver prevModel iterNum verifierState = do-      (newVerifierState, verifierResult) <--        verifier verifierState prevModel-      case verifierResult of-        CEGISVerifierFoundCex cex -> do-          newResult <- solverSolve solver =<< synthConstr iterNum cex-          case newResult of-            Left err -> return ([], CEGISSolverFailure err)-            Right model -> do-              (cexes, result) <- go solver model (iterNum + 1) newVerifierState-              return (cex : cexes, result)-        CEGISVerifierNoCex -> return ([], CEGISSuccess prevModel)-        CEGISVerifierException exception ->-          return ([], CEGISVerifierFailure exception)--data CEGISMultiInputsState input = CEGISMultiInputsState-  { _cegisMultiInputsRemainingSymInputs :: [input],-    _cegisMultiInputsPre :: SymBool,-    _cegisMultiInputsPost :: SymBool-  }---- | The condition for CEGIS to solve.------ The first argument is the pre-condition, and the second argument is the--- post-condition.------ The CEGIS procedures would try to find a model for the formula------ \[---   \forall P. (\exists I. \mathrm{pre}(P, I)) \wedge (\forall I. \mathrm{pre}(P, I)\implies \mathrm{post}(P, I))--- \]------ In program synthesis tasks, \(P\) is the symbolic constants in the symbolic--- program, and \(I\) is the input. The pre-condition is used to restrict the--- search space of the program. The procedure would only return programs that--- meets the pre-conditions on every possible inputs, and there are at least--- one possible input. The post-condition is used to specify the desired program--- behaviors.-data CEGISCondition = CEGISCondition SymBool SymBool-  deriving (Generic)-  deriving (EvaluateSym) 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--- allowed.-cegisPostCond :: SymBool -> CEGISCondition-cegisPostCond = CEGISCondition (con True)---- | Construct a CEGIS condition with both pre- and post-conditions.-cegisPrePost :: SymBool -> SymBool -> CEGISCondition-cegisPrePost = CEGISCondition--deriving via (Default CEGISCondition) instance Mergeable CEGISCondition--deriving via (Default CEGISCondition) instance SimpleMergeable CEGISCondition---- |--- CEGIS with multiple (possibly symbolic) inputs. Solves the following formula--- (see 'CEGISCondition' for details).------ \[---   \forall P. (\exists I\in\mathrm{inputs}. \mathrm{pre}(P, I)) \wedge (\forall I\in\mathrm{inputs}. \mathrm{pre}(P, I)\implies \mathrm{post}(P, I))--- \]------ For simpler queries, where the inputs are representable by a single--- symbolic value, you may want to use 'cegis' or 'cegisExcept' instead.--- We have an example for the 'cegis' call.-cegisMultiInputs ::-  ( EvaluateSym input,-    ExtractSymbolics input,-    ConfigurableSolver config handle-  ) =>-  config ->-  [input] ->-  (input -> CEGISCondition) ->-  IO ([input], CEGISResult SolvingFailure)-cegisMultiInputs config inputs toCEGISCondition = do-  initConstr <- cexesAssertFun conInputs-  genericCEGIS-    config-    initConstr-    synthConstr-    (CEGISMultiInputsState symInputs (con True) (con True))-    verifier-  where-    (conInputs, symInputs) = partition (isEmptySet . extractSymbolics) inputs-    forallSymbols = extractSymbolics symInputs-    cexAssertFun input = do-      unless (isEmptySet (extractSymbolics input)) $ error "BUG"-      CEGISCondition pre post <- return $ toCEGISCondition input-      return $ pre .&& post-    cexesAssertFun = foldM (\acc x -> (acc .&&) <$> cexAssertFun x) (con True)-    synthConstr _ = cexAssertFun-    verifier state@(CEGISMultiInputsState [] _ _) _ =-      return (state, CEGISVerifierNoCex)-    verifier-      (CEGISMultiInputsState (nextSymInput : symInputs) pre post)-      candidate = do-        CEGISCondition nextPre nextPost <--          return $ toCEGISCondition nextSymInput-        let newPre = pre .&& nextPre-        let newPost = post .&& nextPost-        let evaluated =-              evaluateSym False (exceptFor forallSymbols candidate) $-                newPre .&& symNot newPost-        r <- solve config evaluated-        case r of-          Left Unsat ->-            verifier (CEGISMultiInputsState symInputs newPre newPost) candidate-          Left err ->-            return-              ( CEGISMultiInputsState [] newPre newPost,-                CEGISVerifierException err-              )-          Right model ->-            return-              ( CEGISMultiInputsState (nextSymInput : symInputs) newPre newPost,-                CEGISVerifierFoundCex $-                  evaluateSym False (exact forallSymbols model) nextSymInput-              )---- |--- CEGIS with a single symbolic input to represent a set of inputs.------ The following example tries to find the value of @c@ such that for all--- positive @x@, @x * c < 0 && c > -2@. The @c .> -2@ clause is used to make--- the solution unique.------ >>> :set -XOverloadedStrings--- >>> let [x,c] = ["x","c"] :: [SymInteger]--- >>> cegis (precise 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-  ) =>-  -- | The configuration of the solver-  config ->-  -- | Initial symbolic inputs. The solver will try to find a-  -- program that works on all the inputs representable by it (see-  -- 'CEGISCondition').-  inputs ->-  -- | The condition for the solver to solve. All the-  -- symbolic constants that are not in the inputs will-  -- be considered as part of the symbolic program.-  (inputs -> CEGISCondition) ->-  -- | The counter-examples generated-  -- during the CEGIS loop, and the-  -- model found by the solver.-  IO ([inputs], CEGISResult SolvingFailure)-cegis config inputs = cegisMultiInputs config [inputs]---- |--- CEGIS for symbolic programs with error handling, using multiple (possibly--- symbolic) inputs to represent a set of inputs.-cegisExceptMultiInputs ::-  ( ConfigurableSolver config handle,-    EvaluateSym inputs,-    ExtractSymbolics inputs,-    UnionWithExcept t u e v,-    UnionPrjOp u,-    Monad u-  ) =>-  config ->-  [inputs] ->-  (Either e v -> CEGISCondition) ->-  (inputs -> t) ->-  IO ([inputs], CEGISResult SolvingFailure)-cegisExceptMultiInputs config cexes interpretFun f =-  cegisMultiInputs-    config-    cexes-    (simpleMerge . (interpretFun <$>) . extractUnionExcept . f)---- |--- CEGIS for symbolic programs with error handling, using multiple (possibly--- symbolic) inputs to represent a set of inputs.------ The errors should be translated to assertion or assumption violations.-cegisExceptVCMultiInputs ::-  ( ConfigurableSolver config handle,-    EvaluateSym inputs,-    ExtractSymbolics inputs,-    UnionWithExcept t u e v,-    UnionPrjOp u,-    Monad u-  ) =>-  config ->-  [inputs] ->-  (Either e v -> u (Either VerificationConditions ())) ->-  (inputs -> t) ->-  IO ([inputs], CEGISResult SolvingFailure)-cegisExceptVCMultiInputs config cexes interpretFun f =-  cegisMultiInputs-    config-    cexes-    ( \v ->-        simpleMerge-          ( ( \case-                Left AssumptionViolation -> cegisPrePost (con False) (con True)-                Left AssertionViolation -> cegisPostCond (con False)-                _ -> cegisPostCond (con True)-            )-              <$> (extractUnionExcept (f v) >>= interpretFun)-          )-    )---- |--- 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 '()'.------ This function translates assumption violations to failed pre-conditions,--- and translates assertion violations to failed post-conditions.--- The '()' result will not fail any conditions.-cegisExceptStdVCMultiInputs ::-  ( ConfigurableSolver config handle,-    EvaluateSym inputs,-    ExtractSymbolics inputs,-    UnionWithExcept t u VerificationConditions (),-    UnionPrjOp u,-    Monad u-  ) =>-  config ->-  [inputs] ->-  (inputs -> t) ->-  IO ([inputs], CEGISResult SolvingFailure)-cegisExceptStdVCMultiInputs config cexes =-  cegisExceptVCMultiInputs config cexes return---- |--- CEGIS for symbolic programs with error handling, using a single symbolic--- input to represent a set of inputs.------ 'cegisExcept' is particularly useful when custom error types are used.--- With 'cegisExcept', you define how the errors are interpreted to the--- CEGIS conditions after the symbolic evaluation. This could increase the--- readability and modularity of the code.------ 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--- the solution unique.------ >>> :set -XOverloadedStrings--- >>> let [x,c] = ["x","c"] :: [SymInteger]--- >>> import Control.Monad.Except--- >>> :{---   res :: SymInteger -> ExceptT VerificationConditions UnionM ()---   res x = do---     symAssume $ x .> 0---     symAssert $ x * c .< 0---     symAssert $ c .> -2--- :}------ >>> :{---   translation (Left AssumptionViolation) = cegisPrePost (con False) (con True)---   translation (Left AssertionViolation) = cegisPostCond (con False)---   translation _ = cegisPostCond (con True)--- :}------ >>> cegisExcept (precise z3) x translation res--- ([...],CEGISSuccess (Model {c -> -1 :: Integer}))-cegisExcept ::-  ( UnionWithExcept t u e v,-    UnionPrjOp u,-    Functor u,-    EvaluateSym inputs,-    ExtractSymbolics inputs,-    ConfigurableSolver config handle,-    SEq inputs-  ) =>-  config ->-  inputs ->-  (Either e v -> CEGISCondition) ->-  (inputs -> t) ->-  IO ([inputs], CEGISResult SolvingFailure)-cegisExcept config inputs f v =-  cegis config inputs $ \i -> simpleMerge $ f <$> extractUnionExcept (v i)---- |--- CEGIS for symbolic programs with error handling, using a single symbolic--- input to represent a set of inputs.------ The errors should be translated to assertion or assumption violations.-cegisExceptVC ::-  ( UnionWithExcept t u e v,-    UnionPrjOp u,-    Monad u,-    EvaluateSym inputs,-    ExtractSymbolics inputs,-    ConfigurableSolver config handle,-    SEq inputs-  ) =>-  config ->-  inputs ->-  (Either e v -> u (Either VerificationConditions ())) ->-  (inputs -> t) ->-  IO ([inputs], CEGISResult SolvingFailure)-cegisExceptVC config inputs f v = do-  cegis config inputs $ \i ->-    simpleMerge $-      ( \case-          Left AssumptionViolation -> cegisPrePost (con False) (con True)-          Left AssertionViolation -> cegisPostCond (con False)-          _ -> cegisPostCond (con True)-      )-        <$> (extractUnionExcept (v i) >>= f)---- |--- 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 '()'.------ 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 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--- the solution unique.------ >>> :set -XOverloadedStrings--- >>> let [x,c] = ["x","c"] :: [SymInteger]--- >>> import Control.Monad.Except--- >>> :{---   res :: SymInteger -> ExceptT VerificationConditions UnionM ()---   res x = do---     symAssume $ x .> 0---     symAssert $ x * c .< 0---     symAssert $ c .> -2--- :}------ >>> cegisExceptStdVC (precise z3) x res--- ([...],CEGISSuccess (Model {c -> -1 :: Integer}))-cegisExceptStdVC ::-  ( UnionWithExcept t u VerificationConditions (),-    UnionPrjOp u,-    Monad u,-    EvaluateSym inputs,-    ExtractSymbolics inputs,-    ConfigurableSolver config handle,-    SEq inputs-  ) =>-  config ->-  inputs ->-  (inputs -> t) ->-  IO ([inputs], CEGISResult SolvingFailure)-cegisExceptStdVC config inputs = cegisExceptVC config inputs return---- |--- CEGIS with a single symbolic input to represent a set of inputs.------ The following example tries to find the value of @c@ such that for all--- positive @x@, @x * c < 0 && c > -2@. The @c .> -2@ clause is used to make--- the solution unique.------ >>> :set -XOverloadedStrings--- >>> let [x,c] = ["x","c"] :: [SymInteger]--- >>> cegisForAll (precise z3) x $ cegisPrePost (x .> 0) (x * c .< 0 .&& c .> -2)--- (...,CEGISSuccess (Model {c -> -1 :: Integer}))-cegisForAll ::-  ( ExtractSymbolics forallInput,-    ConfigurableSolver config handle-  ) =>-  config ->-  -- | A symbolic value. All the symbolic constants in the value are treated as-  -- for-all variables.-  forallInput ->-  CEGISCondition ->-  -- | First output are the counter-examples for all the for-all variables, and-  -- the second output is the model for all other variables if CEGIS succeeds.-  IO ([Model], CEGISResult SolvingFailure)-cegisForAll config input (CEGISCondition pre post) = do-  (models, result) <- genericCEGIS config phi synthConstr () verifier-  let exactResult = case result of-        CEGISSuccess model -> CEGISSuccess $ exceptFor forallSymbols model-        _ -> result-  return (models, exactResult)-  where-    phi = pre .&& post-    negphi = pre .&& symNot post-    forallSymbols = extractSymbolics input-    synthConstr _ model = return $ evaluateSym False model phi-    verifier () candidate = do-      let evaluated =-            evaluateSym False (exceptFor forallSymbols candidate) negphi-      r <- solve config evaluated-      case r of-        Left Unsat -> return ((), CEGISVerifierNoCex)-        Left err -> return ((), CEGISVerifierException err)-        Right model ->-          return ((), CEGISVerifierFoundCex $ exact forallSymbols model)---- |--- CEGIS for symbolic programs with error handling, with a forall variable.------ See 'cegisForAll' and 'cegisExcept'.-cegisForAllExcept ::-  ( UnionWithExcept t u e v,-    UnionPrjOp u,-    Functor u,-    EvaluateSym inputs,-    ExtractSymbolics inputs,-    ConfigurableSolver config handle,-    SEq inputs-  ) =>-  config ->-  inputs ->-  (Either e v -> CEGISCondition) ->-  t ->-  IO ([Model], CEGISResult SolvingFailure)-cegisForAllExcept config inputs f v =-  cegisForAll config inputs $ simpleMerge $ f <$> extractUnionExcept v---- |--- CEGIS for symbolic programs with error handling, with a forall variable.------ See 'cegisForAll' and 'cegisExceptVC'.-cegisForAllExceptVC ::-  ( UnionWithExcept t u e v,-    UnionPrjOp u,-    Monad u,-    EvaluateSym inputs,-    ExtractSymbolics inputs,-    ConfigurableSolver config handle,-    SEq inputs-  ) =>-  config ->-  inputs ->-  (Either e v -> u (Either VerificationConditions ())) ->-  t ->-  IO ([Model], CEGISResult SolvingFailure)-cegisForAllExceptVC config inputs f v = do-  cegisForAll config inputs $-    simpleMerge $-      ( \case-          Left AssumptionViolation -> cegisPrePost (con False) (con True)-          Left AssertionViolation -> cegisPostCond (con False)-          _ -> cegisPostCond (con True)-      )-        <$> (extractUnionExcept v >>= f)---- |--- CEGIS for symbolic programs with error handling, with a forall variable.------ See 'cegisForAll' and 'cegisExceptStdVC'.-cegisForAllExceptStdVC ::-  ( UnionWithExcept t u VerificationConditions (),-    UnionPrjOp u,-    Monad u,-    EvaluateSym inputs,-    ExtractSymbolics inputs,-    ConfigurableSolver config handle,-    SEq inputs-  ) =>-  config ->-  inputs ->-  t ->-  IO ([Model], CEGISResult SolvingFailure)-cegisForAllExceptStdVC config inputs = cegisForAllExceptVC config inputs return
− src/Grisette/Core/Data/Class/Error.hs 
@@ -1,205 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE Trustworthy #-}---- |--- Module      :   Grisette.Core.Data.Class.Error--- 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.Core.Data.Class.Error-  ( -- * Error transformation-    TransformError (..),--    -- * Throwing error-    symAssertWith,-    symAssertTransformableError,-    symThrowTransformableError,-    symAssert,-    symAssume,-  )-where--import Control.Exception (ArithException, ArrayException)-import Control.Monad.Except (MonadError (throwError))-import Grisette.Core.Control.Exception-  ( AssertionError (AssertionError),-    VerificationConditions (AssertionViolation, AssumptionViolation),-  )-import Grisette.Core.Control.Monad.Union (MonadUnion)-import Grisette.Core.Data.Class.Mergeable (Mergeable)-import Grisette.Core.Data.Class.SimpleMergeable (merge, mrgIf)-import Grisette.IR.SymPrim.Data.SymPrim (SymBool)---- $setup--- >>> import Control.Exception--- >>> import Grisette.Core--- >>> import Grisette.IR.SymPrim--- >>> import Grisette.Lib.Control.Monad--- >>> import Control.Monad.Except--- >>> :set -XOverloadedStrings--- >>> :set -XFlexibleContexts---- | This class indicates that the error type @to@ can always represent the--- error type @from@.------ This is useful in implementing generic procedures that may throw errors.--- For example, we support symbolic division and modulo operations. These--- operations should throw an error when the divisor is zero, and we use the--- standard error type 'Control.Exception.ArithException' for this purpose.--- However, the user may use other type to represent errors, so we need this--- type class to transform the 'Control.Exception.ArithException' to the--- user-defined types.------ Another example of these generic procedures is the--- 'Grisette.Core.symAssert' and 'Grisette.Core.symAssume' functions.--- They can be used with any error types that are--- compatible with the 'Grisette.Core.AssertionError' and--- 'Grisette.Core.VerificationConditions' types, respectively.-class TransformError from to where-  -- | Transforms an error with type @from@ to an error with type @to@.-  transformError :: from -> to--instance {-# OVERLAPPABLE #-} TransformError a a where-  transformError = id-  {-# INLINE transformError #-}--instance {-# OVERLAPS #-} TransformError a () where-  transformError _ = ()-  {-# INLINE transformError #-}--instance {-# OVERLAPPING #-} TransformError () () where-  transformError _ = ()-  {-# INLINE transformError #-}---- | Used within a monadic multi path computation to begin exception processing.------ Terminate the current execution path with the specified error. Compatible--- errors can be transformed.------ >>> symThrowTransformableError Overflow :: ExceptT AssertionError UnionM ()--- ExceptT {Left AssertionError}-symThrowTransformableError ::-  ( Mergeable to,-    Mergeable a,-    TransformError from to,-    MonadError to erm,-    MonadUnion erm-  ) =>-  from ->-  erm a-symThrowTransformableError = merge . throwError . transformError-{-# INLINE symThrowTransformableError #-}---- | Used within a monadic multi path computation for exception processing.------ 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 ()--- ExceptT {If (! a) (Left AssertionError) (Right ())}-symAssertTransformableError ::-  ( Mergeable to,-    TransformError from to,-    MonadError to erm,-    MonadUnion erm-  ) =>-  from ->-  SymBool ->-  erm ()-symAssertTransformableError err cond = mrgIf cond (return ()) (symThrowTransformableError err)-{-# INLINE symAssertTransformableError #-}--symAssertWith ::-  ( Mergeable e,-    MonadError e erm,-    MonadUnion erm-  ) =>-  e ->-  SymBool ->-  erm ()-symAssertWith err cond = mrgIf cond (return ()) (throwError err)-{-# INLINE symAssertWith #-}--instance TransformError VerificationConditions VerificationConditions where-  transformError = id--instance TransformError AssertionError VerificationConditions where-  transformError _ = AssertionViolation--instance TransformError ArithException AssertionError where-  transformError _ = AssertionError--instance TransformError ArrayException AssertionError where-  transformError _ = AssertionError--instance TransformError AssertionError AssertionError where-  transformError = id---- | Used within a monadic multi path computation to begin exception processing.------ Checks the condition passed to the function.--- The current execution path will be terminated with assertion error if the condition is false.------ If the condition is symbolic, Grisette will split the execution into two paths based on the condition.--- The symbolic execution will continue on the then-branch, where the condition is true.--- For the else branch, where the condition is false, the execution will be terminated.------ The resulting monadic environment should be compatible with the 'AssertionError'--- error type. See 'TransformError' type class for details.------ __/Examples/__:------ Terminates the execution if the condition is false.--- Note that we may lose the 'Mergeable' knowledge here if no possible execution--- path is viable. This may affect the efficiency in theory, but in practice this--- should not be a problem as all paths are terminated and no further evaluation--- would be performed.------ >>> symAssert (con False) :: ExceptT AssertionError UnionM ()--- ExceptT {Left AssertionError}--- >>> do; symAssert (con False); mrgReturn 1 :: ExceptT AssertionError UnionM Integer--- ExceptT <Left AssertionError>------ No effect if the condition is true:------ >>> symAssert (con True) :: ExceptT AssertionError UnionM ()--- ExceptT {Right ()}--- >>> do; symAssert (con True); mrgReturn 1 :: ExceptT AssertionError UnionM Integer--- ExceptT {Right 1}------ Splitting the path and terminate one of them when the condition is symbolic.------ >>> symAssert (ssym "a") :: ExceptT AssertionError UnionM ()--- ExceptT {If (! a) (Left AssertionError) (Right ())}--- >>> do; symAssert (ssym "a"); mrgReturn 1 :: ExceptT AssertionError UnionM Integer--- ExceptT {If (! a) (Left AssertionError) (Right 1)}------ 'AssertionError' is compatible with 'VerificationConditions':------ >>> symAssert (ssym "a") :: ExceptT VerificationConditions UnionM ()--- ExceptT {If (! a) (Left AssertionViolation) (Right ())}-symAssert ::-  (TransformError AssertionError to, Mergeable to, MonadError to erm, MonadUnion erm) =>-  SymBool ->-  erm ()-symAssert = symAssertTransformableError AssertionError---- | Used within a monadic multi path computation to begin exception processing.------ Similar to 'symAssert', but terminates the execution path with 'AssumptionViolation' error.------ /Examples/:------ >>> symAssume (ssym "a") :: ExceptT VerificationConditions UnionM ()--- ExceptT {If (! a) (Left AssumptionViolation) (Right ())}-symAssume ::-  (TransformError VerificationConditions to, Mergeable to, MonadError to erm, MonadUnion erm) =>-  SymBool ->-  erm ()-symAssume = symAssertTransformableError AssumptionViolation
− src/Grisette/Core/Data/Class/EvaluateSym.hs 
@@ -1,286 +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.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.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,-    type (:*:) ((:*:)),-    type (:+:) (L1, R1),-  )-import Generics.Deriving.Instances ()-import Grisette.Core.Control.Exception (AssertionError, VerificationConditions)-import Grisette.Core.Data.BV (IntN, SomeIntN, SomeWordN, WordN)-import Grisette.Core.Data.Class.ToCon (ToCon (toCon))-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term (LinkedRep, SupportedPrim)-import Grisette.IR.SymPrim.Data.Prim.Model (Model, evaluateTerm)-import Grisette.IR.SymPrim.Data.SymPrim-  ( SomeSymIntN (SomeSymIntN),-    SomeSymWordN (SomeSymWordN),-    SymBool (SymBool),-    SymIntN (SymIntN),-    SymInteger (SymInteger),-    SymWordN (SymWordN),-    type (-~>) (SymGeneralFun),-    type (=~>) (SymTabularFun),-  )---- $setup--- >>> import Grisette.Core--- >>> import Grisette.IR.SymPrim--- >>> import Data.Proxy--- >>> :set -XTypeApplications---- | Evaluating symbolic values with some model.------ >>> let model = insertValue (SimpleSymbol "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 (SimpleSymbol "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(SomeIntN)-CONCRETE_EVALUATESYM(SomeWordN)-CONCRETE_EVALUATESYM(B.ByteString)-CONCRETE_EVALUATESYM(T.Text)-CONCRETE_EVALUATESYM_BV(IntN)-CONCRETE_EVALUATESYM_BV(WordN)-#endif---- ()-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(op, cons) \-instance (SupportedPrim ca, SupportedPrim cb, LinkedRep ca sa, LinkedRep cb sb) => EvaluateSym (sa op sb) where \-  evaluateSym fillDefault model (cons t) = cons $ evaluateTerm fillDefault model t--#define EVALUATE_SYM_BV_SOME(somety, origty) \-instance EvaluateSym somety where \-  evaluateSym fillDefault model (somety (origty t)) = somety $ origty $ evaluateTerm fillDefault model t--#if 1-EVALUATE_SYM_SIMPLE(SymBool)-EVALUATE_SYM_SIMPLE(SymInteger)-EVALUATE_SYM_BV(SymIntN)-EVALUATE_SYM_BV(SymWordN)-EVALUATE_SYM_FUN(=~>, SymTabularFun)-EVALUATE_SYM_FUN(-~>, SymGeneralFun)-EVALUATE_SYM_BV_SOME(SomeSymIntN, SymIntN)-EVALUATE_SYM_BV_SOME(SomeSymWordN, SymWordN)-#endif---- 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--instance (EvaluateSym c) => EvaluateSym' (K1 i c) where-  evaluateSym' fillDefault model (K1 v) = K1 $ evaluateSym fillDefault model v--instance (EvaluateSym' a) => EvaluateSym' (M1 i c a) where-  evaluateSym' fillDefault model (M1 v) = M1 $ evaluateSym' fillDefault model v--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--instance (EvaluateSym' a, EvaluateSym' b) => EvaluateSym' (a :*: b) where-  evaluateSym' fillDefault model (a :*: b) = evaluateSym' fillDefault model a :*: evaluateSym' fillDefault model b
− src/Grisette/Core/Data/Class/ExtractSymbolics.hs 
@@ -1,323 +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.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.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,-    type (:*:) ((:*:)),-    type (:+:) (L1, R1),-  )-import Grisette.Core.Control.Exception (AssertionError, VerificationConditions)-import Grisette.Core.Data.BV (IntN, SomeIntN, SomeWordN, WordN)-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term-  ( LinkedRep,-    SupportedPrim,-  )-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermUtils (extractSymbolicsTerm)-import Grisette.IR.SymPrim.Data.Prim.Model-  ( SymbolSet (SymbolSet),-  )-import Grisette.IR.SymPrim.Data.SymPrim-  ( SomeSymIntN (SomeSymIntN),-    SomeSymWordN (SomeSymWordN),-    SymBool (SymBool),-    SymIntN (SymIntN),-    SymInteger (SymInteger),-    SymWordN (SymWordN),-    type (-~>) (SymGeneralFun),-    type (=~>) (SymTabularFun),-  )---- $setup--- >>> import Grisette.Core--- >>> import Grisette.IR.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(SomeWordN)-CONCRETE_EXTRACT_SYMBOLICS(SomeIntN)-CONCRETE_EXTRACT_SYMBOLICS(B.ByteString)-CONCRETE_EXTRACT_SYMBOLICS(T.Text)-CONCRETE_EXTRACT_SYMBOLICS_BV(WordN)-CONCRETE_EXTRACT_SYMBOLICS_BV(IntN)-#endif---- ()-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(op, cons) \-instance (SupportedPrim ca, SupportedPrim cb, LinkedRep ca sa, LinkedRep cb sb) => ExtractSymbolics (sa op sb) where \-  extractSymbolics (cons t) = SymbolSet $ extractSymbolicsTerm t--#define EXTRACT_SYMBOLICS_BV_SOME(somety, origty) \-instance ExtractSymbolics somety where \-  extractSymbolics (somety (origty t)) = SymbolSet $ extractSymbolicsTerm t--#if 1-EXTRACT_SYMBOLICS_SIMPLE(SymBool)-EXTRACT_SYMBOLICS_SIMPLE(SymInteger)-EXTRACT_SYMBOLICS_BV(SymIntN)-EXTRACT_SYMBOLICS_BV(SymWordN)-EXTRACT_SYMBOLICS_FUN(=~>, SymTabularFun)-EXTRACT_SYMBOLICS_FUN(-~>, SymGeneralFun)-EXTRACT_SYMBOLICS_BV_SOME(SomeSymIntN, SymIntN)-EXTRACT_SYMBOLICS_BV_SOME(SomeSymWordN, SymWordN)-#endif---- 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 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
− src/Grisette/Core/Data/Class/Function.hs 
@@ -1,72 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE TypeFamilies #-}---- |--- Module      :   Grisette.Core.Data.Class.Function--- 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.Core.Data.Class.Function-  ( -- * Function operations-    Function (..),-    Apply (..),-  )-where---- $setup--- >>> import Grisette.Core--- >>> import Grisette.IR.SymPrim--- >>> :set -XDataKinds--- >>> :set -XBinaryLiterals--- >>> :set -XFlexibleContexts--- >>> :set -XFlexibleInstances--- >>> :set -XFunctionalDependencies--- >>> :set -XOverloadedStrings--- >>> :set -XTypeOperators---- | Abstraction for function-like types.-class Function f where-  -- | Argument type-  type Arg f--  -- | Return type-  type Ret f--  -- | Function application operator.-  ---  -- The operator is not right associated (like `($)`). It is left associated,-  -- and you can provide many arguments with this operator once at a time.-  ---  -- >>> (+1) # 2-  -- 3-  ---  -- >>> (+) # 2 # 3-  -- 5-  (#) :: f -> Arg f -> Ret f--  infixl 9 #--instance Function (a -> b) where-  type Arg (a -> b) = a-  type Ret (a -> b) = b-  f # a = f a---- | Applying an uninterpreted function.------ >>> let f = "f" :: SymInteger =~> SymInteger =~> SymInteger--- >>> apply f "a" "b"--- (apply (apply f a) b)------ Note that for implementation reasons, you can also use `apply` function on--- a non-function symbolic value. In this case, the function is treated as an--- `id` function.-class Apply uf where-  type FunType uf-  apply :: uf -> FunType uf--instance (Apply b) => Apply (a -> b) where-  type FunType (a -> b) = a -> FunType b-  apply f a = apply (f a)
− src/Grisette/Core/Data/Class/GPretty.hs 
@@ -1,466 +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.Core.Data.Class.GPretty-  ( GPretty (..),-    groupedEnclose,-    condEnclose,-  )-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 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.Core.Data.BV (IntN, SomeIntN, SomeWordN, WordN)-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term-  ( LinkedRep,-    SupportedPrim,-    prettyPrintTerm,-  )-import Grisette.IR.SymPrim.Data.SymPrim-  ( SomeSymIntN (SomeSymIntN),-    SomeSymWordN (SomeSymWordN),-    SymBool (SymBool),-    SymIntN (SymIntN),-    SymInteger (SymInteger),-    SymWordN (SymWordN),-    type (-~>) (SymGeneralFun),-    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(SomeIntN)-GPRETTY_SIMPLE(SomeWordN)-#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 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 _ (MaybeT a) =-    group $-      nest 2 $-        vsep-          [ "MaybeT",-            gprettyPrec 11 a-          ]---- ExceptT-instance-  (GPretty (m (Either e a))) =>-  GPretty (ExceptT e m a)-  where-  gprettyPrec _ (ExceptT a) =-    group $-      nest 2 $-        vsep-          [ "ExceptT",-            gprettyPrec 11 a-          ]---- WriterT-instance-  (GPretty (m (a, w))) =>-  GPretty (WriterLazy.WriterT w m a)-  where-  gprettyPrec _ (WriterLazy.WriterT a) =-    group $-      nest 2 $-        vsep-          [ "WriterT",-            gprettyPrec 11 a-          ]--instance-  (GPretty (m (a, w))) =>-  GPretty (WriterStrict.WriterT w m a)-  where-  gprettyPrec _ (WriterStrict.WriterT a) =-    group $-      nest 2 $-        vsep-          [ "WriterT",-            gprettyPrec 11 a-          ]---- Identity-instance (GPretty a) => GPretty (Identity a) where-  gprettyPrec _ (Identity a) =-    group $-      nest 2 $-        vsep-          [ "Identity",-            gprettyPrec 11 a-          ]---- IdentityT-instance (GPretty (m a)) => GPretty (IdentityT m a) where-  gprettyPrec _ (IdentityT a) =-    group $-      nest 2 $-        vsep-          [ "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--#define GPRETTY_SYM_SOME_BV(symtype) \-instance GPretty symtype where \-  gpretty (symtype t) = gpretty t--#if 1-GPRETTY_SYM_SIMPLE(SymBool)-GPRETTY_SYM_SIMPLE(SymInteger)-GPRETTY_SYM_BV(SymIntN)-GPRETTY_SYM_BV(SymWordN)-GPRETTY_SYM_FUN(=~>, SymTabularFun)-GPRETTY_SYM_FUN(-~>, SymGeneralFun)-GPRETTY_SYM_SOME_BV(SomeSymIntN)-GPRETTY_SYM_SOME_BV(SomeSymWordN)-#endif--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--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 pretty (conName c)-          else-            group $-              condEnclose (n > 10) "(" ")" $-                align $-                  nest 2 $-                    vsep-                      [ pretty (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 "")
− src/Grisette/Core/Data/Class/GenSym.hs 
@@ -1,1815 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE DerivingVia #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE QuantifiedConstraints #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskellQuotes #-}-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}---- |--- Module      :   Grisette.Core.Data.Class.GenSym--- 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.Core.Data.Class.GenSym-  ( -- * Indices and identifiers for fresh symbolic value generation-    FreshIndex (..),-    FreshIdent (..),-    name,-    nameWithInfo,--    -- * Monad for fresh symbolic value generation-    MonadFresh (..),-    nextFreshIndex,-    liftFresh,-    FreshT (FreshT, runFreshTFromIndex),-    Fresh,-    runFreshT,-    runFresh,-    mrgRunFreshT,--    -- * Symbolic value generation-    GenSym (..),-    GenSymSimple (..),-    genSym,-    genSymSimple,-    derivedNoSpecFresh,-    derivedNoSpecSimpleFresh,-    derivedSameShapeSimpleFresh,--    -- * Symbolic choices-    chooseFresh,-    chooseSimpleFresh,-    chooseUnionFresh,-    choose,-    chooseSimple,-    chooseUnion,--    -- * Some common GenSym specifications-    ListSpec (..),-    SimpleListSpec (..),-    EnumGenBound (..),-    EnumGenUpperBound (..),-  )-where--import Control.DeepSeq (NFData (rnf))-import Control.Monad.Except-  ( ExceptT (ExceptT),-    MonadError (catchError, throwError),-  )-import Control.Monad.Identity (Identity (runIdentity))-import Control.Monad.RWS.Class-  ( MonadRWS,-    MonadReader (ask, local),-    MonadState (get, put),-    MonadWriter (listen, pass, writer),-    asks,-    gets,-  )-import qualified Control.Monad.RWS.Lazy as RWSLazy-import qualified Control.Monad.RWS.Strict as RWSStrict-import Control.Monad.Reader (ReaderT)-import Control.Monad.Signatures (Catch)-import qualified Control.Monad.State.Lazy as StateLazy-import qualified Control.Monad.State.Strict as StateStrict-import Control.Monad.Trans.Class-  ( MonadTrans (lift),-  )-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 (first))-import qualified Data.ByteString as B-import Data.Hashable (Hashable (hashWithSalt))-import Data.Int (Int16, Int32, Int64, Int8)-import Data.String (IsString (fromString))-import qualified Data.Text as T-import Data.Typeable-  ( Proxy (Proxy),-    Typeable,-    eqT,-    typeRep,-    type (:~:) (Refl),-  )-import Data.Word (Word16, Word32, Word64, Word8)-import GHC.TypeNats (KnownNat, Nat, type (<=))-import Generics.Deriving-  ( Generic (Rep, from, to),-    K1 (K1),-    M1 (M1),-    U1 (U1),-    type (:*:) ((:*:)),-    type (:+:) (L1, R1),-  )-import Grisette.Core.Control.Monad.UnionM (UnionM, isMerged, underlyingUnion)-import Grisette.Core.Data.BV (IntN, SomeIntN, SomeWordN, WordN)-import Grisette.Core.Data.Class.Mergeable-  ( Mergeable (rootStrategy),-    Mergeable1 (liftRootStrategy),-    Mergeable2 (liftRootStrategy2),-    MergingStrategy (SimpleStrategy),-    rootStrategy1,-    wrapStrategy,-  )-import Grisette.Core.Data.Class.SimpleMergeable-  ( SimpleMergeable (mrgIte),-    SimpleMergeable1 (liftMrgIte),-    UnionLike (mergeWithStrategy, mrgIfWithStrategy, single, unionIf),-    merge,-    mrgIf,-    mrgSingle,-  )-import Grisette.Core.Data.Class.Solvable-  ( Solvable (iinfosym, isym),-  )-import Grisette.Core.Data.Union (Union (UnionIf, UnionSingle))-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term-  ( LinkedRep,-    SupportedPrim,-  )-import Grisette.IR.SymPrim.Data.SymPrim-  ( SomeSymIntN (SomeSymIntN),-    SomeSymWordN (SomeSymWordN),-    SymBool,-    SymIntN,-    SymInteger,-    SymWordN,-    type (-~>),-    type (=~>),-  )-import Grisette.Utils.Parameterized-  ( KnownProof (KnownProof),-    LeqProof (LeqProof),-    unsafeKnownProof,-    unsafeLeqProof,-  )-import Language.Haskell.TH.Syntax (Lift (liftTyped))---- $setup--- >>> import Grisette.Core--- >>> import Grisette.IR.SymPrim--- >>> :set -XOverloadedStrings--- >>> :set -XTypeApplications---- | Index type used for 'GenSym'.------ To generate fresh variables, a monadic stateful context will be maintained.--- The index should be increased every time a new symbolic constant is--- generated.-newtype FreshIndex = FreshIndex Int-  deriving (Show)-  deriving (Eq, Ord, Num) via Int--instance Mergeable FreshIndex where-  rootStrategy = SimpleStrategy $ \_ t f -> max t f--instance SimpleMergeable FreshIndex where-  mrgIte _ = max---- | Identifier type used for 'GenSym'------ The constructor is hidden intentionally.--- You can construct an identifier by:------   * a raw name------     The following two expressions will refer to the same identifier (the---     solver won't distinguish them and would assign the same value to them).---     The user may need to use unique names to avoid unintentional identifier---     collision.------     >>> name "a"---     a------     >>> "a" :: FreshIdent -- available when OverloadedStrings is enabled---     a------   * bundle the calling file location with the name to ensure global uniqueness------     Identifiers created at different locations will not be the---     same. The identifiers created at the same location will be the same.------     >>> $$(nameWithLoc "a") -- a sample result could be "a:<interactive>:18:4-18"---     a:<interactive>:...------   * bundle the calling file location with some user provided information------     Identifiers created with different name or different additional---     information will not be the same.------     >>> nameWithInfo "a" (1 :: Int)---     a:1-data FreshIdent where-  FreshIdent :: T.Text -> FreshIdent-  FreshIdentWithInfo :: (Typeable a, Ord a, Lift a, NFData a, Show a, Hashable a) => T.Text -> a -> FreshIdent--instance Show FreshIdent where-  show (FreshIdent i) = T.unpack i-  show (FreshIdentWithInfo s i) = T.unpack s ++ ":" ++ show i--instance IsString FreshIdent where-  fromString = name . T.pack--instance Eq FreshIdent where-  FreshIdent l == FreshIdent r = l == r-  FreshIdentWithInfo l (linfo :: linfo) == FreshIdentWithInfo r (rinfo :: rinfo) = case eqT @linfo @rinfo of-    Just Refl -> l == r && linfo == rinfo-    _ -> False-  _ == _ = False--instance Ord FreshIdent where-  FreshIdent l <= FreshIdent r = l <= r-  FreshIdent _ <= _ = True-  _ <= FreshIdent _ = False-  FreshIdentWithInfo l (linfo :: linfo) <= FreshIdentWithInfo r (rinfo :: rinfo) =-    l < r-      || ( l == r-             && ( case eqT @linfo @rinfo of-                    Just Refl -> linfo <= rinfo-                    _ -> typeRep (Proxy @linfo) <= typeRep (Proxy @rinfo)-                )-         )--instance Hashable FreshIdent where-  hashWithSalt s (FreshIdent n) = s `hashWithSalt` n-  hashWithSalt s (FreshIdentWithInfo n i) = s `hashWithSalt` n `hashWithSalt` i--instance Lift FreshIdent where-  liftTyped (FreshIdent n) = [||FreshIdent n||]-  liftTyped (FreshIdentWithInfo n i) = [||FreshIdentWithInfo n i||]--instance NFData FreshIdent where-  rnf (FreshIdent n) = rnf n-  rnf (FreshIdentWithInfo n i) = rnf n `seq` rnf i---- | Simple name identifier.--- The same identifier refers to the same symbolic variable in the whole program.------ The user may need to use unique names to avoid unintentional identifier--- collision.-name :: T.Text -> FreshIdent-name = FreshIdent---- | Identifier with extra information.--- The same name with the same information--- refers to the same symbolic variable in the whole program.------ The user may need to use unique names or additional information to avoid--- unintentional identifier collision.-nameWithInfo :: forall a. (Typeable a, Ord a, Lift a, NFData a, Show a, Hashable a) => T.Text -> a -> FreshIdent-nameWithInfo = FreshIdentWithInfo---- | Monad class for fresh symbolic value generation.------ The monad should be a reader monad for the 'FreshIdent' and a state monad for--- the 'FreshIndex'.-class (Monad m) => MonadFresh m where-  -- | Get the current index for fresh variable generation.-  getFreshIndex :: m FreshIndex--  -- | Set the current index for fresh variable generation.-  setFreshIndex :: FreshIndex -> m ()--  -- | Get the identifier.-  getFreshIdent :: m FreshIdent---- | Get the next fresh index and increase the current index.-nextFreshIndex :: (MonadFresh m) => m FreshIndex-nextFreshIndex = do-  curr <- getFreshIndex-  let new = curr + 1-  setFreshIndex new-  return curr---- | Lifts an @`Fresh` a@ into any `MonadFresh`.-liftFresh :: (MonadFresh m) => Fresh a -> m a-liftFresh (FreshT f) = do-  index <- nextFreshIndex-  ident <- getFreshIdent-  let (a, newIdx) = runIdentity $ f ident index-  setFreshIndex newIdx-  return a---- | A symbolic generation monad transformer.--- It is a reader monad transformer for identifiers and--- a state monad transformer for indices.------ Each time a fresh symbolic variable is generated, the index should be increased.-newtype FreshT m a = FreshT-  { runFreshTFromIndex :: FreshIdent -> FreshIndex -> m (a, FreshIndex)-  }--instance-  (Mergeable a, Mergeable1 m) =>-  Mergeable (FreshT m a)-  where-  rootStrategy =-    wrapStrategy (liftRootStrategy (liftRootStrategy rootStrategy1)) FreshT runFreshTFromIndex--instance (Mergeable1 m) => Mergeable1 (FreshT m) where-  liftRootStrategy m =-    wrapStrategy-      (liftRootStrategy (liftRootStrategy (liftRootStrategy (liftRootStrategy2 m rootStrategy))))-      FreshT-      runFreshTFromIndex--instance-  (UnionLike m, Mergeable a) =>-  SimpleMergeable (FreshT m a)-  where-  mrgIte = mrgIf--instance-  (UnionLike m) =>-  SimpleMergeable1 (FreshT m)-  where-  liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m)--instance-  (UnionLike m) =>-  UnionLike (FreshT m)-  where-  mergeWithStrategy s (FreshT f) =-    FreshT $ \ident index -> mergeWithStrategy (liftRootStrategy2 s rootStrategy) $ f ident index-  mrgIfWithStrategy s cond (FreshT t) (FreshT f) =-    FreshT $ \ident index -> mrgIfWithStrategy (liftRootStrategy2 s rootStrategy) cond (t ident index) (f ident index)-  single x = FreshT $ \_ i -> single (x, i)-  unionIf cond (FreshT t) (FreshT f) =-    FreshT $ \ident index -> unionIf cond (t ident index) (f ident index)---- | Run the symbolic generation with the given identifier and 0 as the initial index.-runFreshT :: (Monad m) => FreshT m a -> FreshIdent -> m a-runFreshT m ident = fst <$> runFreshTFromIndex m ident (FreshIndex 0)--mrgRunFreshT ::-  (Monad m, UnionLike m, Mergeable a) =>-  FreshT m a ->-  FreshIdent ->-  m a-mrgRunFreshT m ident = merge $ runFreshT m ident--instance (Functor f) => Functor (FreshT f) where-  fmap f (FreshT s) = FreshT $ \ident idx -> first f <$> s ident idx--instance (Applicative m, Monad m) => Applicative (FreshT m) where-  pure a = FreshT $ \_ idx -> pure (a, idx)-  FreshT fs <*> FreshT as = FreshT $ \ident idx -> do-    (f, idx') <- fs ident idx-    (a, idx'') <- as ident idx'-    return (f a, idx'')--instance (Monad m) => Monad (FreshT m) where-  (FreshT s) >>= f = FreshT $ \ident idx -> do-    (a, idx') <- s ident idx-    runFreshTFromIndex (f a) ident idx'--instance MonadTrans FreshT where-  lift x = FreshT $ \_ index -> (,index) <$> x--liftFreshTCache :: (Functor m) => Catch e m (a, FreshIndex) -> Catch e (FreshT m) a-liftFreshTCache catchE (FreshT m) h =-  FreshT $ \ident index -> m ident index `catchE` \e -> runFreshTFromIndex (h e) ident index--instance (MonadError e m) => MonadError e (FreshT m) where-  throwError = lift . throwError-  catchError = liftFreshTCache catchError--instance (MonadWriter w m) => MonadWriter w (FreshT m) where-  writer p = FreshT $ \_ index -> (,index) <$> writer p-  listen (FreshT r) = FreshT $ \ident index -> (\((a, b), c) -> ((a, c), b)) <$> listen (r ident index)-  pass (FreshT r) = FreshT $ \ident index -> pass $ (\((a, b), c) -> ((a, c), b)) <$> r ident index--instance (MonadState s m) => MonadState s (FreshT m) where-  get = FreshT $ \_ index -> gets (,index)-  put s = FreshT $ \_ index -> (,index) <$> put s--instance (MonadReader r m) => MonadReader r (FreshT m) where-  local t (FreshT r) = FreshT $ \ident index -> local t (r ident index)-  ask = FreshT $ \_ index -> asks (,index)--instance (MonadRWS r w s m) => MonadRWS r w s (FreshT m)--instance (MonadFresh m) => MonadFresh (ExceptT e m) where-  getFreshIndex = lift getFreshIndex-  setFreshIndex newIdx = lift $ setFreshIndex newIdx-  getFreshIdent = lift getFreshIdent--instance (MonadFresh m, Monoid w) => MonadFresh (WriterLazy.WriterT w m) where-  getFreshIndex = lift getFreshIndex-  setFreshIndex newIdx = lift $ setFreshIndex newIdx-  getFreshIdent = lift getFreshIdent--instance (MonadFresh m, Monoid w) => MonadFresh (WriterStrict.WriterT w m) where-  getFreshIndex = lift getFreshIndex-  setFreshIndex newIdx = lift $ setFreshIndex newIdx-  getFreshIdent = lift getFreshIdent--instance (MonadFresh m) => MonadFresh (StateLazy.StateT s m) where-  getFreshIndex = lift getFreshIndex-  setFreshIndex newIdx = lift $ setFreshIndex newIdx-  getFreshIdent = lift getFreshIdent--instance (MonadFresh m) => MonadFresh (StateStrict.StateT s m) where-  getFreshIndex = lift getFreshIndex-  setFreshIndex newIdx = lift $ setFreshIndex newIdx-  getFreshIdent = lift getFreshIdent--instance (MonadFresh m) => MonadFresh (ReaderT r m) where-  getFreshIndex = lift getFreshIndex-  setFreshIndex newIdx = lift $ setFreshIndex newIdx-  getFreshIdent = lift getFreshIdent--instance (MonadFresh m, Monoid w) => MonadFresh (RWSLazy.RWST r w s m) where-  getFreshIndex = lift getFreshIndex-  setFreshIndex newIdx = lift $ setFreshIndex newIdx-  getFreshIdent = lift getFreshIdent--instance (MonadFresh m, Monoid w) => MonadFresh (RWSStrict.RWST r w s m) where-  getFreshIndex = lift getFreshIndex-  setFreshIndex newIdx = lift $ setFreshIndex newIdx-  getFreshIdent = lift getFreshIdent---- | 'FreshT' specialized with Identity.-type Fresh = FreshT Identity---- | Run the symbolic generation with the given identifier and 0 as the initial index.-runFresh :: Fresh a -> FreshIdent -> a-runFresh m ident = runIdentity $ runFreshT m ident--instance (Monad m) => MonadFresh (FreshT m) where-  getFreshIndex = FreshT $ \_ idx -> return (idx, idx)-  setFreshIndex newIdx = FreshT $ \_ _ -> return ((), newIdx)-  getFreshIdent = FreshT $ curry return---- | Class of types in which symbolic values can be generated with respect to some specification.------ The result will be wrapped in a union-like monad.--- This ensures that we can generate those types with complex merging rules.------ The uniqueness of symbolic constants is managed with the a monadic context.--- 'Fresh' and 'FreshT' can be useful.-class (Mergeable a) => GenSym spec a where-  -- | Generate a symbolic value given some specification. Within a single-  -- `MonadFresh` context, calls to `fresh` would generate unique symbolic-  -- constants.-  ---  -- The following example generates a symbolic boolean. No specification is-  -- needed.-  ---  -- >>> runFresh (fresh ()) "a" :: UnionM 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-  -- {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)-  -- {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]-  -- {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)-  -- ({a@0},{a@1})-  fresh ::-    (MonadFresh m) =>-    spec ->-    m (UnionM a)-  default fresh ::-    (GenSymSimple spec a) =>-    ( MonadFresh m-    ) =>-    spec ->-    m (UnionM 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]--- {If a@2 [a@1] [a@0,a@1]}-genSym :: (GenSym spec a) => spec -> FreshIdent -> UnionM a-genSym = runFresh . fresh---- | Class of types in which symbolic values can be generated with respect to some specification.------ The result will __/not/__ be wrapped in a union-like monad.------ The uniqueness of symbolic constants is managed with the a monadic context.--- 'Fresh' and 'FreshT' can be useful.-class GenSymSimple spec a where-  -- | Generate a symbolic value given some specification. The uniqueness is ensured.-  ---  -- The following example generates a symbolic boolean. No specification is needed.-  ---  -- >>> runFresh (simpleFresh ()) "a" :: SymBool-  -- a@0-  ---  -- The following code generates list of symbolic boolean with length 2.-  -- As the length is fixed, we don't have to wrap the result in unions.-  ---  -- >>> runFresh (simpleFresh (SimpleListSpec 2 ())) "a" :: [SymBool]-  -- [a@0,a@1]-  simpleFresh ::-    ( MonadFresh m-    ) =>-    spec ->-    m a---- | Generate a simple 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.------ >>> genSymSimple (SimpleListSpec 2 ()) "a" :: [SymBool]--- [a@0,a@1]-genSymSimple :: forall spec a. (GenSymSimple spec a) => spec -> FreshIdent -> a-genSymSimple = runFresh . simpleFresh--class GenSymNoSpec a where-  freshNoSpec ::-    ( MonadFresh m-    ) =>-    m (UnionM (a c))--instance GenSymNoSpec U1 where-  freshNoSpec = return $ mrgSingle U1--instance (GenSym () c) => GenSymNoSpec (K1 i c) where-  freshNoSpec = fmap K1 <$> fresh ()--instance (GenSymNoSpec a) => GenSymNoSpec (M1 i c a) where-  freshNoSpec = fmap M1 <$> freshNoSpec--instance-  ( GenSymNoSpec a,-    GenSymNoSpec b,-    forall x. Mergeable (a x),-    forall x. Mergeable (b x)-  ) =>-  GenSymNoSpec (a :+: b)-  where-  freshNoSpec ::-    forall m c.-    ( MonadFresh m-    ) =>-    m (UnionM ((a :+: b) c))-  freshNoSpec = do-    cond :: bool <- simpleFresh ()-    l :: UnionM (a c) <- freshNoSpec-    r :: UnionM (b c) <- freshNoSpec-    return $ mrgIf cond (fmap L1 l) (fmap R1 r)--instance-  (GenSymNoSpec a, GenSymNoSpec b) =>-  GenSymNoSpec (a :*: b)-  where-  freshNoSpec ::-    forall m c.-    ( MonadFresh m-    ) =>-    m (UnionM ((a :*: b) c))-  freshNoSpec = do-    l :: UnionM (a c) <- freshNoSpec-    r :: UnionM (b c) <- freshNoSpec-    return $ do-      l1 <- l-      r1 <- r-      return $ l1 :*: r1---- | We cannot provide DerivingVia style derivation for 'GenSym', while you can--- use this 'fresh' implementation to implement 'GenSym' for your own types.------ This 'fresh' implementation is for the types that does not need any specification.--- It will generate product types by generating each fields with @()@ as specification,--- and generate all possible values for a sum type.------ __Note:__ __Never__ use on recursive types.-derivedNoSpecFresh ::-  forall a m.-  ( Generic a,-    GenSymNoSpec (Rep a),-    Mergeable a,-    MonadFresh m-  ) =>-  () ->-  m (UnionM a)-derivedNoSpecFresh _ = merge . fmap to <$> freshNoSpec--class GenSymSimpleNoSpec a where-  simpleFreshNoSpec :: (MonadFresh m) => m (a c)--instance GenSymSimpleNoSpec U1 where-  simpleFreshNoSpec = return U1--instance (GenSymSimple () c) => GenSymSimpleNoSpec (K1 i c) where-  simpleFreshNoSpec = K1 <$> simpleFresh ()--instance (GenSymSimpleNoSpec a) => GenSymSimpleNoSpec (M1 i c a) where-  simpleFreshNoSpec = M1 <$> simpleFreshNoSpec--instance-  (GenSymSimpleNoSpec a, GenSymSimpleNoSpec b) =>-  GenSymSimpleNoSpec (a :*: b)-  where-  simpleFreshNoSpec = do-    l :: a c <- simpleFreshNoSpec-    r :: b c <- simpleFreshNoSpec-    return $ l :*: r---- | We cannot provide DerivingVia style derivation for 'GenSymSimple', while--- you can use this 'simpleFresh' implementation to implement 'GenSymSimple' fo--- 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 not work on sum types.------ __Note:__ __Never__ use on recursive types.-derivedNoSpecSimpleFresh ::-  forall a m.-  ( Generic a,-    GenSymSimpleNoSpec (Rep a),-    MonadFresh m-  ) =>-  () ->-  m a-derivedNoSpecSimpleFresh _ = to <$> simpleFreshNoSpec--class GenSymSameShape a where-  genSymSameShapeFresh ::-    ( MonadFresh m-    ) =>-    a c ->-    m (a c)--instance GenSymSameShape U1 where-  genSymSameShapeFresh _ = return U1--instance (GenSymSimple c c) => GenSymSameShape (K1 i c) where-  genSymSameShapeFresh (K1 c) = K1 <$> simpleFresh c--instance (GenSymSameShape a) => GenSymSameShape (M1 i c a) where-  genSymSameShapeFresh (M1 a) = M1 <$> genSymSameShapeFresh a--instance-  (GenSymSameShape a, GenSymSameShape b) =>-  GenSymSameShape (a :+: b)-  where-  genSymSameShapeFresh (L1 a) = L1 <$> genSymSameShapeFresh a-  genSymSameShapeFresh (R1 a) = R1 <$> genSymSameShapeFresh a--instance-  (GenSymSameShape a, GenSymSameShape b) =>-  GenSymSameShape (a :*: b)-  where-  genSymSameShapeFresh (a :*: b) = do-    l :: a c <- genSymSameShapeFresh a-    r :: b c <- genSymSameShapeFresh b-    return $ l :*: r---- | We cannot provide DerivingVia style derivation for 'GenSymSimple', while--- you can use this 'simpleFresh' implementation to implement 'GenSymSimple' fo--- your own types.------ This 'simpleFresh' implementation is for the types that can be generated with--- a reference value of the same type.------ For sum types, it will generate the result with the same data constructor.--- For product types, it will generate the result by generating each field with--- the corresponding reference value.------ __Note:__ __Can__ be used on recursive types.-derivedSameShapeSimpleFresh ::-  forall a m.-  ( Generic a,-    GenSymSameShape (Rep a),-    MonadFresh m-  ) =>-  a ->-  m a-derivedSameShapeSimpleFresh a = to <$> genSymSameShapeFresh (from a)---- | Symbolically chooses one of the provided values.--- The procedure creates @n - 1@ fresh symbolic boolean variables every time it--- is evaluated, and use these variables to conditionally select one of the @n@--- provided expressions.------ 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--- {If a@0 1 (If a@1 2 3)}-chooseFresh ::-  forall a m.-  ( Mergeable a,-    MonadFresh m-  ) =>-  [a] ->-  m (UnionM a)-chooseFresh [x] = return $ mrgSingle x-chooseFresh (r : rs) = do-  b <- simpleFresh ()-  res <- chooseFresh rs-  return $ mrgIf b (mrgSingle r) res-chooseFresh [] = error "chooseFresh expects at least one value"---- | A wrapper for `chooseFresh` that executes the `MonadFresh` context.--- A globally unique identifier should be supplied to ensure the uniqueness of--- symbolic constants in the generated symbolic values.-choose ::-  forall a.-  ( Mergeable a-  ) =>-  [a] ->-  FreshIdent ->-  UnionM a-choose = runFresh . chooseFresh---- | Symbolically chooses one of the provided values.--- The procedure creates @n - 1@ fresh symbolic boolean variables every time it is evaluated, and use--- these variables to conditionally select one of the @n@ provided expressions.------ The result will __/not/__ be wrapped in a union-like monad, but will be--- wrapped in a monad maintaining the 'Fresh' context.------ >>> import Data.Proxy--- >>> runFresh (chooseSimpleFresh [ssym "b", ssym "c", ssym "d"]) "a" :: SymInteger--- (ite a@0 b (ite a@1 c d))-chooseSimpleFresh ::-  forall a m.-  ( SimpleMergeable a,-    MonadFresh m-  ) =>-  [a] ->-  m a-chooseSimpleFresh [x] = return x-chooseSimpleFresh (r : rs) = do-  b :: bool <- simpleFresh ()-  res <- chooseSimpleFresh rs-  return $ mrgIte b r res-chooseSimpleFresh [] = error "chooseSimpleFresh expects at least one value"---- | A wrapper for `chooseSimpleFresh` that executes the `MonadFresh` context.--- A globally unique identifier should be supplied to ensure the uniqueness of--- symbolic constants in the generated symbolic values.-chooseSimple ::-  forall a.-  ( SimpleMergeable a-  ) =>-  [a] ->-  FreshIdent ->-  a-chooseSimple = runFresh . chooseSimpleFresh---- | Symbolically chooses one of the provided values wrapped in union-like--- monads. The procedure creates @n - 1@ fresh symbolic boolean variables every--- time it is evaluated, and use these variables to conditionally select one of--- the @n@ provided expressions.------ 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--- {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)-chooseUnionFresh [x] = return x-chooseUnionFresh (r : rs) = do-  b <- simpleFresh ()-  res <- chooseUnionFresh rs-  return $ mrgIf b r res-chooseUnionFresh [] = error "chooseUnionFresh expects at least one value"---- | A wrapper for `chooseUnionFresh` that executes the `MonadFresh` context.--- A globally unique identifier should be supplied to ensure the uniqueness of--- symbolic constants in the generated symbolic values.-chooseUnion ::-  forall a.-  ( Mergeable a-  ) =>-  [UnionM a] ->-  FreshIdent ->-  UnionM a-chooseUnion = runFresh . chooseUnionFresh--#define CONCRETE_GENSYM_SAME_SHAPE(type) \-instance GenSym type type where fresh = return . mrgSingle--#define CONCRETE_GENSYMSIMPLE_SAME_SHAPE(type) \-instance GenSymSimple type type where simpleFresh = return--#define CONCRETE_GENSYM_SAME_SHAPE_BV(type) \-instance (KnownNat n, 1 <= n) => GenSym (type n) (type n) where fresh = return . mrgSingle--#define CONCRETE_GENSYMSIMPLE_SAME_SHAPE_BV(type) \-instance (KnownNat n, 1 <= n) => GenSymSimple (type n) (type n) where simpleFresh = return--#if 1-CONCRETE_GENSYM_SAME_SHAPE(Bool)-CONCRETE_GENSYM_SAME_SHAPE(Integer)-CONCRETE_GENSYM_SAME_SHAPE(Char)-CONCRETE_GENSYM_SAME_SHAPE(Int)-CONCRETE_GENSYM_SAME_SHAPE(Int8)-CONCRETE_GENSYM_SAME_SHAPE(Int16)-CONCRETE_GENSYM_SAME_SHAPE(Int32)-CONCRETE_GENSYM_SAME_SHAPE(Int64)-CONCRETE_GENSYM_SAME_SHAPE(Word)-CONCRETE_GENSYM_SAME_SHAPE(Word8)-CONCRETE_GENSYM_SAME_SHAPE(Word16)-CONCRETE_GENSYM_SAME_SHAPE(Word32)-CONCRETE_GENSYM_SAME_SHAPE(Word64)-CONCRETE_GENSYM_SAME_SHAPE(SomeWordN)-CONCRETE_GENSYM_SAME_SHAPE(SomeIntN)-CONCRETE_GENSYM_SAME_SHAPE(B.ByteString)-CONCRETE_GENSYM_SAME_SHAPE(T.Text)-CONCRETE_GENSYM_SAME_SHAPE_BV(WordN)-CONCRETE_GENSYM_SAME_SHAPE_BV(IntN)--CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Bool)-CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Integer)-CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Char)-CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Int)-CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Int8)-CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Int16)-CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Int32)-CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Int64)-CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Word)-CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Word8)-CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Word16)-CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Word32)-CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Word64)-CONCRETE_GENSYMSIMPLE_SAME_SHAPE(SomeWordN)-CONCRETE_GENSYMSIMPLE_SAME_SHAPE(SomeIntN)-CONCRETE_GENSYMSIMPLE_SAME_SHAPE(B.ByteString)-CONCRETE_GENSYMSIMPLE_SAME_SHAPE(T.Text)-CONCRETE_GENSYMSIMPLE_SAME_SHAPE_BV(WordN)-CONCRETE_GENSYMSIMPLE_SAME_SHAPE_BV(IntN)-#endif---- Bool-instance GenSym () Bool where-  fresh = derivedNoSpecFresh---- Enums---- | Specification for enum values with upper bound (exclusive). The result would chosen from [0 .. upperbound].------ >>> runFresh (fresh (EnumGenUpperBound @Integer 4)) "c" :: UnionM Integer--- {If c@0 0 (If c@1 1 (If c@2 2 3))}-newtype EnumGenUpperBound a = EnumGenUpperBound a--instance (Enum v, Mergeable v) => GenSym (EnumGenUpperBound v) v where-  fresh (EnumGenUpperBound u) = chooseFresh (toEnum <$> [0 .. fromEnum u - 1])---- | Specification for numbers with lower bound (inclusive) and upper bound (exclusive)------ >>> runFresh (fresh (EnumGenBound @Integer 0 4)) "c" :: UnionM Integer--- {If c@0 0 (If c@1 1 (If c@2 2 3))}-data EnumGenBound a = EnumGenBound a a--instance (Enum v, Mergeable v) => GenSym (EnumGenBound v) v where-  fresh (EnumGenBound l u) = chooseFresh (toEnum <$> [fromEnum l .. fromEnum u - 1])---- Either-instance-  ( GenSym aspec a,-    Mergeable a,-    GenSym bspec b,-    Mergeable b-  ) =>-  GenSym (Either aspec bspec) (Either a b)-  where-  fresh (Left aspec) = (merge . fmap Left) <$> fresh aspec-  fresh (Right bspec) = (merge . fmap Right) <$> fresh bspec--instance-  ( GenSymSimple aspec a,-    GenSymSimple bspec b-  ) =>-  GenSymSimple (Either aspec bspec) (Either a b)-  where-  simpleFresh (Left a) = Left <$> simpleFresh a-  simpleFresh (Right b) = Right <$> simpleFresh b--instance-  (GenSym () a, Mergeable a, GenSym () b, Mergeable b) =>-  GenSym () (Either a b)-  where-  fresh = derivedNoSpecFresh--instance-  ( GenSym aspec a,-    Mergeable a,-    GenSym bspec b,-    Mergeable b-  ) =>-  GenSym (aspec, bspec) (Either a b)-  where-  fresh (aspec, bspec) = do-    l :: UnionM a <- fresh aspec-    r :: UnionM b <- fresh bspec-    chooseUnionFresh [Left <$> l, Right <$> r]---- Maybe-instance-  {-# OVERLAPPING #-}-  (GenSym aspec a, Mergeable a) =>-  GenSym (Maybe aspec) (Maybe a)-  where-  fresh Nothing = return $ mrgSingle Nothing-  fresh (Just aspec) = (merge . fmap Just) <$> fresh aspec--instance-  (GenSymSimple aspec a) =>-  GenSymSimple (Maybe aspec) (Maybe a)-  where-  simpleFresh Nothing = return Nothing-  simpleFresh (Just aspec) = Just <$> simpleFresh aspec--instance-  {-# OVERLAPPABLE #-}-  (GenSym aspec a, Mergeable a) =>-  GenSym aspec (Maybe a)-  where-  fresh aspec = do-    cond <- simpleFresh ()-    a :: UnionM a <- fresh aspec-    return $ mrgIf cond (mrgSingle Nothing) (Just <$> a)---- List-instance-  (GenSym () a, Mergeable a) =>-  GenSym Integer [a]-  where-  fresh v = do-    l <- gl v-    let xs = reverse $ scanr (:) [] l-    chooseUnionFresh $ merge . sequence <$> xs-    where-      gl :: (MonadFresh m) => Integer -> m [UnionM a]-      gl v1-        | v1 <= 0 = return []-        | otherwise = do-            l <- fresh ()-            r <- gl (v1 - 1)-            return $ l : r---- | Specification for list generation.------ >>> runFresh (fresh (ListSpec 0 2 ())) "c" :: UnionM [SymBool]--- {If c@2 [] (If c@3 [c@1] [c@0,c@1])}------ >>> runFresh (fresh (ListSpec 0 2 (SimpleListSpec 1 ()))) "c" :: UnionM [[SymBool]]--- {If c@2 [] (If c@3 [[c@1]] [[c@0],[c@1]])}-data ListSpec spec = ListSpec-  { -- | The minimum length of the generated lists-    genListMinLength :: Int,-    -- | The maximum length of the generated lists-    genListMaxLength :: Int,-    -- | Each element in the lists will be generated with the sub-specification-    genListSubSpec :: spec-  }-  deriving (Show)--instance-  (GenSym spec a, Mergeable a) =>-  GenSym (ListSpec spec) [a]-  where-  fresh (ListSpec minLen maxLen subSpec) =-    if minLen < 0 || maxLen < 0 || minLen >= maxLen-      then error $ "Bad lengths: " ++ show (minLen, maxLen)-      else do-        l <- gl maxLen-        let xs = drop minLen $ reverse $ scanr (:) [] l-        chooseUnionFresh $ merge . sequence <$> xs-    where-      gl :: (MonadFresh m) => Int -> m [UnionM a]-      gl currLen-        | currLen <= 0 = return []-        | otherwise = do-            l <- fresh subSpec-            r <- gl (currLen - 1)-            return $ l : r--instance-  (GenSym a a, Mergeable a) =>-  GenSym [a] [a]-  where-  fresh l = do-    r :: [UnionM a] <- traverse fresh l-    return $ merge $ sequence r--instance-  (GenSymSimple a a) =>-  GenSymSimple [a] [a]-  where-  simpleFresh = derivedSameShapeSimpleFresh---- | Specification for list generation of a specific length.------ >>> runFresh (simpleFresh (SimpleListSpec 2 ())) "c" :: [SymBool]--- [c@0,c@1]-data SimpleListSpec spec = SimpleListSpec-  { -- | The length of the generated list-    genSimpleListLength :: Int,-    -- | Each element in the list will be generated with the sub-specification-    genSimpleListSubSpec :: spec-  }-  deriving (Show)--instance-  (GenSym spec a, Mergeable a) =>-  GenSym (SimpleListSpec spec) [a]-  where-  fresh (SimpleListSpec len subSpec) =-    if len < 0-      then error $ "Bad lengths: " ++ show len-      else do-        merge . sequence <$> gl len-    where-      gl :: (MonadFresh m) => Int -> m [UnionM a]-      gl currLen-        | currLen <= 0 = return []-        | otherwise = do-            l <- fresh subSpec-            r <- gl (currLen - 1)-            return $ l : r--instance-  (GenSymSimple spec a) =>-  GenSymSimple (SimpleListSpec spec) [a]-  where-  simpleFresh (SimpleListSpec len subSpec) =-    if len < 0-      then error $ "Bad lengths: " ++ show len-      else do-        gl len-    where-      gl :: (MonadFresh m) => Int -> m [a]-      gl currLen-        | currLen <= 0 = return []-        | otherwise = do-            l <- simpleFresh subSpec-            r <- gl (currLen - 1)-            return $ l : r---- ()-instance GenSym () ()--instance GenSymSimple () () where-  simpleFresh = derivedNoSpecSimpleFresh---- (,)-instance-  ( GenSym aspec a,-    Mergeable a,-    GenSym bspec b,-    Mergeable b-  ) =>-  GenSym (aspec, bspec) (a, b)-  where-  fresh (aspec, bspec) = do-    a1 <- fresh aspec-    b1 <- fresh bspec-    return $ do-      ax <- a1-      bx <- b1-      mrgSingle (ax, bx)--instance-  ( GenSymSimple aspec a,-    GenSymSimple bspec b-  ) =>-  GenSymSimple (aspec, bspec) (a, b)-  where-  simpleFresh (aspec, bspec) = do-    (,)-      <$> simpleFresh aspec-      <*> simpleFresh bspec--instance-  (GenSym () a, Mergeable a, GenSym () b, Mergeable b) =>-  GenSym () (a, b)-  where-  fresh = derivedNoSpecFresh--instance-  ( GenSymSimple () a,-    GenSymSimple () b-  ) =>-  GenSymSimple () (a, b)-  where-  simpleFresh = derivedNoSpecSimpleFresh---- (,,)-instance-  ( GenSym aspec a,-    Mergeable a,-    GenSym bspec b,-    Mergeable b,-    GenSym cspec c,-    Mergeable c-  ) =>-  GenSym (aspec, bspec, cspec) (a, b, c)-  where-  fresh (aspec, bspec, cspec) = do-    a1 <- fresh aspec-    b1 <- fresh bspec-    c1 <- fresh cspec-    return $ do-      ax <- a1-      bx <- b1-      cx <- c1-      mrgSingle (ax, bx, cx)--instance-  ( GenSymSimple aspec a,-    GenSymSimple bspec b,-    GenSymSimple cspec c-  ) =>-  GenSymSimple (aspec, bspec, cspec) (a, b, c)-  where-  simpleFresh (aspec, bspec, cspec) = do-    (,,)-      <$> simpleFresh aspec-      <*> simpleFresh bspec-      <*> simpleFresh cspec--instance-  ( GenSym () a,-    Mergeable a,-    GenSym () b,-    Mergeable b,-    GenSym () c,-    Mergeable c-  ) =>-  GenSym () (a, b, c)-  where-  fresh = derivedNoSpecFresh--instance-  ( GenSymSimple () a,-    GenSymSimple () b,-    GenSymSimple () c-  ) =>-  GenSymSimple () (a, b, c)-  where-  simpleFresh = derivedNoSpecSimpleFresh---- (,,,)-instance-  ( GenSym aspec a,-    Mergeable a,-    GenSym bspec b,-    Mergeable b,-    GenSym cspec c,-    Mergeable c,-    GenSym dspec d,-    Mergeable d-  ) =>-  GenSym (aspec, bspec, cspec, dspec) (a, b, c, d)-  where-  fresh (aspec, bspec, cspec, dspec) = do-    a1 <- fresh aspec-    b1 <- fresh bspec-    c1 <- fresh cspec-    d1 <- fresh dspec-    return $ do-      ax <- a1-      bx <- b1-      cx <- c1-      dx <- d1-      mrgSingle (ax, bx, cx, dx)--instance-  ( GenSymSimple aspec a,-    GenSymSimple bspec b,-    GenSymSimple cspec c,-    GenSymSimple dspec d-  ) =>-  GenSymSimple (aspec, bspec, cspec, dspec) (a, b, c, d)-  where-  simpleFresh (aspec, bspec, cspec, dspec) = do-    (,,,)-      <$> simpleFresh aspec-      <*> simpleFresh bspec-      <*> simpleFresh cspec-      <*> simpleFresh dspec--instance-  ( GenSym () a,-    Mergeable a,-    GenSym () b,-    Mergeable b,-    GenSym () c,-    Mergeable c,-    GenSym () d,-    Mergeable d-  ) =>-  GenSym () (a, b, c, d)-  where-  fresh = derivedNoSpecFresh--instance-  ( GenSymSimple () a,-    GenSymSimple () b,-    GenSymSimple () c,-    GenSymSimple () d-  ) =>-  GenSymSimple () (a, b, c, d)-  where-  simpleFresh = derivedNoSpecSimpleFresh---- (,,,,)-instance-  ( GenSym aspec a,-    Mergeable a,-    GenSym bspec b,-    Mergeable b,-    GenSym cspec c,-    Mergeable c,-    GenSym dspec d,-    Mergeable d,-    GenSym espec e,-    Mergeable e-  ) =>-  GenSym (aspec, bspec, cspec, dspec, espec) (a, b, c, d, e)-  where-  fresh (aspec, bspec, cspec, dspec, espec) = do-    a1 <- fresh aspec-    b1 <- fresh bspec-    c1 <- fresh cspec-    d1 <- fresh dspec-    e1 <- fresh espec-    return $ do-      ax <- a1-      bx <- b1-      cx <- c1-      dx <- d1-      ex <- e1-      mrgSingle (ax, bx, cx, dx, ex)--instance-  ( GenSymSimple aspec a,-    GenSymSimple bspec b,-    GenSymSimple cspec c,-    GenSymSimple dspec d,-    GenSymSimple espec e-  ) =>-  GenSymSimple (aspec, bspec, cspec, dspec, espec) (a, b, c, d, e)-  where-  simpleFresh (aspec, bspec, cspec, dspec, espec) = do-    (,,,,)-      <$> simpleFresh aspec-      <*> simpleFresh bspec-      <*> simpleFresh cspec-      <*> simpleFresh dspec-      <*> simpleFresh espec--instance-  ( GenSym () a,-    Mergeable a,-    GenSym () b,-    Mergeable b,-    GenSym () c,-    Mergeable c,-    GenSym () d,-    Mergeable d,-    GenSym () e,-    Mergeable e-  ) =>-  GenSym () (a, b, c, d, e)-  where-  fresh = derivedNoSpecFresh--instance-  ( GenSymSimple () a,-    GenSymSimple () b,-    GenSymSimple () c,-    GenSymSimple () d,-    GenSymSimple () e-  ) =>-  GenSymSimple () (a, b, c, d, e)-  where-  simpleFresh = derivedNoSpecSimpleFresh---- (,,,,,)-instance-  ( GenSym aspec a,-    Mergeable a,-    GenSym bspec b,-    Mergeable b,-    GenSym cspec c,-    Mergeable c,-    GenSym dspec d,-    Mergeable d,-    GenSym espec e,-    Mergeable e,-    GenSym fspec f,-    Mergeable f-  ) =>-  GenSym (aspec, bspec, cspec, dspec, espec, fspec) (a, b, c, d, e, f)-  where-  fresh (aspec, bspec, cspec, dspec, espec, fspec) = do-    a1 <- fresh aspec-    b1 <- fresh bspec-    c1 <- fresh cspec-    d1 <- fresh dspec-    e1 <- fresh espec-    f1 <- fresh fspec-    return $ do-      ax <- a1-      bx <- b1-      cx <- c1-      dx <- d1-      ex <- e1-      fx <- f1-      mrgSingle (ax, bx, cx, dx, ex, fx)--instance-  ( GenSymSimple aspec a,-    GenSymSimple bspec b,-    GenSymSimple cspec c,-    GenSymSimple dspec d,-    GenSymSimple espec e,-    GenSymSimple fspec f-  ) =>-  GenSymSimple (aspec, bspec, cspec, dspec, espec, fspec) (a, b, c, d, e, f)-  where-  simpleFresh (aspec, bspec, cspec, dspec, espec, fspec) = do-    (,,,,,)-      <$> simpleFresh aspec-      <*> simpleFresh bspec-      <*> simpleFresh cspec-      <*> simpleFresh dspec-      <*> simpleFresh espec-      <*> simpleFresh fspec--instance-  ( GenSym () a,-    Mergeable a,-    GenSym () b,-    Mergeable b,-    GenSym () c,-    Mergeable c,-    GenSym () d,-    Mergeable d,-    GenSym () e,-    Mergeable e,-    GenSym () f,-    Mergeable f-  ) =>-  GenSym () (a, b, c, d, e, f)-  where-  fresh = derivedNoSpecFresh--instance-  ( GenSymSimple () a,-    GenSymSimple () b,-    GenSymSimple () c,-    GenSymSimple () d,-    GenSymSimple () e,-    GenSymSimple () f-  ) =>-  GenSymSimple () (a, b, c, d, e, f)-  where-  simpleFresh = derivedNoSpecSimpleFresh---- (,,,,,,)-instance-  ( GenSym aspec a,-    Mergeable a,-    GenSym bspec b,-    Mergeable b,-    GenSym cspec c,-    Mergeable c,-    GenSym dspec d,-    Mergeable d,-    GenSym espec e,-    Mergeable e,-    GenSym fspec f,-    Mergeable f,-    GenSym gspec g,-    Mergeable g-  ) =>-  GenSym (aspec, bspec, cspec, dspec, espec, fspec, gspec) (a, b, c, d, e, f, g)-  where-  fresh (aspec, bspec, cspec, dspec, espec, fspec, gspec) = do-    a1 <- fresh aspec-    b1 <- fresh bspec-    c1 <- fresh cspec-    d1 <- fresh dspec-    e1 <- fresh espec-    f1 <- fresh fspec-    g1 <- fresh gspec-    return $ do-      ax <- a1-      bx <- b1-      cx <- c1-      dx <- d1-      ex <- e1-      fx <- f1-      gx <- g1-      mrgSingle (ax, bx, cx, dx, ex, fx, gx)--instance-  ( GenSymSimple aspec a,-    GenSymSimple bspec b,-    GenSymSimple cspec c,-    GenSymSimple dspec d,-    GenSymSimple espec e,-    GenSymSimple fspec f,-    GenSymSimple gspec g-  ) =>-  GenSymSimple (aspec, bspec, cspec, dspec, espec, fspec, gspec) (a, b, c, d, e, f, g)-  where-  simpleFresh (aspec, bspec, cspec, dspec, espec, fspec, gspec) = do-    (,,,,,,)-      <$> simpleFresh aspec-      <*> simpleFresh bspec-      <*> simpleFresh cspec-      <*> simpleFresh dspec-      <*> simpleFresh espec-      <*> simpleFresh fspec-      <*> simpleFresh gspec--instance-  ( GenSym () a,-    Mergeable a,-    GenSym () b,-    Mergeable b,-    GenSym () c,-    Mergeable c,-    GenSym () d,-    Mergeable d,-    GenSym () e,-    Mergeable e,-    GenSym () f,-    Mergeable f,-    GenSym () g,-    Mergeable g-  ) =>-  GenSym () (a, b, c, d, e, f, g)-  where-  fresh = derivedNoSpecFresh--instance-  ( GenSymSimple () a,-    GenSymSimple () b,-    GenSymSimple () c,-    GenSymSimple () d,-    GenSymSimple () e,-    GenSymSimple () f,-    GenSymSimple () g-  ) =>-  GenSymSimple () (a, b, c, d, e, f, g)-  where-  simpleFresh = derivedNoSpecSimpleFresh---- (,,,,,,,)-instance-  ( GenSym aspec a,-    Mergeable a,-    GenSym bspec b,-    Mergeable b,-    GenSym cspec c,-    Mergeable c,-    GenSym dspec d,-    Mergeable d,-    GenSym espec e,-    Mergeable e,-    GenSym fspec f,-    Mergeable f,-    GenSym gspec g,-    Mergeable g,-    GenSym hspec h,-    Mergeable h-  ) =>-  GenSym (aspec, bspec, cspec, dspec, espec, fspec, gspec, hspec) (a, b, c, d, e, f, g, h)-  where-  fresh (aspec, bspec, cspec, dspec, espec, fspec, gspec, hspec) = do-    a1 <- fresh aspec-    b1 <- fresh bspec-    c1 <- fresh cspec-    d1 <- fresh dspec-    e1 <- fresh espec-    f1 <- fresh fspec-    g1 <- fresh gspec-    h1 <- fresh hspec-    return $ do-      ax <- a1-      bx <- b1-      cx <- c1-      dx <- d1-      ex <- e1-      fx <- f1-      gx <- g1-      hx <- h1-      mrgSingle (ax, bx, cx, dx, ex, fx, gx, hx)--instance-  ( GenSymSimple aspec a,-    GenSymSimple bspec b,-    GenSymSimple cspec c,-    GenSymSimple dspec d,-    GenSymSimple espec e,-    GenSymSimple fspec f,-    GenSymSimple gspec g,-    GenSymSimple hspec h-  ) =>-  GenSymSimple (aspec, bspec, cspec, dspec, espec, fspec, gspec, hspec) (a, b, c, d, e, f, g, h)-  where-  simpleFresh (aspec, bspec, cspec, dspec, espec, fspec, gspec, hspec) = do-    (,,,,,,,)-      <$> simpleFresh aspec-      <*> simpleFresh bspec-      <*> simpleFresh cspec-      <*> simpleFresh dspec-      <*> simpleFresh espec-      <*> simpleFresh fspec-      <*> simpleFresh gspec-      <*> simpleFresh hspec--instance-  ( GenSym () a,-    Mergeable a,-    GenSym () b,-    Mergeable b,-    GenSym () c,-    Mergeable c,-    GenSym () d,-    Mergeable d,-    GenSym () e,-    Mergeable e,-    GenSym () f,-    Mergeable f,-    GenSym () g,-    Mergeable g,-    GenSym () h,-    Mergeable h-  ) =>-  GenSym () (a, b, c, d, e, f, g, h)-  where-  fresh = derivedNoSpecFresh--instance-  ( GenSymSimple () a,-    GenSymSimple () b,-    GenSymSimple () c,-    GenSymSimple () d,-    GenSymSimple () e,-    GenSymSimple () f,-    GenSymSimple () g,-    GenSymSimple () h-  ) =>-  GenSymSimple () (a, b, c, d, e, f, g, h)-  where-  simpleFresh = derivedNoSpecSimpleFresh---- MaybeT-instance-  {-# OVERLAPPABLE #-}-  ( GenSym spec (m (Maybe a)),-    Mergeable1 m,-    Mergeable a-  ) =>-  GenSym spec (MaybeT m a)-  where-  fresh v = do-    x <- fresh v-    return $ merge . fmap MaybeT $ x--instance-  {-# OVERLAPPABLE #-}-  ( GenSymSimple spec (m (Maybe a))-  ) =>-  GenSymSimple spec (MaybeT m a)-  where-  simpleFresh v = MaybeT <$> simpleFresh v--instance-  {-# OVERLAPPING #-}-  ( GenSymSimple (m (Maybe a)) (m (Maybe a))-  ) =>-  GenSymSimple (MaybeT m a) (MaybeT m a)-  where-  simpleFresh (MaybeT v) = MaybeT <$> simpleFresh v--instance-  {-# OVERLAPPING #-}-  ( GenSymSimple (m (Maybe a)) (m (Maybe a)),-    Mergeable1 m,-    Mergeable a-  ) =>-  GenSym (MaybeT m a) (MaybeT m a)---- ExceptT-instance-  {-# OVERLAPPABLE #-}-  ( GenSym spec (m (Either a b)),-    Mergeable1 m,-    Mergeable a,-    Mergeable b-  ) =>-  GenSym spec (ExceptT a m b)-  where-  fresh v = do-    x <- fresh v-    return $ merge . fmap ExceptT $ x--instance-  {-# OVERLAPPABLE #-}-  ( GenSymSimple spec (m (Either a b))-  ) =>-  GenSymSimple spec (ExceptT a m b)-  where-  simpleFresh v = ExceptT <$> simpleFresh v--instance-  {-# OVERLAPPING #-}-  ( GenSymSimple (m (Either e a)) (m (Either e a))-  ) =>-  GenSymSimple (ExceptT e m a) (ExceptT e m a)-  where-  simpleFresh (ExceptT v) = ExceptT <$> simpleFresh v--instance-  {-# OVERLAPPING #-}-  ( GenSymSimple (m (Either e a)) (m (Either e a)),-    Mergeable1 m,-    Mergeable e,-    Mergeable a-  ) =>-  GenSym (ExceptT e m a) (ExceptT e m a)--#define GENSYM_SIMPLE(symtype) \-instance GenSym symtype symtype-#define GENSYM_SIMPLE_SIMPLE(symtype) \-instance GenSymSimple symtype symtype where \-  simpleFresh _ = simpleFresh ()-#define GENSYM_UNIT_SIMPLE(symtype) \-instance GenSym () symtype where \-  fresh _ = mrgSingle <$> simpleFresh ()-#define GENSYM_UNIT_SIMPLE_SIMPLE(symtype) \-instance GenSymSimple () symtype where \-  simpleFresh _ = do; \-    ident <- getFreshIdent; \-    FreshIndex i <- nextFreshIndex; \-    case ident of; \-      FreshIdent s -> return $ isym s i; \-      FreshIdentWithInfo s info -> return $ iinfosym s i info--#define GENSYM_BV(symtype) \-instance (KnownNat n, 1 <= n) => GenSym (symtype n) (symtype n)-#define GENSYM_SIMPLE_BV(symtype) \-instance (KnownNat n, 1 <= n) => GenSymSimple (symtype n) (symtype n) where \-  simpleFresh _ = simpleFresh ()-#define GENSYM_UNIT_BV(symtype) \-instance (KnownNat n, 1 <= n) => GenSym () (symtype n) where \-  fresh _ = mrgSingle <$> simpleFresh ()-#define GENSYM_UNIT_SIMPLE_BV(symtype) \-instance (KnownNat n, 1 <= n) => GenSymSimple () (symtype n) where \-  simpleFresh _ = do; \-    ident <- getFreshIdent; \-    FreshIndex i <- nextFreshIndex; \-    case ident of; \-      FreshIdent s -> return $ isym s i; \-      FreshIdentWithInfo s info -> return $ iinfosym s i info--#define GENSYM_BV_SOME(symtype) \-instance GenSym symtype symtype-#define GENSYM_SIMPLE_BV_SOME(symtype) \-instance GenSymSimple symtype symtype where \-  simpleFresh (symtype v) = simpleFresh v-#define GENSYM_N_BV_SOME(symtype) \-instance (KnownNat n, 1 <= n) => GenSym (p n) symtype where \-  fresh p = mrgSingle <$> simpleFresh p-#define GENSYM_N_SIMPLE_BV_SOME(symtype, origtype) \-instance (KnownNat n, 1 <= n) => GenSymSimple (p n) symtype where \-  simpleFresh _ = do; \-    i :: origtype n <- simpleFresh (); \-    return $ symtype i-#define GENSYM_N_INT_BV_SOME(symtype) \-instance GenSym Int symtype where \-  fresh p = mrgSingle <$> simpleFresh p-#define GENSYM_N_INT_SIMPLE_BV_SOME(symtype, origtype) \-instance GenSymSimple Int symtype where \-  simpleFresh i = if i > 0 then f (Proxy @0) else \-    error "Can only generate bit vectors with positive bit size" \-    where \-      f :: forall p (n :: Nat) m. (MonadFresh m) => p n -> m symtype; \-      f _ = case (unsafeKnownProof @n (fromIntegral i), unsafeLeqProof @1 @n) of \-        (KnownProof, LeqProof) -> do \-        v :: origtype n <- simpleFresh (); \-        return $ symtype v; \--#define GENSYM_FUN(op) \-instance (SupportedPrim ca, SupportedPrim cb, LinkedRep ca sa, LinkedRep cb sb) => GenSym (sa op sb) (sa op sb)-#define GENSYM_SIMPLE_FUN(op) \-instance (SupportedPrim ca, SupportedPrim cb, LinkedRep ca sa, LinkedRep cb sb) => GenSymSimple (sa op sb) (sa op sb) where \-  simpleFresh _ = simpleFresh ()-#define GENSYM_UNIT_FUN(op) \-instance (SupportedPrim ca, SupportedPrim cb, LinkedRep ca sa, LinkedRep cb sb) => GenSym () (sa op sb) where \-  fresh _ = mrgSingle <$> simpleFresh ()-#define GENSYM_UNIT_SIMPLE_FUN(op) \-instance (SupportedPrim ca, SupportedPrim cb, LinkedRep ca sa, LinkedRep cb sb) => GenSymSimple () (sa op sb) where \-  simpleFresh _ = do; \-    ident <- getFreshIdent; \-    FreshIndex i <- nextFreshIndex; \-    case ident of; \-      FreshIdent s -> return $ isym s i; \-      FreshIdentWithInfo s info -> return $ iinfosym s i info--#if 1-GENSYM_SIMPLE(SymBool)-GENSYM_SIMPLE_SIMPLE(SymBool)-GENSYM_UNIT_SIMPLE(SymBool)-GENSYM_UNIT_SIMPLE_SIMPLE(SymBool)-GENSYM_SIMPLE(SymInteger)-GENSYM_SIMPLE_SIMPLE(SymInteger)-GENSYM_UNIT_SIMPLE(SymInteger)-GENSYM_UNIT_SIMPLE_SIMPLE(SymInteger)--GENSYM_BV(SymIntN)-GENSYM_SIMPLE_BV(SymIntN)-GENSYM_UNIT_BV(SymIntN)-GENSYM_UNIT_SIMPLE_BV(SymIntN)-GENSYM_BV(SymWordN)-GENSYM_SIMPLE_BV(SymWordN)-GENSYM_UNIT_BV(SymWordN)-GENSYM_UNIT_SIMPLE_BV(SymWordN)--GENSYM_BV_SOME(SomeSymIntN)-GENSYM_SIMPLE_BV_SOME(SomeSymIntN)-GENSYM_N_BV_SOME(SomeSymIntN)-GENSYM_N_SIMPLE_BV_SOME(SomeSymIntN, SymIntN)-GENSYM_N_INT_BV_SOME(SomeSymIntN)-GENSYM_N_INT_SIMPLE_BV_SOME(SomeSymIntN, SymIntN)-GENSYM_BV_SOME(SomeSymWordN)-GENSYM_SIMPLE_BV_SOME(SomeSymWordN)-GENSYM_N_BV_SOME(SomeSymWordN)-GENSYM_N_SIMPLE_BV_SOME(SomeSymWordN, SymWordN)-GENSYM_N_INT_BV_SOME(SomeSymWordN)-GENSYM_N_INT_SIMPLE_BV_SOME(SomeSymWordN, SymWordN)--GENSYM_FUN(=~>)-GENSYM_SIMPLE_FUN(=~>)-GENSYM_UNIT_FUN(=~>)-GENSYM_UNIT_SIMPLE_FUN(=~>)-GENSYM_FUN(-~>)-GENSYM_SIMPLE_FUN(-~>)-GENSYM_UNIT_FUN(-~>)-GENSYM_UNIT_SIMPLE_FUN(-~>)-#endif--instance (GenSym spec a, Mergeable a) => GenSym spec (UnionM a)--instance (GenSym spec a) => GenSymSimple spec (UnionM 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-  where-  fresh spec = go (underlyingUnion $ merge spec)-    where-      go (UnionSingle x) = fresh x-      go (UnionIf _ _ _ t f) = mrgIf <$> simpleFresh () <*> go t <*> go f
− src/Grisette/Core/Data/Class/ITEOp.hs 
@@ -1,88 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}---- |--- Module      :   Grisette.Core.Data.Class.ITEOp--- 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.Core.Data.Class.ITEOp-  ( ITEOp (..),-  )-where--import GHC.TypeNats (KnownNat, type (<=))-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term-  ( LinkedRep,-    SupportedPrim,-  )-import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool (pevalITETerm)-import Grisette.IR.SymPrim.Data.SymPrim-  ( SomeSymIntN,-    SomeSymWordN,-    SymBool (SymBool),-    SymIntN (SymIntN),-    SymInteger (SymInteger),-    SymWordN (SymWordN),-    binSomeSymIntNR1,-    binSomeSymWordNR1,-    type (-~>) (SymGeneralFun),-    type (=~>) (SymTabularFun),-  )---- $setup--- >>> import Grisette.Core--- >>> import Grisette.IR.SymPrim--- >>> :set -XDataKinds--- >>> :set -XBinaryLiterals--- >>> :set -XFlexibleContexts--- >>> :set -XFlexibleInstances--- >>> :set -XFunctionalDependencies---- | ITE operator for solvable (see "Grisette.Core#solvable")s, including symbolic boolean, integer, etc.------ >>> let a = "a" :: SymBool--- >>> let b = "b" :: SymBool--- >>> let c = "c" :: SymBool--- >>> symIte a b c--- (ite a b c)-class ITEOp v where-  symIte :: SymBool -> v -> v -> v---- ITEOp instances-#define ITEOP_SIMPLE(type) \-instance ITEOp type where \-  symIte (SymBool c) (type t) (type f) = type $ pevalITETerm c t f; \-  {-# INLINE symIte #-}--#define ITEOP_BV(type) \-instance (KnownNat n, 1 <= n) => ITEOp (type n) where \-  symIte (SymBool c) (type t) (type f) = type $ pevalITETerm c t f; \-  {-# INLINE symIte #-}--#define ITEOP_BV_SOME(symtype, bf) \-instance ITEOp symtype where \-  symIte c = bf (symIte c) "symIte"; \-  {-# INLINE symIte #-}--#define ITEOP_FUN(op, cons) \-instance (SupportedPrim ca, SupportedPrim cb, LinkedRep ca sa, LinkedRep cb sb) => ITEOp (sa op sb) where \-  symIte (SymBool c) (cons t) (cons f) = cons $ pevalITETerm c t f; \-  {-# INLINE symIte #-}--#if 1-ITEOP_SIMPLE(SymBool)-ITEOP_SIMPLE(SymInteger)-ITEOP_BV(SymIntN)-ITEOP_BV(SymWordN)-ITEOP_BV_SOME(SomeSymIntN, binSomeSymIntNR1)-ITEOP_BV_SOME(SomeSymWordN, binSomeSymWordNR1)-ITEOP_FUN(=~>, SymTabularFun)-ITEOP_FUN(-~>, SymGeneralFun)-#endif
− src/Grisette/Core/Data/Class/LogicalOp.hs 
@@ -1,106 +0,0 @@-module Grisette.Core.Data.Class.LogicalOp-  ( LogicalOp (..),-  )-where--import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool-  ( pevalAndTerm,-    pevalImplyTerm,-    pevalNotTerm,-    pevalOrTerm,-    pevalXorTerm,-  )-import Grisette.IR.SymPrim.Data.SymPrim (SymBool (SymBool))---- $setup--- >>> import Grisette.Core--- >>> import Grisette.IR.SymPrim--- >>> :set -XDataKinds--- >>> :set -XBinaryLiterals--- >>> :set -XFlexibleContexts--- >>> :set -XFlexibleInstances--- >>> :set -XFunctionalDependencies---- | Symbolic logical operators for symbolic booleans.------ >>> let t = con True :: SymBool--- >>> let f = con False :: SymBool--- >>> let a = "a" :: SymBool--- >>> let b = "b" :: SymBool--- >>> t .|| f--- true--- >>> a .|| t--- true--- >>> a .|| f--- a--- >>> a .|| b--- (|| a b)--- >>> t .&& f--- false--- >>> a .&& t--- a--- >>> a .&& f--- false--- >>> a .&& b--- (&& a b)--- >>> symNot t--- false--- >>> symNot f--- true--- >>> symNot a--- (! a)--- >>> t `symXor` f--- true--- >>> t `symXor` t--- false--- >>> a `symXor` t--- (! a)--- >>> a `symXor` f--- a--- >>> a `symXor` b--- (|| (&& (! a) b) (&& a (! b)))-class LogicalOp b where-  -- | Symbolic disjunction-  (.||) :: b -> b -> b-  a .|| b = symNot $ symNot a .&& symNot b-  {-# INLINE (.||) #-}--  infixr 2 .||--  -- | Symbolic conjunction-  (.&&) :: b -> b -> b-  a .&& b = symNot $ symNot a .|| symNot b-  {-# INLINE (.&&) #-}--  infixr 3 .&&--  -- | Symbolic negation-  symNot :: b -> b--  -- | Symbolic exclusive disjunction-  symXor :: b -> b -> b-  a `symXor` b = (a .&& symNot b) .|| (symNot a .&& b)-  {-# INLINE symXor #-}--  -- | Symbolic implication-  symImplies :: b -> b -> b-  a `symImplies` b = symNot a .|| b-  {-# INLINE symImplies #-}--  {-# MINIMAL (.||), symNot | (.&&), symNot #-}---- LogicalOp instances-instance LogicalOp Bool where-  (.||) = (||)-  {-# INLINE (.||) #-}-  (.&&) = (&&)-  {-# INLINE (.&&) #-}-  symNot = not-  {-# INLINE symNot #-}--instance LogicalOp SymBool where-  (SymBool l) .|| (SymBool r) = SymBool $ pevalOrTerm l r-  (SymBool l) .&& (SymBool r) = SymBool $ pevalAndTerm l r-  symNot (SymBool v) = SymBool $ pevalNotTerm v-  (SymBool l) `symXor` (SymBool r) = SymBool $ pevalXorTerm l r-  (SymBool l) `symImplies` (SymBool r) = SymBool $ pevalImplyTerm l r
− src/Grisette/Core/Data/Class/Mergeable.hs 
@@ -1,1091 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DerivingVia #-}-{-# 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.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.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-  ( Proxy (Proxy),-    Typeable,-    eqT,-    type (:~:) (Refl),-  )-import Data.Word (Word16, Word32, Word64, Word8)-import GHC.Natural (Natural)-import GHC.TypeNats (KnownNat, natVal, 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.Core.Control.Exception (AssertionError, VerificationConditions)-import Grisette.Core.Data.BV-  ( BitwidthMismatch,-    IntN (IntN),-    SomeIntN (SomeIntN),-    SomeWordN (SomeWordN),-    WordN (WordN),-  )-import Grisette.Core.Data.Class.ITEOp (ITEOp (symIte))-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term-  ( LinkedRep,-    SupportedPrim,-  )-import Grisette.IR.SymPrim.Data.SymPrim-  ( SomeSymIntN (SomeSymIntN),-    SomeSymWordN (SomeSymWordN),-    SymBool,-    SymIntN,-    SymInteger,-    SymWordN,-    type (-~>),-    type (=~>),-  )-import Grisette.Utils.Parameterized (unsafeAxiom)-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(B.ByteString)-CONCRETE_ORD_MERGEABLE(T.Text)-CONCRETE_ORD_MERGEABLE_BV(WordN)-CONCRETE_ORD_MERGEABLE_BV(IntN)-#endif--instance Mergeable SomeIntN where-  rootStrategy =-    SortedStrategy @Natural-      (\(SomeIntN (_ :: IntN n)) -> natVal (Proxy @n))-      ( \_ ->-          SortedStrategy @Integer-            (\(SomeIntN (IntN i)) -> i)-            (const $ SimpleStrategy $ \_ l _ -> l)-      )--instance Mergeable SomeWordN where-  rootStrategy =-    SortedStrategy @Natural-      (\(SomeWordN (_ :: WordN n)) -> natVal (Proxy @n))-      ( \_ ->-          SortedStrategy @Integer-            (\(SomeWordN (WordN i)) -> i)-            (const $ SimpleStrategy $ \_ l _ -> l)-      )---- ()-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(op) \-instance (SupportedPrim ca, SupportedPrim cb, LinkedRep ca sa, LinkedRep cb sb) => Mergeable (sa op sb) where \-  rootStrategy = SimpleStrategy symIte--#if 1-MERGEABLE_SIMPLE(SymBool)-MERGEABLE_SIMPLE(SymInteger)-MERGEABLE_BV(SymIntN)-MERGEABLE_BV(SymWordN)-MERGEABLE_FUN(=~>)-MERGEABLE_FUN(-~>)-#endif--instance Mergeable SomeSymIntN where-  rootStrategy =-    SortedStrategy @Natural-      (\(SomeSymIntN (_ :: SymIntN n)) -> natVal (Proxy @n))-      ( \_ ->-          SimpleStrategy-            ( \c (SomeSymIntN (l :: SymIntN l)) (SomeSymIntN (r :: SymIntN r)) ->-                case unsafeAxiom @l @r of-                  Refl -> SomeSymIntN $ symIte c l r-            )-      )--instance Mergeable SomeSymWordN where-  rootStrategy =-    SortedStrategy @Natural-      (\(SomeSymWordN (_ :: SymWordN n)) -> natVal (Proxy @n))-      ( \_ ->-          SimpleStrategy-            ( \c (SomeSymWordN (l :: SymWordN l)) (SomeSymWordN (r :: SymWordN r)) ->-                case unsafeAxiom @l @r of-                  Refl -> SomeSymWordN $ symIte c l r-            )-      )---- 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' #-}
− src/Grisette/Core/Data/Class/ModelOps.hs 
@@ -1,170 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE TypeFamilies #-}---- |--- Module      :   Grisette.Core.Data.Class.ModelOps--- 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.Core.Data.Class.ModelOps-  ( -- * Model and symbolic set operations-    SymbolSetOps (..),-    SymbolSetRep (..),-    ModelOps (..),-    ModelRep (..),-  )-where--import Data.Kind (Type)---- $setup--- >>> import Grisette.Core--- >>> import Grisette.IR.SymPrim---- | The operations on symbolic constant sets------ Note that symbolic constants with different types are considered different.------ >>> let aBool = "a" :: TypedSymbol Bool--- >>> let bBool = "b" :: TypedSymbol Bool--- >>> let cBool = "c" :: TypedSymbol Bool--- >>> let aInteger = "a" :: TypedSymbol Integer--- >>> emptySet :: SymbolSet--- SymbolSet {}--- >>> containsSymbol aBool (buildSymbolSet aBool :: SymbolSet)--- True--- >>> containsSymbol bBool (buildSymbolSet aBool :: SymbolSet)--- False--- >>> insertSymbol aBool (buildSymbolSet aBool :: SymbolSet)--- SymbolSet {a :: Bool}--- >>> insertSymbol aInteger (buildSymbolSet aBool :: SymbolSet)--- SymbolSet {a :: Bool, a :: Integer}--- >>> let abSet = buildSymbolSet (aBool, bBool) :: SymbolSet--- >>> let acSet = buildSymbolSet (aBool, cBool) :: SymbolSet--- >>> intersectionSet abSet acSet--- SymbolSet {a :: Bool}--- >>> unionSet abSet acSet--- SymbolSet {a :: Bool, b :: Bool, c :: Bool}--- >>> differenceSet abSet acSet--- SymbolSet {b :: Bool}-class-  (Monoid symbolSet) =>-  SymbolSetOps symbolSet (typedSymbol :: Type -> Type)-    | symbolSet -> typedSymbol-  where-  -- | Construct an empty set-  emptySet :: symbolSet--  -- | Check if the set is empty-  isEmptySet :: symbolSet -> Bool--  -- | Check if the set contains the given symbol-  containsSymbol :: forall a. typedSymbol a -> symbolSet -> Bool--  -- | Insert a symbol into the set-  insertSymbol :: forall a. typedSymbol a -> symbolSet -> symbolSet--  -- | Set intersection-  intersectionSet :: symbolSet -> symbolSet -> symbolSet--  -- | Set union-  unionSet :: symbolSet -> symbolSet -> symbolSet--  -- | Set difference-  differenceSet :: symbolSet -> symbolSet -> symbolSet---- | A type class for building a symbolic constant set manually from a symbolic--- constant set representation------ >>> buildSymbolSet ("a" :: TypedSymbol Bool, "b" :: TypedSymbol Bool) :: SymbolSet--- SymbolSet {a :: Bool, b :: Bool}-class-  (SymbolSetOps symbolSet typedSymbol) =>-  SymbolSetRep rep symbolSet (typedSymbol :: Type -> Type)-  where-  -- | Build a symbolic constant set-  buildSymbolSet :: rep -> symbolSet---- | The operations on Models.------ Note that symbolic constants with different types are considered different.------ >>> let aBool = "a" :: TypedSymbol Bool--- >>> let bBool = "b" :: TypedSymbol Bool--- >>> let cBool = "c" :: TypedSymbol Bool--- >>> let aInteger = "a" :: TypedSymbol Integer--- >>> emptyModel :: Model--- Model {}--- >>> valueOf aBool (buildModel (aBool ::= True) :: Model)--- Just True--- >>> valueOf bBool (buildModel (aBool ::= True) :: Model)--- Nothing--- >>> insertValue bBool False (buildModel (aBool ::= True) :: Model)--- Model {a -> True :: Bool, b -> False :: Bool}--- >>> let abModel = buildModel (aBool ::= True, bBool ::= False) :: Model--- >>> let acSet = buildSymbolSet (aBool, cBool) :: SymbolSet--- >>> exceptFor acSet abModel--- Model {b -> False :: Bool}--- >>> restrictTo acSet abModel--- Model {a -> True :: Bool}--- >>> extendTo acSet abModel--- Model {a -> True :: Bool, b -> False :: Bool, c -> False :: Bool}--- >>> exact acSet abModel--- Model {a -> True :: Bool, c -> False :: Bool}-class-  (SymbolSetOps symbolSet typedSymbol) =>-  ModelOps model symbolSet typedSymbol-    | model -> symbolSet typedSymbol-  where-  -- | Construct an empty model-  emptyModel :: model--  -- | Check if the model is empty-  isEmptyModel :: model -> Bool--  -- | Check if the model contains the given symbol-  modelContains :: typedSymbol a -> model -> Bool--  -- | Extract the assigned value for a given symbolic constant-  valueOf :: typedSymbol t -> model -> Maybe t--  -- | Insert an assignment into the model-  insertValue :: typedSymbol t -> t -> model -> model--  -- | Returns a model that removed all the assignments for the symbolic-  -- constants in the set-  exceptFor :: symbolSet -> model -> model--  -- | Returns a model that removed the assignments for the symbolic constants-  exceptFor' :: typedSymbol t -> model -> model--  -- | Returns a model that only keeps the assignments for the symbolic-  -- constants in the set-  restrictTo :: symbolSet -> model -> model--  -- | Returns a model that extends the assignments for the symbolic constants-  -- in the set by assigning default values to them-  extendTo :: symbolSet -> model -> model--  -- | Returns a model that contains the assignments for exactly the symbolic-  -- constants in the set by removing assignments for the symbolic constants that-  -- are not in the set and add assignments for the missing symbolic constants-  -- by assigning default values to them.-  exact :: symbolSet -> model -> model-  exact s = restrictTo s . extendTo s---- | A type class for building a model manually from a model representation-class ModelRep rep model | rep -> model where-  -- | Build a model-  ---  -- >>> let aBool = "a" :: TypedSymbol Bool-  -- >>> let bBool = "b" :: TypedSymbol Bool-  -- >>> buildModel (aBool ::= True, bBool ::= False) :: Model-  -- Model {a -> True :: Bool, b -> False :: Bool}-  buildModel :: rep -> model
− src/Grisette/Core/Data/Class/SEq.hs 
@@ -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 TypeApplications #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}---- |--- Module      :   Grisette.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.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.Typeable (Proxy (Proxy), type (:~:) (Refl))-import Data.Word (Word16, Word32, Word64, Word8)-import GHC.TypeLits (sameNat)-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.Core.Control.Exception (AssertionError, VerificationConditions)-import Grisette.Core.Data.BV (IntN, SomeIntN, SomeWordN, WordN)-import Grisette.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.&&)))-import Grisette.Core.Data.Class.Solvable (Solvable (con))-import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool (pevalEqvTerm)-import Grisette.IR.SymPrim.Data.SymPrim-  ( SomeSymIntN (SomeSymIntN),-    SomeSymWordN (SomeSymWordN),-    SymBool (SymBool),-    SymIntN (SymIntN),-    SymInteger (SymInteger),-    SymWordN (SymWordN),-  )---- $setup--- >>> import Grisette.Core--- >>> import Grisette.IR.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(B.ByteString)-CONCRETE_SEQ(T.Text)-CONCRETE_SEQ_BV(WordN)-CONCRETE_SEQ_BV(IntN)-CONCRETE_SEQ(SomeWordN)-CONCRETE_SEQ(SomeIntN)-#endif---- 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 $ pevalEqvTerm l r--#define SEQ_BV(symtype) \-instance (KnownNat n, 1 <= n) => SEq (symtype n) where \-  (symtype l) .== (symtype r) = SymBool $ pevalEqvTerm l r--#define SEQ_BV_SOME(somety, origty) \-instance SEq somety where \-  somety (l :: origty l) .== somety (r :: origty r) = \-    (case sameNat (Proxy @l) (Proxy @r) of \-      Just Refl -> l .== r; \-      Nothing -> con False); \-  {-# INLINE (.==) #-}; \-  somety (l :: origty l) ./= somety (r :: origty r) = \-    (case sameNat (Proxy @l) (Proxy @r) of \-      Just Refl -> l ./= r; \-      Nothing -> con True); \-  {-# INLINE (./=) #-}--#if 1-SEQ_SIMPLE(SymBool)-SEQ_SIMPLE(SymInteger)-SEQ_BV(SymIntN)-SEQ_BV(SymWordN)-SEQ_BV_SOME(SomeSymIntN, SymIntN)-SEQ_BV_SOME(SomeSymWordN, SymWordN)-#endif---- 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 (.==) #-}
− src/Grisette/Core/Data/Class/SOrd.hs 
@@ -1,504 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DerivingVia #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}---- |--- Module      :   Grisette.Core.Data.Class.SOrd--- 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.Core.Data.Class.SOrd-  ( -- * Symbolic total order relation-    SOrd (..),-    SOrd' (..),-  )-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.Core.Control.Exception (AssertionError, VerificationConditions)-import Grisette.Core.Control.Monad.UnionM (UnionM, liftToMonadUnion)-import Grisette.Core.Data.BV (IntN, SomeIntN, SomeWordN, WordN)-import Grisette.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.&&), (.||)))-import Grisette.Core.Data.Class.SEq (SEq ((./=), (.==)), SEq' ((..==)))-import Grisette.Core.Data.Class.SimpleMergeable-  ( mrgIf,-    mrgSingle,-    simpleMerge,-  )-import Grisette.Core.Data.Class.Solvable (Solvable (con))-import Grisette.IR.SymPrim.Data.Prim.PartialEval.Num-  ( pevalGeNumTerm,-    pevalGtNumTerm,-    pevalLeNumTerm,-    pevalLtNumTerm,-  )-import Grisette.IR.SymPrim.Data.SymPrim-  ( SomeSymIntN,-    SomeSymWordN,-    SymBool (SymBool),-    SymIntN (SymIntN),-    SymInteger (SymInteger),-    SymWordN (SymWordN),-    binSomeSymIntN,-    binSomeSymWordN,-  )---- $setup--- >>> import Grisette.Core--- >>> import Grisette.IR.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 `UnionLike` 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(SomeWordN)-CONCRETE_SORD(SomeIntN)-CONCRETE_SORD(B.ByteString)-CONCRETE_SORD(T.Text)-CONCRETE_SORD_BV(WordN)-CONCRETE_SORD_BV(IntN)-#endif--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 $ pevalLeNumTerm a b; \-  (symtype a) .< (symtype b) = SymBool $ pevalLtNumTerm a b; \-  (symtype a) .>= (symtype b) = SymBool $ pevalGeNumTerm a b; \-  (symtype a) .> (symtype b) = SymBool $ pevalGtNumTerm 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 $ pevalLeNumTerm a b; \-  (symtype a) .< (symtype b) = SymBool $ pevalLtNumTerm a b; \-  (symtype a) .>= (symtype b) = SymBool $ pevalGeNumTerm a b; \-  (symtype a) .> (symtype b) = SymBool $ pevalGtNumTerm a b; \-  a `symCompare` b = mrgIf \-    (a .< b) \-    (mrgSingle LT) \-    (mrgIf (a .== b) (mrgSingle EQ) (mrgSingle GT))--#define SORD_BV_SOME(somety, bf) \-instance SOrd somety where \-  (.<=) = bf (.<=) ".<="; \-  {-# INLINE (.<=) #-}; \-  (.<) = bf (.<) ".<"; \-  {-# INLINE (.<) #-}; \-  (.>=) = bf (.>=) ".>="; \-  {-# INLINE (.>=) #-}; \-  (.>) = bf (.>) ".>"; \-  {-# INLINE (.>) #-}; \-  symCompare = bf symCompare "symCompare"; \-  {-# INLINE symCompare #-}--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_BV(SymIntN)-SORD_BV(SymWordN)-SORD_BV_SOME(SomeSymIntN, binSomeSymIntN)-SORD_BV_SOME(SomeSymWordN, binSomeSymWordN)-#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) => SOrd (UnionM 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 = liftToMonadUnion $ do-    x1 <- x-    y1 <- 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)
− src/Grisette/Core/Data/Class/SafeDivision.hs 
@@ -1,379 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}---- |--- Module      :   Grisette.Core.Data.Class.SafeDivision--- 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.Core.Data.Class.SafeDivision-  ( ArithException (..),-    SafeDivision (..),-  )-where--import Control.Exception (ArithException (DivideByZero, Overflow, Underflow))-import Control.Monad.Except (MonadError (throwError))-import Data.Int (Int16, Int32, Int64, Int8)-import Data.Typeable (Proxy (Proxy), type (:~:) (Refl))-import Data.Word (Word16, Word32, Word64, Word8)-import GHC.TypeNats (KnownNat, sameNat, type (<=))-import Grisette.Core.Control.Monad.Union (MonadUnion)-import Grisette.Core.Data.BV-  ( BitwidthMismatch (BitwidthMismatch),-    IntN,-    SomeIntN (SomeIntN),-    SomeWordN (SomeWordN),-    WordN,-  )-import Grisette.Core.Data.Class.LogicalOp (LogicalOp ((.&&), (.||)))-import Grisette.Core.Data.Class.Mergeable (Mergeable)-import Grisette.Core.Data.Class.SEq (SEq ((.==)))-import Grisette.Core.Data.Class.SOrd-  ( SOrd ((.<), (.<=), (.>), (.>=)),-  )-import Grisette.Core.Data.Class.SimpleMergeable-  ( merge,-    mrgIf,-    mrgSingle,-  )-import Grisette.Core.Data.Class.Solvable (Solvable (con))-import Grisette.IR.SymPrim.Data.Prim.PartialEval.Integral-  ( pevalDivBoundedIntegralTerm,-    pevalDivIntegralTerm,-    pevalModBoundedIntegralTerm,-    pevalModIntegralTerm,-    pevalQuotBoundedIntegralTerm,-    pevalQuotIntegralTerm,-    pevalRemBoundedIntegralTerm,-    pevalRemIntegralTerm,-  )-import Grisette.IR.SymPrim.Data.SymPrim-  ( SymIntN (SymIntN),-    SymInteger (SymInteger),-    SymWordN (SymWordN),-  )---- $setup--- >>> import Grisette.Core--- >>> import Grisette.IR.SymPrim--- >>> import Control.Monad.Except---- | Safe division with monadic error handling in multi-path--- execution. These procedures throw an exception when the--- divisor is zero. The result should be able to handle errors with--- `MonadError`.-class (SOrd a, Num a, Mergeable a, Mergeable e) => SafeDivision e a | a -> e where-  -- | Safe signed 'div' with monadic error handling in multi-path execution.-  ---  -- >>> safeDiv (ssym "a") (ssym "b") :: ExceptT ArithException UnionM SymInteger-  -- ExceptT {If (= b 0) (Left divide by zero) (Right (div a b))}-  safeDiv :: (MonadError e uf, MonadUnion uf) => a -> a -> uf a-  safeDiv l r = do-    (d, _) <- safeDivMod l r-    mrgSingle d--  -- | Safe signed 'mod' with monadic error handling in multi-path execution.-  ---  -- >>> safeMod (ssym "a") (ssym "b") :: ExceptT ArithException UnionM SymInteger-  -- ExceptT {If (= b 0) (Left divide by zero) (Right (mod a b))}-  safeMod :: (MonadError e uf, MonadUnion uf) => a -> a -> uf a-  safeMod l r = do-    (_, m) <- safeDivMod l r-    mrgSingle m--  -- | Safe signed 'divMod' with monadic error handling in multi-path execution.-  ---  -- >>> safeDivMod (ssym "a") (ssym "b") :: ExceptT ArithException UnionM (SymInteger, SymInteger)-  -- ExceptT {If (= b 0) (Left divide by zero) (Right ((div a b),(mod a b)))}-  safeDivMod :: (MonadError e uf, MonadUnion uf) => a -> a -> uf (a, a)-  safeDivMod l r = do-    d <- safeDiv l r-    m <- safeMod l r-    mrgSingle (d, m)--  -- | Safe signed 'quot' with monadic error handling in multi-path execution.-  safeQuot :: (MonadError e uf, MonadUnion uf) => a -> a -> uf a-  safeQuot l r = do-    (d, m) <- safeDivMod l r-    mrgIf-      ((l .>= 0 .&& r .> 0) .|| (l .<= 0 .&& r .< 0) .|| m .== 0)-      (mrgSingle d)-      (mrgSingle $ d + 1)--  -- | Safe signed 'rem' with monadic error handling in multi-path execution.-  safeRem :: (MonadError e uf, MonadUnion uf) => a -> a -> uf a-  safeRem l r = do-    (_, m) <- safeDivMod l r-    mrgIf-      ((l .>= 0 .&& r .> 0) .|| (l .<= 0 .&& r .< 0) .|| m .== 0)-      (mrgSingle m)-      (mrgSingle $ m - r)--  -- | Safe signed 'quotRem' with monadic error handling in multi-path execution.-  safeQuotRem :: (MonadError e uf, MonadUnion uf) => a -> a -> uf (a, a)-  safeQuotRem l r = do-    (d, m) <- safeDivMod l r-    mrgIf-      ((l .>= 0 .&& r .> 0) .|| (l .<= 0 .&& r .< 0) .|| m .== 0)-      (mrgSingle (d, m))-      (mrgSingle (d + 1, m - r))--  -- | Safe signed 'div' with monadic error handling in multi-path execution.-  -- The error is transformed.-  ---  -- >>> safeDiv' (const ()) (ssym "a") (ssym "b") :: ExceptT () UnionM SymInteger-  -- ExceptT {If (= b 0) (Left ()) (Right (div a b))}-  safeDiv' :: (MonadError e' uf, MonadUnion uf, Mergeable e') => (e -> e') -> a -> a -> uf a-  safeDiv' t l r = do-    (d, _) <- safeDivMod' t l r-    mrgSingle d--  -- | Safe signed 'mod' with monadic error handling in multi-path execution.-  -- The error is transformed.-  ---  -- >>> safeMod' (const ()) (ssym "a") (ssym "b") :: ExceptT () UnionM SymInteger-  -- ExceptT {If (= b 0) (Left ()) (Right (mod a b))}-  safeMod' :: (MonadError e' uf, MonadUnion uf, Mergeable e') => (e -> e') -> a -> a -> uf a-  safeMod' t l r = do-    (_, m) <- safeDivMod' t l r-    mrgSingle m--  -- | Safe signed 'divMod' with monadic error handling in multi-path execution.-  -- The error is transformed.-  ---  -- >>> safeDivMod' (const ()) (ssym "a") (ssym "b") :: ExceptT () UnionM (SymInteger, SymInteger)-  -- ExceptT {If (= b 0) (Left ()) (Right ((div a b),(mod a b)))}-  safeDivMod' :: (MonadError e' uf, MonadUnion uf, Mergeable e') => (e -> e') -> a -> a -> uf (a, a)-  safeDivMod' t l r = do-    d <- safeDiv' t l r-    m <- safeMod' t l r-    mrgSingle (d, m)--  -- | Safe signed 'quot' with monadic error handling in multi-path execution.-  -- The error is transformed.-  safeQuot' :: (MonadError e' uf, MonadUnion uf, Mergeable e') => (e -> e') -> a -> a -> uf a-  safeQuot' t l r = do-    (d, m) <- safeDivMod' t l r-    mrgIf-      ((l .>= 0 .&& r .> 0) .|| (l .<= 0 .&& r .< 0) .|| m .== 0)-      (mrgSingle d)-      (mrgSingle $ d + 1)--  -- | Safe signed 'rem' with monadic error handling in multi-path execution.-  -- The error is transformed.-  safeRem' :: (MonadError e' uf, MonadUnion uf, Mergeable e') => (e -> e') -> a -> a -> uf a-  safeRem' t l r = do-    (_, m) <- safeDivMod' t l r-    mrgIf-      ((l .>= 0 .&& r .> 0) .|| (l .<= 0 .&& r .< 0) .|| m .== 0)-      (mrgSingle m)-      (mrgSingle $ m - r)--  -- | Safe signed 'quotRem' with monadic error handling in multi-path execution.-  -- The error is transformed.-  safeQuotRem' :: (MonadError e' uf, MonadUnion uf, Mergeable e') => (e -> e') -> a -> a -> uf (a, a)-  safeQuotRem' t l r = do-    (d, m) <- safeDivMod' t l r-    mrgIf-      ((l .>= 0 .&& r .> 0) .|| (l .<= 0 .&& r .< 0) .|| m .== 0)-      (mrgSingle (d, m))-      (mrgSingle (d + 1, m - r))--  {-# MINIMAL (safeDivMod | (safeDiv, safeMod)), (safeDivMod' | (safeDiv', safeMod')) #-}--#define QUOTE() '-#define QID(a) a-#define QRIGHT(a) QID(a)'--#define QRIGHTT(a) QID(a)' t'-#define QRIGHTU(a) QID(a)' _'--#define SAFE_DIVISION_CONCRETE_FUNC(name, op) \-name _ r | r == 0 = merge $ throwError DivideByZero; \-name l r = mrgSingle $ l `op` r; \-QRIGHTT(name) _ r | r == 0 = let _ = t' in merge $ throwError (t' DivideByZero); \-QRIGHTU(name) l r = mrgSingle $ l `op` r--#define SAFE_DIVISION_CONCRETE(type) \-instance SafeDivision ArithException type where \-  SAFE_DIVISION_CONCRETE_FUNC(safeDiv, div); \-  SAFE_DIVISION_CONCRETE_FUNC(safeMod, mod); \-  SAFE_DIVISION_CONCRETE_FUNC(safeDivMod, divMod); \-  SAFE_DIVISION_CONCRETE_FUNC(safeQuot, quot); \-  SAFE_DIVISION_CONCRETE_FUNC(safeRem, rem); \-  SAFE_DIVISION_CONCRETE_FUNC(safeQuotRem, quotRem)--#define SAFE_DIVISION_CONCRETE_BV(type) \-instance (KnownNat n, 1 <= n) => SafeDivision ArithException (type n) where \-  SAFE_DIVISION_CONCRETE_FUNC(safeDiv, div); \-  SAFE_DIVISION_CONCRETE_FUNC(safeMod, mod); \-  SAFE_DIVISION_CONCRETE_FUNC(safeDivMod, divMod); \-  SAFE_DIVISION_CONCRETE_FUNC(safeQuot, quot); \-  SAFE_DIVISION_CONCRETE_FUNC(safeRem, rem); \-  SAFE_DIVISION_CONCRETE_FUNC(safeQuotRem, quotRem)--#if 1-SAFE_DIVISION_CONCRETE(Integer)-SAFE_DIVISION_CONCRETE(Int8)-SAFE_DIVISION_CONCRETE(Int16)-SAFE_DIVISION_CONCRETE(Int32)-SAFE_DIVISION_CONCRETE(Int64)-SAFE_DIVISION_CONCRETE(Int)-SAFE_DIVISION_CONCRETE(Word8)-SAFE_DIVISION_CONCRETE(Word16)-SAFE_DIVISION_CONCRETE(Word32)-SAFE_DIVISION_CONCRETE(Word64)-SAFE_DIVISION_CONCRETE(Word)-#endif--#define SAFE_DIVISION_CONCRETE_FUNC_SOME(stype, type, name, op) \-  name (stype (l :: type l)) (stype (r :: type r)) = \-    (case sameNat (Proxy @l) (Proxy @r) of \-      Just Refl -> \-        if r == 0 \-          then merge $ throwError $ Right DivideByZero \-          else mrgSingle $ stype $ l `op` r; \-      Nothing -> merge $ throwError $ Left BitwidthMismatch); \-  QRIGHT(name) t (stype (l :: type l)) (stype (r :: type r)) = \-    (case sameNat (Proxy @l) (Proxy @r) of \-      Just Refl -> \-        if r == 0 \-          then merge $ throwError $ t (Right DivideByZero) \-          else mrgSingle $ stype $ l `op` r; \-      Nothing -> merge $ throwError $ t (Left BitwidthMismatch))--#define SAFE_DIVISION_CONCRETE_FUNC_SOME_DIVMOD(stype, type, name, op) \-  name (stype (l :: type l)) (stype (r :: type r)) = \-    (case sameNat (Proxy @l) (Proxy @r) of \-      Just Refl -> \-        if r == 0 \-          then merge $ throwError $ Right DivideByZero \-          else (case l `op` r of (d, m) -> mrgSingle (stype d, stype m)); \-      Nothing -> merge $ throwError $ Left BitwidthMismatch); \-  QRIGHT(name) t (stype (l :: type l)) (stype (r :: type r)) = \-    (case sameNat (Proxy @l) (Proxy @r) of \-      Just Refl -> \-        if r == 0 \-          then merge $ throwError $ t (Right DivideByZero) \-          else (case l `op` r of (d, m) -> mrgSingle (stype d, stype m)); \-      Nothing -> merge $ throwError $ t (Left BitwidthMismatch))--#if 1-SAFE_DIVISION_CONCRETE_BV(IntN)-SAFE_DIVISION_CONCRETE_BV(WordN)-instance SafeDivision (Either BitwidthMismatch ArithException) SomeIntN where-  SAFE_DIVISION_CONCRETE_FUNC_SOME(SomeIntN, IntN, safeDiv, div)-  SAFE_DIVISION_CONCRETE_FUNC_SOME(SomeIntN, IntN, safeMod, mod)-  SAFE_DIVISION_CONCRETE_FUNC_SOME_DIVMOD(SomeIntN, IntN, safeDivMod, divMod)-  SAFE_DIVISION_CONCRETE_FUNC_SOME(SomeIntN, IntN, safeQuot, quot)-  SAFE_DIVISION_CONCRETE_FUNC_SOME(SomeIntN, IntN, safeRem, rem)-  SAFE_DIVISION_CONCRETE_FUNC_SOME_DIVMOD(SomeIntN, IntN, safeQuotRem, quotRem)--instance SafeDivision (Either BitwidthMismatch ArithException) SomeWordN where-  SAFE_DIVISION_CONCRETE_FUNC_SOME(SomeWordN, WordN, safeDiv, div)-  SAFE_DIVISION_CONCRETE_FUNC_SOME(SomeWordN, WordN, safeMod, mod)-  SAFE_DIVISION_CONCRETE_FUNC_SOME_DIVMOD(SomeWordN, WordN, safeDivMod, divMod)-  SAFE_DIVISION_CONCRETE_FUNC_SOME(SomeWordN, WordN, safeQuot, quot)-  SAFE_DIVISION_CONCRETE_FUNC_SOME(SomeWordN, WordN, safeRem, rem)-  SAFE_DIVISION_CONCRETE_FUNC_SOME_DIVMOD(SomeWordN, WordN, safeQuotRem, quotRem)-#endif--#define SAFE_DIVISION_SYMBOLIC_FUNC(name, type, op) \-name (type l) rs@(type r) = \-  mrgIf \-    (rs .== con 0) \-    (throwError DivideByZero) \-    (mrgSingle $ type $ op l r); \-QRIGHT(name) t (type l) rs@(type r) = \-  mrgIf \-    (rs .== con 0) \-    (throwError (t DivideByZero)) \-    (mrgSingle $ type $ op l r)--#define SAFE_DIVISION_SYMBOLIC_FUNC2(name, type, op1, op2) \-name (type l) rs@(type r) = \-  mrgIf \-    (rs .== con 0) \-    (throwError DivideByZero) \-    (mrgSingle (type $ op1 l r, type $ op2 l r)); \-QRIGHT(name) t (type l) rs@(type r) = \-  mrgIf \-    (rs .== con 0) \-    (throwError (t DivideByZero)) \-    (mrgSingle (type $ op1 l r, type $ op2 l r))--#if 1-instance SafeDivision ArithException SymInteger where-  SAFE_DIVISION_SYMBOLIC_FUNC(safeDiv, SymInteger, pevalDivIntegralTerm)-  SAFE_DIVISION_SYMBOLIC_FUNC(safeMod, SymInteger, pevalModIntegralTerm)-  SAFE_DIVISION_SYMBOLIC_FUNC(safeQuot, SymInteger, pevalQuotIntegralTerm)-  SAFE_DIVISION_SYMBOLIC_FUNC(safeRem, SymInteger, pevalRemIntegralTerm)-  SAFE_DIVISION_SYMBOLIC_FUNC2(safeDivMod, SymInteger, pevalDivIntegralTerm, pevalModIntegralTerm)-  SAFE_DIVISION_SYMBOLIC_FUNC2(safeQuotRem, SymInteger, pevalQuotIntegralTerm, pevalRemIntegralTerm)-#endif--#define SAFE_DIVISION_SYMBOLIC_FUNC_BOUNDED_SIGNED(name, type, op) \-name ls@(type l) rs@(type r) = \-  mrgIf \-    (rs .== con 0) \-    (throwError DivideByZero) \-    (mrgIf (rs .== con (-1) .&& ls .== con minBound) \-      (throwError Overflow) \-      (mrgSingle $ type $ op l r)); \-QRIGHT(name) t ls@(type l) rs@(type r) = \-  mrgIf \-    (rs .== con 0) \-    (throwError (t DivideByZero)) \-    (mrgIf (rs .== con (-1) .&& ls .== con minBound) \-      (throwError (t Overflow)) \-      (mrgSingle $ type $ op l r))--#define SAFE_DIVISION_SYMBOLIC_FUNC2_BOUNDED_SIGNED(name, type, op1, op2) \-name ls@(type l) rs@(type r) = \-  mrgIf \-    (rs .== con 0) \-    (throwError DivideByZero) \-    (mrgIf (rs .== con (-1) .&& ls .== con minBound) \-      (throwError Overflow) \-      (mrgSingle (type $ op1 l r, type $ op2 l r))); \-QRIGHT(name) t ls@(type l) rs@(type r) = \-  mrgIf \-    (rs .== con 0) \-    (throwError (t DivideByZero)) \-    (mrgIf (rs .== con (-1) .&& ls .== con minBound) \-      (throwError (t Overflow)) \-      (mrgSingle (type $ op1 l r, type $ op2 l r)))--#if 1-instance (KnownNat n, 1 <= n) => SafeDivision ArithException (SymIntN n) where-  SAFE_DIVISION_SYMBOLIC_FUNC_BOUNDED_SIGNED(safeDiv, SymIntN, pevalDivBoundedIntegralTerm)-  SAFE_DIVISION_SYMBOLIC_FUNC(safeMod, SymIntN, pevalModBoundedIntegralTerm)-  SAFE_DIVISION_SYMBOLIC_FUNC_BOUNDED_SIGNED(safeQuot, SymIntN, pevalQuotBoundedIntegralTerm)-  SAFE_DIVISION_SYMBOLIC_FUNC(safeRem, SymIntN, pevalRemBoundedIntegralTerm)-  SAFE_DIVISION_SYMBOLIC_FUNC2_BOUNDED_SIGNED(safeDivMod, SymIntN, pevalDivBoundedIntegralTerm, pevalModBoundedIntegralTerm)-  SAFE_DIVISION_SYMBOLIC_FUNC2_BOUNDED_SIGNED(safeQuotRem, SymIntN, pevalQuotBoundedIntegralTerm, pevalRemBoundedIntegralTerm)-#endif--#if 1-instance (KnownNat n, 1 <= n) => SafeDivision ArithException (SymWordN n) where-  SAFE_DIVISION_SYMBOLIC_FUNC(safeDiv, SymWordN, pevalDivIntegralTerm)-  SAFE_DIVISION_SYMBOLIC_FUNC(safeMod, SymWordN, pevalModIntegralTerm)-  SAFE_DIVISION_SYMBOLIC_FUNC(safeQuot, SymWordN, pevalQuotIntegralTerm)-  SAFE_DIVISION_SYMBOLIC_FUNC(safeRem, SymWordN, pevalRemIntegralTerm)-  SAFE_DIVISION_SYMBOLIC_FUNC2(safeDivMod, SymWordN, pevalDivIntegralTerm, pevalModIntegralTerm)-  SAFE_DIVISION_SYMBOLIC_FUNC2(safeQuotRem, SymWordN, pevalQuotIntegralTerm, pevalRemIntegralTerm)-#endif
− src/Grisette/Core/Data/Class/SafeLinearArith.hs 
@@ -1,307 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}---- |--- Module      :   Grisette.Core.Data.Class.SafeLinearArith--- 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.Core.Data.Class.SafeLinearArith-  ( ArithException (..),-    SafeLinearArith (..),-  )-where--import Control.Exception (ArithException (DivideByZero, Overflow, Underflow))-import Control.Monad.Except (MonadError (throwError))-import Data.Int (Int16, Int32, Int64, Int8)-import Data.Typeable (Proxy (Proxy), type (:~:) (Refl))-import Data.Word (Word16, Word32, Word64, Word8)-import GHC.TypeNats (KnownNat, sameNat, type (<=))-import Grisette.Core.Control.Monad.Union (MonadUnion)-import Grisette.Core.Data.BV-  ( BitwidthMismatch (BitwidthMismatch),-    IntN,-    SomeIntN (SomeIntN),-    SomeWordN (SomeWordN),-    WordN,-  )-import Grisette.Core.Data.Class.LogicalOp-  ( LogicalOp ((.&&), (.||)),-  )-import Grisette.Core.Data.Class.Mergeable (Mergeable)-import Grisette.Core.Data.Class.SEq (SEq ((./=), (.==)))-import Grisette.Core.Data.Class.SOrd (SOrd ((.<), (.>), (.>=)))-import Grisette.Core.Data.Class.SimpleMergeable-  ( merge,-    mrgIf,-    mrgSingle,-  )-import Grisette.Core.Data.Class.Solvable (Solvable (con))-import Grisette.IR.SymPrim.Data.SymPrim-  ( SymIntN,-    SymInteger,-    SymWordN,-  )---- $setup--- >>> import Grisette.Core--- >>> import Grisette.IR.SymPrim--- >>> import Control.Monad.Except---- | Safe division with monadic error handling in multi-path--- execution. These procedures throw an exception when overflow or underflow happens.--- The result should be able to handle errors with `MonadError`.-class (SOrd a, Num a, Mergeable a, Mergeable e) => SafeLinearArith e a | a -> e where-  -- | 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-  -- ExceptT {Right (+ a b)}-  -- >>> safeAdd (ssym "a") (ssym "b") :: ExceptT ArithException UnionM (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 :: (MonadError e uf, MonadUnion uf) => a -> a -> uf 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-  -- ExceptT {Right (- a)}-  -- >>> safeNeg (ssym "a") :: ExceptT ArithException UnionM (SymIntN 4)-  -- ExceptT {If (= a 0x8) (Left arithmetic overflow) (Right (- a))}-  safeNeg :: (MonadError e uf, MonadUnion uf) => a -> uf a--  -- | Safe '-' with monadic error handling in multi-path execution.-  -- Overflows or underflows are treated as errors.-  ---  -- >>> safeMinus (ssym "a") (ssym "b") :: ExceptT ArithException UnionM SymInteger-  -- ExceptT {Right (+ a (- b))}-  -- >>> safeMinus (ssym "a") (ssym "b") :: ExceptT ArithException UnionM (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)))}-  safeMinus :: (MonadError e uf, MonadUnion uf) => a -> a -> uf a--  -- | Safe '+' with monadic error handling in multi-path execution.-  -- Overflows or underflows are treated as errors.-  -- The error is transformed.-  safeAdd' :: (MonadError e' uf, MonadUnion uf, Mergeable e') => (e -> e') -> a -> a -> uf a--  -- | Safe 'negate' with monadic error handling in multi-path execution.-  -- Overflows or underflows are treated as errors.-  -- The error is transformed.-  safeNeg' :: (MonadError e' uf, MonadUnion uf, Mergeable e') => (e -> e') -> a -> uf a--  -- | Safe '-' with monadic error handling in multi-path execution.-  -- Overflows or underflows are treated as errors.-  -- The error is transformed.-  safeMinus' :: (MonadError e' uf, MonadUnion uf, Mergeable e') => (e -> e') -> a -> a -> uf a--instance SafeLinearArith ArithException Integer where-  safeAdd l r = mrgSingle (l + r)-  safeNeg l = mrgSingle (-l)-  safeMinus l r = mrgSingle (l - r)-  safeAdd' _ l r = mrgSingle (l + r)-  safeNeg' _ l = mrgSingle (-l)-  safeMinus' _ l r = mrgSingle (l - r)--#define SAFE_LINARITH_SIGNED_CONCRETE_BODY \-  safeAdd l r = let res = l + r in \-    mrgIf (con $ l > 0 && r > 0 && res < 0) \-          (throwError Overflow) \-          (mrgIf (con $ l < 0 && r < 0 && res >= 0) \-                 (throwError Underflow) \-                 (return res));\-  safeAdd' t' l r = let res = l + r in \-    mrgIf (con $ l > 0 && r > 0 && res < 0) \-          (throwError (t' Overflow)) \-          (mrgIf (con $ l < 0 && r < 0 && res >= 0) \-                 (throwError (t' Underflow)) \-                 (return res)); \-  safeMinus l r = let res = l - r in \-    mrgIf (con $ l >= 0 && r < 0 && res < 0) \-          (throwError Overflow) \-          (mrgIf (con $ l < 0 && r > 0 && res > 0) \-                 (throwError Underflow) \-                 (return res));\-  safeMinus' t' l r = let res = l - r in \-    mrgIf (con $ l >= 0 && r < 0 && res < 0) \-          (throwError (t' Overflow)) \-          (mrgIf (con $ l < 0 && r > 0 && res > 0) \-                 (throwError (t' Underflow)) \-                 (return res)); \-  safeNeg v = mrgIf (con $ v == minBound) (throwError Overflow) (return $ -v);\-  safeNeg' t' v = mrgIf (con $ v == minBound) (throwError (t' Overflow)) (return $ -v)--#define SAFE_LINARITH_SIGNED_CONCRETE(type) \-instance SafeLinearArith ArithException type where \-  SAFE_LINARITH_SIGNED_CONCRETE_BODY--#define SAFE_LINARITH_SIGNED_BV_CONCRETE(type) \-instance (KnownNat n, 1 <= n) => SafeLinearArith ArithException (type n) where \-  SAFE_LINARITH_SIGNED_CONCRETE_BODY--#define SAFE_LINARITH_UNSIGNED_CONCRETE_BODY \-  safeAdd l r = let res = l + r in \-    mrgIf (con $ l > res || r > res) \-          (throwError Overflow) \-          (return res);\-  safeAdd' t' l r = let res = l + r in \-    mrgIf (con $ l > res || r > res) \-          (throwError (t' Overflow)) \-          (return res); \-  safeMinus l r = \-    mrgIf (con $ r > l) \-          (throwError Underflow) \-          (return $ l - r);\-  safeMinus' t' l r = \-    mrgIf (con $ r > l) \-          (throwError $ t' Underflow) \-          (return $ l - r);\-  safeNeg v = mrgIf (con $ v /= 0) (throwError Underflow) (return $ -v);\-  safeNeg' t' v = mrgIf (con $ v /= 0) (throwError (t' Underflow)) (return $ -v)--#define SAFE_LINARITH_UNSIGNED_CONCRETE(type) \-instance SafeLinearArith ArithException type where \-  SAFE_LINARITH_UNSIGNED_CONCRETE_BODY--#define SAFE_LINARITH_UNSIGNED_BV_CONCRETE(type) \-instance (KnownNat n, 1 <= n) => SafeLinearArith ArithException (type n) where \-  SAFE_LINARITH_UNSIGNED_CONCRETE_BODY--#define SAFE_LINARITH_SOME_CONCRETE(type, ctype) \-instance SafeLinearArith (Either BitwidthMismatch ArithException) type where \-  safeAdd (type (l :: ctype l)) (type (r :: ctype r)) = merge (\-    case sameNat (Proxy @l) (Proxy @r) of \-      Just Refl -> type <$> safeAdd' Right l r; \-      _ -> throwError $ Left BitwidthMismatch); \-  safeAdd' t (type (l :: ctype l)) (type (r :: ctype r)) = merge (\-    case sameNat (Proxy @l) (Proxy @r) of \-      Just Refl -> type <$> safeAdd' (t . Right) l r; \-      _ -> let t' = t; _ = t' in throwError $ t' $ Left BitwidthMismatch); \-  safeMinus (type (l :: ctype l)) (type (r :: ctype r)) = merge (\-    case sameNat (Proxy @l) (Proxy @r) of \-      Just Refl -> type <$> safeMinus' Right l r; \-      _ -> throwError $ Left BitwidthMismatch); \-  safeMinus' t (type (l :: ctype l)) (type (r :: ctype r)) = merge (\-    case sameNat (Proxy @l) (Proxy @r) of \-      Just Refl -> type <$> safeMinus' (t . Right) l r; \-      _ -> let t' = t; _ = t' in throwError $ t' $ Left BitwidthMismatch); \-  safeNeg (type l) = merge $ type <$> safeNeg' Right l; \-  safeNeg' t (type l) = merge $ type <$> safeNeg' (t . Right) l--#if 1-SAFE_LINARITH_SIGNED_CONCRETE(Int8)-SAFE_LINARITH_SIGNED_CONCRETE(Int16)-SAFE_LINARITH_SIGNED_CONCRETE(Int32)-SAFE_LINARITH_SIGNED_CONCRETE(Int64)-SAFE_LINARITH_SIGNED_CONCRETE(Int)-SAFE_LINARITH_SIGNED_BV_CONCRETE(IntN)-SAFE_LINARITH_SOME_CONCRETE(SomeIntN, IntN)-SAFE_LINARITH_UNSIGNED_CONCRETE(Word8)-SAFE_LINARITH_UNSIGNED_CONCRETE(Word16)-SAFE_LINARITH_UNSIGNED_CONCRETE(Word32)-SAFE_LINARITH_UNSIGNED_CONCRETE(Word64)-SAFE_LINARITH_UNSIGNED_CONCRETE(Word)-SAFE_LINARITH_UNSIGNED_BV_CONCRETE(WordN)-SAFE_LINARITH_SOME_CONCRETE(SomeWordN, WordN)-#endif--instance SafeLinearArith ArithException SymInteger where-  safeAdd ls rs = mrgSingle $ ls + rs-  safeAdd' _ ls rs = mrgSingle $ ls + rs-  safeNeg v = mrgSingle $ -v-  safeNeg' _ v = mrgSingle $ -v-  safeMinus ls rs = mrgSingle $ ls - rs-  safeMinus' _ ls rs = mrgSingle $ ls - rs--instance (KnownNat n, 1 <= n) => SafeLinearArith ArithException (SymIntN n) where-  safeAdd ls rs =-    mrgIf-      (ls .> 0)-      (mrgIf (rs .> 0 .&& res .< 0) (throwError Overflow) (return res))-      ( mrgIf-          (ls .< 0 .&& rs .< 0 .&& res .>= 0)-          (throwError Underflow)-          (mrgSingle res)-      )-    where-      res = ls + rs-  safeAdd' f ls rs =-    mrgIf-      (ls .> 0)-      (mrgIf (rs .> 0 .&& res .< 0) (throwError $ f Overflow) (return res))-      ( mrgIf-          (ls .< 0 .&& rs .< 0 .&& res .>= 0)-          (throwError $ f Underflow)-          (mrgSingle res)-      )-    where-      res = ls + rs-  safeNeg v = mrgIf (v .== con minBound) (throwError Overflow) (mrgSingle $ -v)-  safeNeg' f v = mrgIf (v .== con minBound) (throwError $ f Overflow) (mrgSingle $ -v)-  safeMinus ls rs =-    mrgIf-      (ls .>= 0)-      (mrgIf (rs .< 0 .&& res .< 0) (throwError Overflow) (return res))-      ( mrgIf-          (ls .< 0 .&& rs .> 0 .&& res .> 0)-          (throwError Underflow)-          (mrgSingle res)-      )-    where-      res = ls - rs-  safeMinus' f ls rs =-    mrgIf-      (ls .>= 0)-      (mrgIf (rs .< 0 .&& res .< 0) (throwError $ f Overflow) (return res))-      ( mrgIf-          (ls .< 0 .&& rs .> 0 .&& res .> 0)-          (throwError $ f Underflow)-          (mrgSingle res)-      )-    where-      res = ls - rs--instance (KnownNat n, 1 <= n) => SafeLinearArith ArithException (SymWordN n) where-  safeAdd ls rs =-    mrgIf-      (ls .> res .|| rs .> res)-      (throwError Overflow)-      (mrgSingle res)-    where-      res = ls + rs-  safeAdd' f ls rs =-    mrgIf-      (ls .> res .|| rs .> res)-      (throwError $ f Overflow)-      (mrgSingle res)-    where-      res = ls + rs-  safeNeg v = mrgIf (v ./= 0) (throwError Underflow) (mrgSingle v)-  safeNeg' f v = mrgIf (v ./= 0) (throwError $ f Underflow) (mrgSingle v)-  safeMinus ls rs =-    mrgIf-      (rs .> ls)-      (throwError Underflow)-      (mrgSingle res)-    where-      res = ls - rs-  safeMinus' f ls rs =-    mrgIf-      (rs .> ls)-      (throwError $ f Underflow)-      (mrgSingle res)-    where-      res = ls - rs
− src/Grisette/Core/Data/Class/SafeSymRotate.hs 
@@ -1,110 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}--module Grisette.Core.Data.Class.SafeSymRotate (SafeSymRotate (..)) where--import Control.Exception (ArithException (Overflow))-import Control.Monad.Error.Class (MonadError)-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.Core.Control.Monad.Union (MonadUnion)-import Grisette.Core.Data.BV (IntN, WordN)-import Grisette.Core.Data.Class.Mergeable (Mergeable)-import Grisette.Core.Data.Class.SOrd (SOrd ((.<)))-import Grisette.Core.Data.Class.SimpleMergeable (UnionLike, mrgIf)-import Grisette.Core.Data.Class.SymRotate (SymRotate)-import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bits-  ( pevalRotateLeftTerm,-    pevalRotateRightTerm,-  )-import Grisette.IR.SymPrim.Data.SymPrim-  ( SymIntN (SymIntN),-    SymWordN (SymWordN),-  )-import Grisette.Lib.Control.Monad (mrgReturn)-import Grisette.Lib.Control.Monad.Except (mrgThrowError)--class (SymRotate a) => SafeSymRotate e a | a -> e where-  safeSymRotateL :: (MonadError e m, UnionLike m) => a -> a -> m a-  safeSymRotateL = safeSymRotateL' id-  safeSymRotateR :: (MonadError e m, UnionLike m) => a -> a -> m a-  safeSymRotateR = safeSymRotateR' id-  safeSymRotateL' ::-    (MonadError e' m, UnionLike m) => (e -> e') -> a -> a -> m a-  safeSymRotateR' ::-    (MonadError e' m, UnionLike m) => (e -> e') -> a -> a -> m a-  {-# MINIMAL safeSymRotateL', safeSymRotateR' #-}---- | This function handles the case when the shift amount is out the range of--- `Int` correctly.-safeSymRotateLConcreteNum ::-  (MonadError e m, MonadUnion m, Integral a, FiniteBits a, Mergeable a) =>-  e ->-  a ->-  a ->-  m a-safeSymRotateLConcreteNum e _ s | s < 0 = mrgThrowError e-safeSymRotateLConcreteNum _ a s =-  mrgReturn $ rotateL a (fromIntegral $ s `rem` fromIntegral (finiteBitSize s))---- | This function handles the case when the shift amount is out the range of--- `Int` correctly.-safeSymRotateRConcreteNum ::-  (MonadError e m, MonadUnion m, Integral a, FiniteBits a, Mergeable a) =>-  e ->-  a ->-  a ->-  m a-safeSymRotateRConcreteNum e _ s | s < 0 = mrgThrowError e-safeSymRotateRConcreteNum _ a s =-  mrgReturn $ rotateR a (fromIntegral $ s `rem` fromIntegral (finiteBitSize s))--#define SAFE_SYM_ROTATE_CONCRETE(T) \-  instance SafeSymRotate ArithException T where \-    safeSymRotateL' f = safeSymRotateLConcreteNum (f Overflow); \-    safeSymRotateR' f = safeSymRotateRConcreteNum (f Overflow) \--#if 1-SAFE_SYM_ROTATE_CONCRETE(Word8)-SAFE_SYM_ROTATE_CONCRETE(Word16)-SAFE_SYM_ROTATE_CONCRETE(Word32)-SAFE_SYM_ROTATE_CONCRETE(Word64)-SAFE_SYM_ROTATE_CONCRETE(Word)-SAFE_SYM_ROTATE_CONCRETE(Int8)-SAFE_SYM_ROTATE_CONCRETE(Int16)-SAFE_SYM_ROTATE_CONCRETE(Int32)-SAFE_SYM_ROTATE_CONCRETE(Int64)-SAFE_SYM_ROTATE_CONCRETE(Int)-#endif--instance (KnownNat n, 1 <= n) => SafeSymRotate ArithException (WordN n) where-  safeSymRotateL' f = safeSymRotateLConcreteNum (f Overflow)-  safeSymRotateR' f = safeSymRotateRConcreteNum (f Overflow)--instance (KnownNat n, 1 <= n) => SafeSymRotate ArithException (IntN n) where-  safeSymRotateL' f = safeSymRotateLConcreteNum (f Overflow)-  safeSymRotateR' f = safeSymRotateRConcreteNum (f Overflow)--instance (KnownNat n, 1 <= n) => SafeSymRotate ArithException (SymWordN n) where-  safeSymRotateL' _ (SymWordN ta) (SymWordN tr) =-    mrgReturn $ SymWordN $ pevalRotateLeftTerm ta tr-  safeSymRotateR' _ (SymWordN ta) (SymWordN tr) =-    mrgReturn $ SymWordN $ pevalRotateRightTerm ta tr--instance (KnownNat n, 1 <= n) => SafeSymRotate ArithException (SymIntN n) where-  safeSymRotateL' f (SymIntN ta) r@(SymIntN tr) =-    mrgIf-      (r .< 0)-      (mrgThrowError $ f Overflow)-      (mrgReturn $ SymIntN $ pevalRotateLeftTerm ta tr)-  safeSymRotateR' f (SymIntN ta) r@(SymIntN tr) =-    mrgIf-      (r .< 0)-      (mrgThrowError $ f Overflow)-      (mrgReturn $ SymIntN $ pevalRotateRightTerm ta tr)
− src/Grisette/Core/Data/Class/SafeSymShift.hs 
@@ -1,190 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DerivingVia #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE QuantifiedConstraints #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}--module Grisette.Core.Data.Class.SafeSymShift-  ( SafeSymShift (..),-  )-where--import Control.Exception (ArithException (Overflow))-import Control.Monad.Error.Class (MonadError)-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.Core.Control.Monad.Union (MonadUnion)-import Grisette.Core.Data.BV (IntN, WordN)-import Grisette.Core.Data.Class.LogicalOp-  ( LogicalOp ((.&&), (.||)),-  )-import Grisette.Core.Data.Class.Mergeable (Mergeable)-import Grisette.Core.Data.Class.SOrd-  ( SOrd ((.<), (.>=)),-  )-import Grisette.Core.Data.Class.SimpleMergeable-  ( UnionLike,-    mrgIf,-  )-import Grisette.Core.Data.Class.SymShift (SymShift)-import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bits-  ( pevalShiftLeftTerm,-    pevalShiftRightTerm,-  )-import Grisette.IR.SymPrim.Data.SymPrim (SymIntN (SymIntN), SymWordN (SymWordN))-import Grisette.Lib.Control.Monad (mrgReturn)-import Grisette.Lib.Control.Monad.Except (mrgThrowError)---- | Safe version for `shiftL` or `shiftR`.------ The `safeSymShiftL` and `safeSymShiftR` and their primed versions are defined--- for all non-negative shift amounts.------ * Shifting by negative shift amounts is an error.--- * The result is defined to be 0 when shifting left by more than or equal to--- the  bit size of the number.--- * The result is defined to be 0 when shifting right by more than or equal to--- the bit size of the number and the number is unsigned or signed non-negative.--- * The result is defined to be -1 when shifting right by more than or equal to--- the bit size of the number and the number is signed negative.------ The `safeSymStrictShiftL` and `safeSymStrictShiftR` and their primed versions--- are defined for all non-negative shift amounts that is less than the bit--- size. Shifting by more than or equal to the bit size is an error, otherwise--- they are the same as the non-strict versions.-class (SymShift a) => SafeSymShift e a | a -> e where-  safeSymShiftL :: (MonadError e m, UnionLike m) => a -> a -> m a-  safeSymShiftL = safeSymShiftL' id-  safeSymShiftR :: (MonadError e m, UnionLike m) => a -> a -> m a-  safeSymShiftR = safeSymShiftR' id-  safeSymShiftL' ::-    (MonadError e' m, UnionLike m) => (e -> e') -> a -> a -> m a-  safeSymShiftR' ::-    (MonadError e' m, UnionLike m) => (e -> e') -> a -> a -> m a-  safeSymStrictShiftL :: (MonadError e m, UnionLike m) => a -> a -> m a-  safeSymStrictShiftL = safeSymStrictShiftL' id-  safeSymStrictShiftR :: (MonadError e m, UnionLike m) => a -> a -> m a-  safeSymStrictShiftR = safeSymStrictShiftR' id-  safeSymStrictShiftL' ::-    (MonadError e' m, UnionLike m) => (e -> e') -> a -> a -> m a-  safeSymStrictShiftR' ::-    (MonadError e' m, UnionLike m) => (e -> e') -> a -> a -> m a-  {-# MINIMAL-    safeSymShiftL',-    safeSymShiftR',-    safeSymStrictShiftL',-    safeSymStrictShiftR'-    #-}---- | This function handles the case when the shift amount is out the range of--- `Int` correctly.-safeSymShiftLConcreteNum ::-  (MonadError e m, MonadUnion m, Integral a, FiniteBits a, Mergeable a) =>-  e ->-  Bool ->-  a ->-  a ->-  m a-safeSymShiftLConcreteNum e _ _ s | s < 0 = mrgThrowError e-safeSymShiftLConcreteNum e allowLargeShiftAmount a s-  | (fromIntegral s :: Integer) >= fromIntegral (finiteBitSize a) =-      if allowLargeShiftAmount then mrgReturn 0 else mrgThrowError e-safeSymShiftLConcreteNum _ _ a s = mrgReturn $ shiftL a (fromIntegral s)---- | This function handles the case when the shift amount is out the range of--- `Int` correctly.-safeSymShiftRConcreteNum ::-  (MonadError e m, MonadUnion m, Integral a, FiniteBits a, Mergeable a) =>-  e ->-  Bool ->-  a ->-  a ->-  m a-safeSymShiftRConcreteNum e _ _ s | s < 0 = mrgThrowError e-safeSymShiftRConcreteNum e allowLargeShiftAmount a s-  | (fromIntegral s :: Integer) >= fromIntegral (finiteBitSize a) =-      if allowLargeShiftAmount then mrgReturn 0 else mrgThrowError e-safeSymShiftRConcreteNum _ _ a s = mrgReturn $ shiftR a (fromIntegral s)--#define SAFE_SYM_SHIFT_CONCRETE(T) \-  instance SafeSymShift ArithException T where \-    safeSymShiftL' f = safeSymShiftLConcreteNum (f Overflow) True; \-    safeSymShiftR' f = safeSymShiftRConcreteNum (f Overflow) True; \-    safeSymStrictShiftL' f = safeSymShiftLConcreteNum (f Overflow) False; \-    safeSymStrictShiftR' f = safeSymShiftRConcreteNum (f Overflow) False--#if 1-SAFE_SYM_SHIFT_CONCRETE(Word8)-SAFE_SYM_SHIFT_CONCRETE(Word16)-SAFE_SYM_SHIFT_CONCRETE(Word32)-SAFE_SYM_SHIFT_CONCRETE(Word64)-SAFE_SYM_SHIFT_CONCRETE(Word)-SAFE_SYM_SHIFT_CONCRETE(Int8)-SAFE_SYM_SHIFT_CONCRETE(Int16)-SAFE_SYM_SHIFT_CONCRETE(Int32)-SAFE_SYM_SHIFT_CONCRETE(Int64)-SAFE_SYM_SHIFT_CONCRETE(Int)-#endif--instance (KnownNat n, 1 <= n) => SafeSymShift ArithException (WordN n) where-  safeSymShiftL' f = safeSymShiftLConcreteNum (f Overflow) True-  safeSymShiftR' f = safeSymShiftRConcreteNum (f Overflow) True-  safeSymStrictShiftL' f = safeSymShiftLConcreteNum (f Overflow) False-  safeSymStrictShiftR' f = safeSymShiftRConcreteNum (f Overflow) False--instance (KnownNat n, 1 <= n) => SafeSymShift ArithException (IntN n) where-  safeSymShiftL' f = safeSymShiftLConcreteNum (f Overflow) True-  safeSymShiftR' f = safeSymShiftRConcreteNum (f Overflow) True-  safeSymStrictShiftL' f = safeSymShiftLConcreteNum (f Overflow) False-  safeSymStrictShiftR' f = safeSymShiftRConcreteNum (f Overflow) False--instance (KnownNat n, 1 <= n) => SafeSymShift ArithException (SymWordN n) where-  safeSymShiftL' _ (SymWordN a) (SymWordN s) =-    return $ SymWordN $ pevalShiftLeftTerm a s-  safeSymShiftR' _ (SymWordN a) (SymWordN s) =-    return $ SymWordN $ pevalShiftRightTerm a s-  safeSymStrictShiftL' f a@(SymWordN ta) s@(SymWordN ts) =-    mrgIf-      (s .>= fromIntegral (finiteBitSize a))-      (mrgThrowError $ f Overflow)-      (return $ SymWordN $ pevalShiftLeftTerm ta ts)-  safeSymStrictShiftR' f a@(SymWordN ta) s@(SymWordN ts) =-    mrgIf-      (s .>= fromIntegral (finiteBitSize a))-      (mrgThrowError $ f Overflow)-      (return $ SymWordN $ pevalShiftRightTerm ta ts)--instance (KnownNat n, 1 <= n) => SafeSymShift ArithException (SymIntN n) where-  safeSymShiftL' f (SymIntN a) ss@(SymIntN s) =-    mrgIf-      (ss .< 0)-      (mrgThrowError $ f Overflow)-      (return $ SymIntN $ pevalShiftLeftTerm a s)-  safeSymShiftR' f (SymIntN a) ss@(SymIntN s) =-    mrgIf-      (ss .< 0)-      (mrgThrowError $ f Overflow)-      (return $ SymIntN $ pevalShiftRightTerm a s)-  safeSymStrictShiftL' f a@(SymIntN ta) s@(SymIntN ts) =-    mrgIf-      (s .< 0 .|| (bs .>= 0 .&& s .>= bs))-      (mrgThrowError $ f Overflow)-      (return $ SymIntN $ pevalShiftLeftTerm ta ts)-    where-      bs = fromIntegral (finiteBitSize a)-  safeSymStrictShiftR' f a@(SymIntN ta) s@(SymIntN ts) =-    mrgIf-      (s .< 0 .|| (bs .>= 0 .&& s .>= bs))-      (mrgThrowError $ f Overflow)-      (return $ SymIntN $ pevalShiftRightTerm ta ts)-    where-      bs = fromIntegral (finiteBitSize a)
− src/Grisette/Core/Data/Class/SignConversion.hs 
@@ -1,37 +0,0 @@-{-# LANGUAGE FunctionalDependencies #-}--module Grisette.Core.Data.Class.SignConversion-  ( SignConversion (..),-  )-where--import Data.Int (Int16, Int32, Int64, Int8)-import Data.Word (Word16, Word32, Word64, Word8)---- | Convert values between signed and unsigned.-class SignConversion ubv sbv | ubv -> sbv, sbv -> ubv where-  -- | Convert unsigned value to the corresponding signed value.-  toSigned :: ubv -> sbv--  -- | Convert signed value to the corresponding unsigned value.-  toUnsigned :: sbv -> ubv--instance SignConversion Word8 Int8 where-  toSigned = fromIntegral-  toUnsigned = fromIntegral--instance SignConversion Word16 Int16 where-  toSigned = fromIntegral-  toUnsigned = fromIntegral--instance SignConversion Word32 Int32 where-  toSigned = fromIntegral-  toUnsigned = fromIntegral--instance SignConversion Word64 Int64 where-  toSigned = fromIntegral-  toUnsigned = fromIntegral--instance SignConversion Word Int where-  toSigned = fromIntegral-  toUnsigned = fromIntegral
− src/Grisette/Core/Data/Class/SimpleMergeable.hs 
@@ -1,849 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DerivingVia #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE QuantifiedConstraints #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ViewPatterns #-}---- |--- Module      :   Grisette.Core.Data.Class.SimpleMergeable--- 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.Core.Data.Class.SimpleMergeable-  ( -- * Simple mergeable types-    SimpleMergeable (..),-    SimpleMergeable1 (..),-    mrgIte1,-    SimpleMergeable2 (..),-    mrgIte2,--    -- * UnionLike operations-    UnionLike (..),-    mrgIf,-    merge,-    mrgSingle,-    UnionPrjOp (..),-    pattern Single,-    pattern If,-    simpleMerge,-    onUnion,-    onUnion2,-    onUnion3,-    onUnion4,-    (.#),-  )-where--import Control.Monad.Except (ExceptT (ExceptT))-import Control.Monad.Identity-  ( Identity (Identity),-    IdentityT (IdentityT),-  )-import qualified Control.Monad.RWS.Lazy as RWSLazy-import qualified Control.Monad.RWS.Strict as RWSStrict-import Control.Monad.Reader (ReaderT (ReaderT))-import qualified Control.Monad.State.Lazy as StateLazy-import qualified Control.Monad.State.Strict as StateStrict-import Control.Monad.Trans.Cont (ContT (ContT))-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 (first))-import Data.Kind (Type)-import GHC.Generics-  ( Generic (Rep, from, to),-    K1 (K1),-    M1 (M1),-    U1,-    V1,-    type (:*:) ((:*:)),-  )-import GHC.TypeNats (KnownNat, type (<=))-import Generics.Deriving (Default (Default))-import Grisette.Core.Control.Exception (AssertionError)-import Grisette.Core.Data.Class.Function (Function (Arg, Ret, (#)))-import Grisette.Core.Data.Class.ITEOp (ITEOp (symIte))-import Grisette.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.&&)))-import Grisette.Core.Data.Class.Mergeable-  ( Mergeable (rootStrategy),-    Mergeable',-    Mergeable1 (liftRootStrategy),-    Mergeable2 (liftRootStrategy2),-    Mergeable3 (liftRootStrategy3),-    MergingStrategy (SimpleStrategy),-  )-import Grisette.Core.Data.Class.Solvable (Solvable (con))-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term-  ( LinkedRep,-    SupportedPrim,-  )-import Grisette.IR.SymPrim.Data.SymPrim-  ( SymBool,-    SymIntN,-    SymInteger,-    SymWordN,-    type (-~>),-    type (=~>),-  )---- $setup--- >>> import Grisette.Core--- >>> import Grisette.IR.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.--- You may need the @DerivingVia@ and @DerivingStrategies@ extensions.------ > data X = ...--- >   deriving Generic--- >   deriving (Mergeable, SimpleMergeable) via (Default X)-class (Mergeable a) => SimpleMergeable a where-  -- | Performs if-then-else with the simple root merge strategy.-  ---  -- >>> mrgIte "a" "b" "c" :: SymInteger-  -- (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 SimpleMergeable1 u where-  -- | Lift 'mrgIte' through the type constructor.-  ---  -- >>> liftMrgIte mrgIte "a" (Identity "b") (Identity "c") :: Identity SymInteger-  -- Identity (ite a b c)-  liftMrgIte :: (SymBool -> a -> a -> a) -> SymBool -> u a -> u a -> u a---- | Lift the standard 'mrgIte' function through the type constructor.------ >>> 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 = liftMrgIte mrgIte-{-# INLINE mrgIte1 #-}---- | Lifting of the 'SimpleMergeable' class to binary type constructors.-class (Mergeable2 u) => 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---- | 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 = liftMrgIte2 mrgIte mrgIte-{-# INLINE mrgIte2 #-}---- | 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, Mergeable1 u) => UnionLike u where-  -- | Wrap a single value in the union.-  ---  -- Note that this function cannot propagate the 'Mergeable' knowledge.-  ---  -- >>> single "a" :: UnionM SymInteger-  -- <a>-  -- >>> mrgSingle "a" :: UnionM SymInteger-  -- {a}-  single :: a -> u a--  -- | If-then-else on two union values.-  ---  -- Note that this function cannot capture the 'Mergeable' knowledge. However,-  -- it may use the merging strategy from the branches to merge the results.-  ---  -- >>> unionIf "a" (single "b") (single "c") :: UnionM SymInteger-  -- <If a b c>-  -- >>> unionIf "a" (mrgSingle "b") (single "c") :: UnionM SymInteger-  -- {(ite a b c)}-  unionIf :: SymBool -> u a -> u a -> u a--  -- | Merge the contents with some merge strategy.-  ---  -- >>> mergeWithStrategy rootStrategy $ unionIf "a" (single "b") (single "c") :: UnionM 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.-  ---  -- 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, 'merge' is usually a better alternative.-  mergeWithStrategy :: MergingStrategy a -> u a -> u a--  -- | Symbolic @if@ control flow with the result merged with some merge strategy.-  ---  -- >>> mrgIfWithStrategy rootStrategy "a" (mrgSingle "b") (single "c") :: UnionM 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.-  ---  -- 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-  mrgIfWithStrategy s cond l r = mergeWithStrategy s $ unionIf cond l r-  {-# INLINE mrgIfWithStrategy #-}--  -- | Wrap a single value in the union and capture the 'Mergeable' knowledge.-  ---  -- >>> mrgSingleWithStrategy rootStrategy "a" :: UnionM SymInteger-  -- {a}-  ---  -- __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.-  ---  -- 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, 'mrgSingle' is usually a better alternative.-  mrgSingleWithStrategy :: MergingStrategy a -> a -> u a-  mrgSingleWithStrategy s = mergeWithStrategy s . single-  {-# INLINE mrgSingleWithStrategy #-}---- | Symbolic @if@ control flow with the result merged with the type's root merge strategy.------ Equivalent to @'mrgIfWithStrategy' 'rootStrategy'@.------ >>> mrgIf "a" (single "b") (single "c") :: UnionM SymInteger--- {(ite a b c)}-mrgIf :: (UnionLike u, Mergeable a) => SymBool -> u a -> u a -> u a-mrgIf = mrgIfWithStrategy rootStrategy-{-# INLINE mrgIf #-}---- | Merge the contents with the type's root merge strategy.------ Equivalent to @'mergeWithStrategy' 'rootStrategy'@.------ >>> merge $ unionIf "a" (single "b") (single "c") :: UnionM SymInteger--- {(ite a b c)}-merge :: (UnionLike u, Mergeable a) => u a -> u a-merge = mergeWithStrategy rootStrategy-{-# INLINE merge #-}---- | Wrap a single value in the type and propagate the type's root merge strategy.------ Equivalent to @'mrgSingleWithStrategy' 'rootStrategy'@.------ >>> mrgSingle "a" :: UnionM SymInteger--- {a}-mrgSingle :: (UnionLike u, Mergeable a) => a -> u a-mrgSingle = mrgSingleWithStrategy rootStrategy-{-# INLINE mrgSingle #-}--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 #-}--instance (SimpleMergeable a) => SimpleMergeable1 ((,) a) where-  liftMrgIte mb cond (a1, b1) (a2, b2) = (mrgIte cond a1 a2, mb cond b1 b2)-  {-# INLINE liftMrgIte #-}--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,-    SimpleMergeable b,-    SimpleMergeable c,-    SimpleMergeable d,-    SimpleMergeable e,-    SimpleMergeable f,-    SimpleMergeable g,-    SimpleMergeable h-  ) =>-  SimpleMergeable (a, b, c, d, e, f, g, h)-  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 #-}--instance (SimpleMergeable b) => SimpleMergeable (a -> b) where-  mrgIte = mrgIte1-  {-# INLINE mrgIte #-}--instance SimpleMergeable1 ((->) a) where-  liftMrgIte ms cond t f v = ms cond (t v) (f v)-  {-# INLINE liftMrgIte #-}--instance (UnionLike m, Mergeable a) => SimpleMergeable (MaybeT m a) where-  mrgIte = mrgIf-  {-# INLINE mrgIte #-}--instance (UnionLike m) => SimpleMergeable1 (MaybeT m) where-  liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m)-  {-# INLINE liftMrgIte #-}--instance (UnionLike m) => UnionLike (MaybeT m) where-  mergeWithStrategy s (MaybeT v) = MaybeT $ mergeWithStrategy (liftRootStrategy s) v-  {-# INLINE mergeWithStrategy #-}-  mrgIfWithStrategy s cond (MaybeT t) (MaybeT f) = MaybeT $ mrgIfWithStrategy (liftRootStrategy s) cond t f-  {-# INLINE mrgIfWithStrategy #-}-  single = MaybeT . single . return-  {-# INLINE single #-}-  unionIf cond (MaybeT l) (MaybeT r) = MaybeT $ unionIf cond l r-  {-# INLINE unionIf #-}--instance-  (UnionLike m, Mergeable e, Mergeable a) =>-  SimpleMergeable (ExceptT e m a)-  where-  mrgIte = mrgIf-  {-# INLINE mrgIte #-}--instance-  (UnionLike m, Mergeable e) =>-  SimpleMergeable1 (ExceptT e m)-  where-  liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m)-  {-# INLINE liftMrgIte #-}--instance-  (UnionLike m, Mergeable e) =>-  UnionLike (ExceptT e m)-  where-  mergeWithStrategy s (ExceptT v) = ExceptT $ mergeWithStrategy (liftRootStrategy s) v-  {-# INLINE mergeWithStrategy #-}-  mrgIfWithStrategy s cond (ExceptT t) (ExceptT f) = ExceptT $ mrgIfWithStrategy (liftRootStrategy s) cond t f-  {-# INLINE mrgIfWithStrategy #-}-  single = ExceptT . single . return-  {-# INLINE single #-}-  unionIf cond (ExceptT l) (ExceptT r) = ExceptT $ unionIf cond l r-  {-# INLINE unionIf #-}--instance-  (Mergeable s, Mergeable a, UnionLike m) =>-  SimpleMergeable (StateLazy.StateT s m a)-  where-  mrgIte = mrgIf-  {-# INLINE mrgIte #-}--instance-  (Mergeable s, UnionLike m) =>-  SimpleMergeable1 (StateLazy.StateT s m)-  where-  liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m)-  {-# INLINE liftMrgIte #-}--instance-  (Mergeable s, UnionLike m) =>-  UnionLike (StateLazy.StateT s m)-  where-  mergeWithStrategy ms (StateLazy.StateT f) =-    StateLazy.StateT $ \v -> mergeWithStrategy (liftRootStrategy2 ms rootStrategy) $ f v-  {-# INLINE mergeWithStrategy #-}-  mrgIfWithStrategy s cond (StateLazy.StateT t) (StateLazy.StateT f) =-    StateLazy.StateT $ \v -> mrgIfWithStrategy (liftRootStrategy2 s rootStrategy) cond (t v) (f v)-  {-# INLINE mrgIfWithStrategy #-}-  single x = StateLazy.StateT $ \s -> single (x, s)-  {-# INLINE single #-}-  unionIf cond (StateLazy.StateT l) (StateLazy.StateT r) =-    StateLazy.StateT $ \s -> unionIf cond (l s) (r s)-  {-# INLINE unionIf #-}--instance-  (Mergeable s, Mergeable a, UnionLike m) =>-  SimpleMergeable (StateStrict.StateT s m a)-  where-  mrgIte = mrgIf-  {-# INLINE mrgIte #-}--instance-  (Mergeable s, UnionLike m) =>-  SimpleMergeable1 (StateStrict.StateT s m)-  where-  liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m)-  {-# INLINE liftMrgIte #-}--instance-  (Mergeable s, UnionLike m) =>-  UnionLike (StateStrict.StateT s m)-  where-  mergeWithStrategy ms (StateStrict.StateT f) =-    StateStrict.StateT $ \v -> mergeWithStrategy (liftRootStrategy2 ms rootStrategy) $ f v-  {-# INLINE mergeWithStrategy #-}-  mrgIfWithStrategy s cond (StateStrict.StateT t) (StateStrict.StateT f) =-    StateStrict.StateT $ \v -> mrgIfWithStrategy (liftRootStrategy2 s rootStrategy) cond (t v) (f v)-  {-# INLINE mrgIfWithStrategy #-}-  single x = StateStrict.StateT $ \s -> single (x, s)-  {-# INLINE single #-}-  unionIf cond (StateStrict.StateT l) (StateStrict.StateT r) =-    StateStrict.StateT $ \s -> unionIf cond (l s) (r s)-  {-# INLINE unionIf #-}--instance-  (Mergeable s, Mergeable a, UnionLike m, Monoid s) =>-  SimpleMergeable (WriterLazy.WriterT s m a)-  where-  mrgIte = mrgIf-  {-# INLINE mrgIte #-}--instance-  (Mergeable s, UnionLike m, Monoid s) =>-  SimpleMergeable1 (WriterLazy.WriterT s m)-  where-  liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m)-  {-# INLINE liftMrgIte #-}--instance-  (Mergeable s, UnionLike m, Monoid s) =>-  UnionLike (WriterLazy.WriterT s m)-  where-  mergeWithStrategy ms (WriterLazy.WriterT f) = WriterLazy.WriterT $ mergeWithStrategy (liftRootStrategy2 ms rootStrategy) f-  {-# INLINE mergeWithStrategy #-}-  mrgIfWithStrategy s cond (WriterLazy.WriterT t) (WriterLazy.WriterT f) =-    WriterLazy.WriterT $ mrgIfWithStrategy (liftRootStrategy2 s rootStrategy) cond t f-  {-# INLINE mrgIfWithStrategy #-}-  single x = WriterLazy.WriterT $ single (x, mempty)-  {-# INLINE single #-}-  unionIf cond (WriterLazy.WriterT l) (WriterLazy.WriterT r) =-    WriterLazy.WriterT $ unionIf cond l r-  {-# INLINE unionIf #-}--instance-  (Mergeable s, Mergeable a, UnionLike m, Monoid s) =>-  SimpleMergeable (WriterStrict.WriterT s m a)-  where-  mrgIte = mrgIf-  {-# INLINE mrgIte #-}--instance-  (Mergeable s, UnionLike m, Monoid s) =>-  SimpleMergeable1 (WriterStrict.WriterT s m)-  where-  liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m)-  {-# INLINE liftMrgIte #-}--instance-  (Mergeable s, UnionLike m, Monoid s) =>-  UnionLike (WriterStrict.WriterT s m)-  where-  mergeWithStrategy ms (WriterStrict.WriterT f) = WriterStrict.WriterT $ mergeWithStrategy (liftRootStrategy2 ms rootStrategy) f-  {-# INLINE mergeWithStrategy #-}-  mrgIfWithStrategy s cond (WriterStrict.WriterT t) (WriterStrict.WriterT f) =-    WriterStrict.WriterT $ mrgIfWithStrategy (liftRootStrategy2 s rootStrategy) cond t f-  {-# INLINE mrgIfWithStrategy #-}-  single x = WriterStrict.WriterT $ single (x, mempty)-  {-# INLINE single #-}-  unionIf cond (WriterStrict.WriterT l) (WriterStrict.WriterT r) =-    WriterStrict.WriterT $ unionIf cond l r-  {-# INLINE unionIf #-}--instance-  (Mergeable a, UnionLike m) =>-  SimpleMergeable (ReaderT s m a)-  where-  mrgIte = mrgIf-  {-# INLINE mrgIte #-}--instance-  (UnionLike m) =>-  SimpleMergeable1 (ReaderT s m)-  where-  liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m)-  {-# INLINE liftMrgIte #-}--instance-  (UnionLike m) =>-  UnionLike (ReaderT s m)-  where-  mergeWithStrategy ms (ReaderT f) = ReaderT $ \v -> mergeWithStrategy ms $ f v-  {-# INLINE mergeWithStrategy #-}-  mrgIfWithStrategy s cond (ReaderT t) (ReaderT f) =-    ReaderT $ \v -> mrgIfWithStrategy s cond (t v) (f v)-  {-# INLINE mrgIfWithStrategy #-}-  single x = ReaderT $ \_ -> single x-  {-# INLINE single #-}-  unionIf cond (ReaderT l) (ReaderT r) = ReaderT $ \s -> unionIf cond (l s) (r s)-  {-# INLINE unionIf #-}--instance (SimpleMergeable a) => SimpleMergeable (Identity a) where-  mrgIte cond (Identity l) (Identity r) = Identity $ mrgIte cond l r-  {-# INLINE mrgIte #-}--instance SimpleMergeable1 Identity where-  liftMrgIte mite cond (Identity l) (Identity r) = Identity $ mite cond l r-  {-# INLINE liftMrgIte #-}--instance (UnionLike m, Mergeable a) => SimpleMergeable (IdentityT m a) where-  mrgIte = mrgIf-  {-# INLINE mrgIte #-}--instance (UnionLike m) => SimpleMergeable1 (IdentityT m) where-  liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m)-  {-# INLINE liftMrgIte #-}--instance (UnionLike m) => UnionLike (IdentityT m) where-  mergeWithStrategy ms (IdentityT f) =-    IdentityT $ mergeWithStrategy ms f-  {-# INLINE mergeWithStrategy #-}-  mrgIfWithStrategy s cond (IdentityT l) (IdentityT r) = IdentityT $ mrgIfWithStrategy s cond l r-  {-# INLINE mrgIfWithStrategy #-}-  single x = IdentityT $ single x-  {-# INLINE single #-}-  unionIf cond (IdentityT l) (IdentityT r) = IdentityT $ unionIf cond l r-  {-# INLINE unionIf #-}--instance (UnionLike 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 (UnionLike m, Mergeable r) => SimpleMergeable1 (ContT r m) where-  liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m)-  {-# INLINE liftMrgIte #-}--instance (UnionLike m, Mergeable r) => UnionLike (ContT r m) where-  mergeWithStrategy _ (ContT f) = ContT $ \c -> merge (f c)-  {-# INLINE mergeWithStrategy #-}-  mrgIfWithStrategy _ cond (ContT l) (ContT r) = ContT $ \c -> mrgIf cond (l c) (r c)-  {-# INLINE mrgIfWithStrategy #-}-  single x = ContT $ \c -> c x-  {-# INLINE single #-}-  unionIf cond (ContT l) (ContT r) = ContT $ \c -> unionIf cond (l c) (r c)-  {-# INLINE unionIf #-}--instance-  (Mergeable s, Mergeable w, Monoid w, Mergeable a, UnionLike m) =>-  SimpleMergeable (RWSLazy.RWST r w s m a)-  where-  mrgIte = mrgIf-  {-# INLINE mrgIte #-}--instance-  (Mergeable s, Mergeable w, Monoid w, UnionLike m) =>-  SimpleMergeable1 (RWSLazy.RWST r w s m)-  where-  liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m)-  {-# INLINE liftMrgIte #-}--instance-  (Mergeable s, Mergeable w, Monoid w, UnionLike m) =>-  UnionLike (RWSLazy.RWST r w s m)-  where-  mergeWithStrategy ms (RWSLazy.RWST f) =-    RWSLazy.RWST $ \r s -> mergeWithStrategy (liftRootStrategy3 ms rootStrategy rootStrategy) $ f r s-  {-# INLINE mergeWithStrategy #-}-  mrgIfWithStrategy ms cond (RWSLazy.RWST t) (RWSLazy.RWST f) =-    RWSLazy.RWST $ \r s -> mrgIfWithStrategy (liftRootStrategy3 ms rootStrategy rootStrategy) cond (t r s) (f r s)-  {-# INLINE mrgIfWithStrategy #-}-  single x = RWSLazy.RWST $ \_ s -> single (x, s, mempty)-  {-# INLINE single #-}-  unionIf cond (RWSLazy.RWST t) (RWSLazy.RWST f) =-    RWSLazy.RWST $ \r s -> unionIf cond (t r s) (f r s)-  {-# INLINE unionIf #-}--instance-  (Mergeable s, Mergeable w, Monoid w, Mergeable a, UnionLike m) =>-  SimpleMergeable (RWSStrict.RWST r w s m a)-  where-  mrgIte = mrgIf-  {-# INLINE mrgIte #-}--instance-  (Mergeable s, Mergeable w, Monoid w, UnionLike m) =>-  SimpleMergeable1 (RWSStrict.RWST r w s m)-  where-  liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m)-  {-# INLINE liftMrgIte #-}--instance-  (Mergeable s, Mergeable w, Monoid w, UnionLike m) =>-  UnionLike (RWSStrict.RWST r w s m)-  where-  mergeWithStrategy ms (RWSStrict.RWST f) =-    RWSStrict.RWST $ \r s -> mergeWithStrategy (liftRootStrategy3 ms rootStrategy rootStrategy) $ f r s-  {-# INLINE mergeWithStrategy #-}-  mrgIfWithStrategy ms cond (RWSStrict.RWST t) (RWSStrict.RWST f) =-    RWSStrict.RWST $ \r s -> mrgIfWithStrategy (liftRootStrategy3 ms rootStrategy rootStrategy) cond (t r s) (f r s)-  {-# INLINE mrgIfWithStrategy #-}-  single x = RWSStrict.RWST $ \_ s -> single (x, s, mempty)-  {-# INLINE single #-}-  unionIf cond (RWSStrict.RWST t) (RWSStrict.RWST f) =-    RWSStrict.RWST $ \r s -> unionIf cond (t r s) (f r s)-  {-# INLINE unionIf #-}---- | Union containers that can be projected back into single value or--- if-guarded values.-class (UnionLike u) => UnionPrjOp (u :: Type -> Type) where-  -- | Pattern match to extract single values.-  ---  -- >>> singleView (single 1 :: UnionM Integer)-  -- Just 1-  -- >>> singleView (unionIf "a" (single 1) (single 2) :: UnionM Integer)-  -- Nothing-  singleView :: u a -> Maybe a--  -- | Pattern match to extract if values.-  ---  -- >>> ifView (single 1 :: UnionM Integer)-  -- Nothing-  -- >>> ifView (unionIf "a" (single 1) (single 2) :: UnionM Integer)-  -- Just (a,<1>,<2>)-  -- >>> ifView (mrgIf "a" (single 1) (single 2) :: UnionM Integer)-  -- Just (a,{1},{2})-  ifView :: u a -> Maybe (SymBool, u a, u a)--  -- | The leftmost value in the union.-  ---  -- >>> leftMost (unionIf "a" (single 1) (single 2) :: UnionM Integer)-  -- 1-  leftMost :: u a -> a--  -- | Convert the union to a guarded list.-  ---  -- >>> toGuardedList (mrgIf "a" (single 1) (mrgIf "b" (single 2) (single 3)) :: UnionM Integer)-  -- [(a,1),((&& b (! a)),2),((! (|| b a)),3)]-  toGuardedList :: u a -> [(SymBool, a)]-  toGuardedList u =-    case (singleView u, ifView u) of-      (Just x, _) -> [(con True, x)]-      (_, Just (c, l, r)) ->-        fmap (first (.&& c)) (toGuardedList l)-          ++ fmap (first (.&& symNot c)) (toGuardedList r)-      _ -> error "Should not happen"---- | Pattern match to extract single values with 'singleView'.------ >>> case (single 1 :: UnionM Integer) of Single v -> v--- 1-pattern Single :: (UnionPrjOp u, Mergeable a) => a -> u a-pattern Single x <--  (singleView -> Just x)-  where-    Single x = mrgSingle x---- | Pattern match to extract guard values with 'ifView'--- >>> case (unionIf "a" (single 1) (single 2) :: UnionM Integer) of If c t f -> (c,t,f)--- (a,<1>,<2>)-pattern If :: (UnionPrjOp u, Mergeable a) => SymBool -> u a -> u a -> u a-pattern If c t f <--  (ifView -> Just (c, t, f))-  where-    If c t f = unionIf c t f---- | Merge the simply mergeable values in a union, and extract the merged value.------ In the following example, 'unionIf' will not merge the results, and--- 'simpleMerge' will merge it and extract the single merged value.------ >>> unionIf (ssym "a") (return $ ssym "b") (return $ ssym "c") :: UnionM SymBool--- <If a b c>--- >>> simpleMerge $ (unionIf (ssym "a") (return $ ssym "b") (return $ ssym "c") :: UnionM SymBool)--- (ite a b c)-simpleMerge :: forall u a. (SimpleMergeable a, UnionLike u, UnionPrjOp u) => u a -> a-simpleMerge u = case merge u of-  Single x -> x-  _ -> error "Should not happen"-{-# INLINE simpleMerge #-}---- | Lift a function to work on union values.------ >>> sumU = onUnion sum--- >>> sumU (unionIf "cond" (return ["a"]) (return ["b","c"]) :: UnionM [SymInteger])--- (ite cond a (+ b c))-onUnion ::-  forall u a r.-  (SimpleMergeable r, UnionLike u, UnionPrjOp u, Monad u) =>-  (a -> r) ->-  (u a -> r)-onUnion f = simpleMerge . fmap f---- | Lift a function to work on union values.-onUnion2 ::-  forall u a b r.-  (SimpleMergeable r, UnionLike u, UnionPrjOp u, Monad u) =>-  (a -> b -> r) ->-  (u a -> u b -> r)-onUnion2 f ua ub = simpleMerge $ f <$> ua <*> ub---- | Lift a function to work on union values.-onUnion3 ::-  forall u a b c r.-  (SimpleMergeable r, UnionLike u, UnionPrjOp u, Monad u) =>-  (a -> b -> c -> r) ->-  (u a -> u b -> u c -> r)-onUnion3 f ua ub uc = simpleMerge $ f <$> ua <*> ub <*> uc---- | Lift a function to work on union values.-onUnion4 ::-  forall u a b c d r.-  (SimpleMergeable r, UnionLike u, UnionPrjOp u, Monad u) =>-  (a -> b -> c -> d -> r) ->-  (u a -> u b -> u c -> u d -> r)-onUnion4 f ua ub uc ud = simpleMerge $ f <$> ua <*> ub <*> uc <*> ud---- | Helper for applying functions on 'UnionPrjOp' 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)--- {If (&& b a) 1 (If b 2 (If a 3 4))}-(.#) ::-  (Function f, SimpleMergeable (Ret f), UnionPrjOp u, Functor u) =>-  f ->-  u (Arg f) ->-  Ret f-(.#) f u = simpleMerge $ fmap (f #) u-{-# INLINE (.#) #-}--infixl 9 .#--#define SIMPLE_MERGEABLE_SIMPLE(symtype) \-instance SimpleMergeable symtype where \-  mrgIte = symIte; \-  {-# INLINE mrgIte #-}--#define SIMPLE_MERGEABLE_BV(symtype) \-instance (KnownNat n, 1 <= n) => SimpleMergeable (symtype n) where \-  mrgIte = symIte; \-  {-# INLINE mrgIte #-}--#define SIMPLE_MERGEABLE_FUN(op) \-instance (SupportedPrim ca, SupportedPrim cb, LinkedRep ca sa, LinkedRep cb sb) => SimpleMergeable (sa op sb) where \-  mrgIte = symIte; \-  {-# INLINE mrgIte #-}--#if 1-SIMPLE_MERGEABLE_SIMPLE(SymBool)-SIMPLE_MERGEABLE_SIMPLE(SymInteger)-SIMPLE_MERGEABLE_BV(SymIntN)-SIMPLE_MERGEABLE_BV(SymWordN)-SIMPLE_MERGEABLE_FUN(=~>)-SIMPLE_MERGEABLE_FUN(-~>)-#endif---- Exception-deriving via (Default AssertionError) instance SimpleMergeable AssertionError
− src/Grisette/Core/Data/Class/Solvable.hs 
@@ -1,107 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ViewPatterns #-}---- |--- Module      :   Grisette.Core.Data.Class.Solvable--- 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.Core.Data.Class.Solvable-  ( -- * Solvable type interface-    Solvable (..),-    pattern Con,-  )-where--import Control.DeepSeq (NFData)-import Data.Hashable (Hashable)-import Data.String (IsString)-import qualified Data.Text as T-import Data.Typeable (Typeable)-import Language.Haskell.TH.Syntax (Lift)---- $setup--- >>> import Grisette.Core--- >>> import Grisette.IR.SymPrim--- >>> :set -XOverloadedStrings---- | The class defines the creation and pattern matching of solvable type--- values.-class (IsString t) => Solvable c t | t -> c where-  -- | Wrap a concrete value in a symbolic value.-  ---  -- >>> con True :: SymBool-  -- true-  con :: c -> t--  -- | Extract the concrete value from a symbolic value.-  ---  -- >>> conView (con True :: SymBool)-  -- Just True-  ---  -- >>> conView (ssym "a" :: SymBool)-  -- Nothing-  conView :: t -> Maybe c--  -- | Generate simply-named symbolic constants.-  ---  -- Two symbolic constants with the same name are the same symbolic constant,-  -- and will always be assigned with the same value by the solver.-  ---  -- >>> ssym "a" :: SymBool-  -- a-  -- >>> (ssym "a" :: SymBool) == ssym "a"-  -- True-  -- >>> (ssym "a" :: SymBool) == ssym "b"-  -- False-  -- >>> (ssym "a" :: SymBool) .&& ssym "a"-  -- a-  ssym :: T.Text -> t--  -- | Generate indexed symbolic constants.-  ---  -- Two symbolic constants with the same name but different indices are-  -- not the same symbolic constants.-  ---  -- >>> isym "a" 1 :: SymBool-  -- a@1-  isym :: T.Text -> Int -> t--  -- | Generate simply-named symbolic constants with some extra information for-  -- disambiguation.-  ---  -- Two symbolic constants with the same name but different extra information-  -- (including info with different types) are considered to be different.-  ---  -- >>> sinfosym "a" "someInfo" :: SymInteger-  -- a:"someInfo"-  sinfosym :: (Typeable a, Ord a, Lift a, NFData a, Show a, Hashable a) => T.Text -> a -> t--  -- | Generate indexed symbolic constants with some extra information for-  -- disambiguation.-  ---  -- Two symbolic constants with the same name and index but different extra-  -- information (including info with different types) are considered to be-  -- different.-  ---  -- >>> iinfosym "a" 1 "someInfo" :: SymInteger-  -- a@1:"someInfo"-  iinfosym :: (Typeable a, Ord a, Lift a, NFData a, Show a, Hashable a) => T.Text -> Int -> a -> t---- | Extract the concrete value from a solvable value with 'conView'.------ >>> case con True :: SymBool of Con v -> v--- True-pattern Con :: (Solvable c t) => c -> t-pattern Con c <--  (conView -> Just c)-  where-    Con c = con c
− src/Grisette/Core/Data/Class/Solver.hs 
@@ -1,288 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveLift #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}---- |--- Module      :   Grisette.Core.Data.Class.Solver--- 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.Core.Data.Class.Solver-  ( -- * Note for the examples--    ----    -- | The examples assumes that the [z3](https://github.com/Z3Prover/z3)-    -- solver is available in @PATH@.--    -- * Solver interfaces-    SolvingFailure (..),-    MonadicSolver (..),-    SolverCommand (..),-    ConfigurableSolver (..),-    Solver (..),-    withSolver,-    solve,-    solveMulti,--    -- * Union with exceptions-    UnionWithExcept (..),-    solveExcept,-    solveMultiExcept,-  )-where--import Control.DeepSeq (NFData)-import Control.Exception (SomeException, bracket)-import Control.Monad.Except (ExceptT, runExceptT)-import qualified Data.HashSet as S-import Data.Hashable (Hashable)-import Data.Maybe (fromJust)-import GHC.Generics (Generic)-import Grisette.Core.Data.Class.ExtractSymbolics-  ( ExtractSymbolics (extractSymbolics),-  )-import Grisette.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.||)))-import Grisette.Core.Data.Class.SimpleMergeable-  ( UnionPrjOp,-    simpleMerge,-  )-import Grisette.Core.Data.Class.Solvable (Solvable (con))-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term-  ( SomeTypedSymbol (SomeTypedSymbol),-  )-import Grisette.IR.SymPrim.Data.Prim.Model-  ( Model,-    SymbolSet (unSymbolSet),-    equation,-  )-import Grisette.IR.SymPrim.Data.SymPrim (SymBool (SymBool))-import Language.Haskell.TH.Syntax (Lift)--data SolveInternal = SolveInternal-  deriving (Eq, Show, Ord, Generic, Hashable, Lift, NFData)---- $setup--- >>> import Grisette.Core--- >>> import Grisette.IR.SymPrim--- >>> import Grisette.Backend.SBV--- >>> :set -XOverloadedStrings---- | The current failures that can be returned by the solver.-data SolvingFailure-  = -- | Unsatisfiable: No model is available.-    Unsat-  | -- | Unknown: The solver cannot determine whether the formula is-    -- satisfiable.-    Unk-  | -- | The solver has reached the maximum number of models to return.-    ResultNumLimitReached-  | -- | The solver has encountered an error.-    SolvingError SomeException-  | -- | The solver has been terminated.-    Terminated-  deriving (Show)---- | A monadic solver interface.------ This interface abstract the monadic interface of a solver. All the operations--- performed in the monad are using a single solver instance. The solver--- instance is management by the monad's @run@ function.-class MonadicSolver m where-  monadicSolverPush :: Int -> m ()-  monadicSolverPop :: Int -> m ()-  monadicSolverSolve :: SymBool -> m (Either SolvingFailure Model)---- | The commands that can be sent to a solver.-data SolverCommand-  = SolverSolve SymBool-  | SolverPush Int-  | SolverPop Int-  | SolverTerminate---- | A class that abstracts the solver interface.-class Solver handle where-  -- | Run a solver command.-  solverRunCommand ::-    (handle -> IO (Either SolvingFailure a)) ->-    handle ->-    SolverCommand ->-    IO (Either SolvingFailure a)--  -- | Solve a formula.-  solverSolve :: handle -> SymBool -> IO (Either SolvingFailure Model)--  -- | Push @n@ levels.-  solverPush :: handle -> Int -> IO (Either SolvingFailure ())-  solverPush handle n =-    solverRunCommand (const $ return $ Right ()) handle $ SolverPush n--  -- | Pop @n@ levels.-  solverPop :: handle -> Int -> IO (Either SolvingFailure ())-  solverPop handle n =-    solverRunCommand (const $ return $ Right ()) handle $ SolverPop n--  -- | Terminate the solver, wait until the last command is finished.-  solverTerminate :: handle -> IO ()--  -- | Force terminate the solver, do not wait for the last command to finish.-  solverForceTerminate :: handle -> IO ()---- | A class that abstracts the creation of a solver instance based on a--- configuration.------ The solver instance will need to be terminated by the user, with the solver--- interface.-class-  (Solver handle) =>-  ConfigurableSolver config handle-    | config -> handle-  where-  newSolver :: config -> IO handle---- | Start a solver, run a computation with the solver, and terminate the--- solver after the computation finishes.-withSolver ::-  (ConfigurableSolver config handle) =>-  config ->-  (handle -> IO a) ->-  IO a-withSolver config = bracket (newSolver config) solverTerminate---- | Solve a single formula. Find an assignment to it to make it true.------ >>> solve (precise z3) ("a" .&& ("b" :: SymInteger) .== 1)--- Right (Model {a -> True :: Bool, b -> 1 :: Integer})--- >>> solve (precise z3) ("a" .&& symNot "a")--- Left Unsat-solve ::-  (ConfigurableSolver config handle) =>-  -- | solver configuration-  config ->-  -- | formula to solve, the solver will try to make it true-  SymBool ->-  IO (Either SolvingFailure Model)-solve config formula = withSolver config (`solverSolve` formula)---- | 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")--- > [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) =>-  -- | solver configuration-  config ->-  -- | maximum number of models to return-  Int ->-  -- | formula to solve, the solver will try to make it true-  SymBool ->-  IO ([Model], SolvingFailure)-solveMulti config numOfModelRequested formula =-  withSolver config $ \solver -> do-    firstModel <- solverSolve solver formula-    case firstModel of-      Left err -> return ([], err)-      Right model -> do-        (models, err) <- go solver model numOfModelRequested-        return (model : models, err)-  where-    allSymbols = extractSymbolics formula :: SymbolSet-    go solver prevModel n-      | n <= 1 = return ([], ResultNumLimitReached)-      | otherwise = do-          let newFormula =-                S.foldl'-                  ( \acc (SomeTypedSymbol _ v) ->-                      acc-                        .|| (symNot (SymBool $ fromJust $ equation v prevModel))-                  )-                  (con False)-                  (unSymbolSet allSymbols)-          res <- solverSolve solver newFormula-          case res of-            Left err -> return ([], err)-            Right model -> do-              (models, err) <- go solver model (n - 1)-              return (model : models, err)---- | A class that abstracts the union-like structures that contains exceptions.-class UnionWithExcept t u e v | t -> u e v where-  -- | Extract a union of exceptions and values from the structure.-  extractUnionExcept :: t -> u (Either e v)--instance UnionWithExcept (ExceptT e u v) u e v where-  extractUnionExcept = runExceptT---- |--- Solver procedure for programs with error handling.------ >>> :set -XLambdaCase--- >>> import Control.Monad.Except--- >>> let x = "x" :: SymInteger--- >>> :{---   res :: ExceptT AssertionError UnionM ()---   res = do---     symAssert $ x .> 0       -- constrain that x is positive---     symAssert $ x .< 2       -- constrain that x is less than 2--- :}------ >>> :{---   translate (Left _) = con False -- errors are not desirable---   translate _ = con True         -- non-errors are desirable--- :}------ >>> solveExcept (precise z3) translate res--- Right (Model {x -> 1 :: Integer})-solveExcept ::-  ( UnionWithExcept t u e v,-    UnionPrjOp u,-    Functor u,-    ConfigurableSolver config handle-  ) =>-  -- | solver configuration-  config ->-  -- | mapping the results to symbolic boolean formulas, the solver would try to-  -- find a model to make the formula true-  (Either e v -> SymBool) ->-  -- | the program to be solved, should be a union of exception and values-  t ->-  IO (Either SolvingFailure Model)-solveExcept config f v = solve config (simpleMerge $ f <$> extractUnionExcept v)---- |--- Solver procedure for programs with error handling. Would return multiple--- models if possible.-solveMultiExcept ::-  ( UnionWithExcept t u e v,-    UnionPrjOp u,-    Functor u,-    ConfigurableSolver config handle-  ) =>-  -- | solver configuration-  config ->-  -- | maximum number of models to return-  Int ->-  -- | mapping the results to symbolic boolean formulas, the solver would try to-  -- find a model to make the formula true-  (Either e v -> SymBool) ->-  -- | the program to be solved, should be a union of exception and values-  t ->-  IO ([Model], SolvingFailure)-solveMultiExcept config n f v =-  solveMulti config n (simpleMerge $ f <$> extractUnionExcept v)
− src/Grisette/Core/Data/Class/SubstituteSym.hs 
@@ -1,318 +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.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.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,-    type (:*:) ((:*:)),-    type (:+:) (L1, R1),-  )-import Generics.Deriving.Instances ()-import Grisette.Core.Data.BV (IntN, SomeIntN, SomeWordN, WordN)-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term-  ( LinkedRep (underlyingTerm),-    SupportedPrim,-    TypedSymbol,-  )-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermSubstitution (substTerm)-import Grisette.IR.SymPrim.Data.SymPrim-  ( SomeSymIntN (SomeSymIntN),-    SomeSymWordN (SomeSymWordN),-    SymBool (SymBool),-    SymIntN (SymIntN),-    SymInteger (SymInteger),-    SymWordN (SymWordN),-    type (-~>) (SymGeneralFun),-    type (=~>) (SymTabularFun),-  )---- $setup--- >>> import Grisette.Core--- >>> import Grisette.IR.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(SomeWordN)-CONCRETE_SUBSTITUTESYM(SomeIntN)-CONCRETE_SUBSTITUTESYM(B.ByteString)-CONCRETE_SUBSTITUTESYM(T.Text)-CONCRETE_SUBSTITUTESYM_BV(WordN)-CONCRETE_SUBSTITUTESYM_BV(IntN)-#endif--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(op, cons) \-instance (SupportedPrim ca, SupportedPrim cb, LinkedRep ca sa, LinkedRep cb sb) => SubstituteSym (sa op sb) where \-  substituteSym sym v (cons t) = cons $ substTerm sym (underlyingTerm v) t--#define SUBSTITUTE_SYM_BV_SOME(somety, origty) \-instance SubstituteSym somety where \-  substituteSym sym v (somety (origty t)) = somety $ origty $ 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_BV_SOME(SomeSymIntN, SymIntN)-SUBSTITUTE_SYM_BV_SOME(SomeSymWordN, SymWordN)-#endif---- | 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 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
− src/Grisette/Core/Data/Class/SymRotate.hs 
@@ -1,64 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DerivingVia #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE UndecidableInstances #-}--module Grisette.Core.Data.Class.SymRotate-  ( SymRotate (..),-    DefaultFiniteBitsSymRotate (..),-  )-where--import Data.Bits (Bits (isSigned, rotate), FiniteBits (finiteBitSize))-import Data.Int (Int16, Int32, Int64, Int8)-import Data.Word (Word16, Word32, Word64, Word8)--class (Bits a) => SymRotate a where-  symRotate :: a -> a -> a--instance SymRotate Int where-  symRotate = rotate--newtype DefaultFiniteBitsSymRotate a = DefaultFiniteBitsSymRotate-  { unDefaultFiniteBitsSymRotate :: a-  }-  deriving newtype (Eq, Bits)--instance-  (Integral a, FiniteBits a) =>-  SymRotate (DefaultFiniteBitsSymRotate a)-  where-  symRotate (DefaultFiniteBitsSymRotate a) (DefaultFiniteBitsSymRotate s)-    | isSigned a = DefaultFiniteBitsSymRotate $ symRotateSigned a s-    | otherwise = DefaultFiniteBitsSymRotate $ symRotateUnsigned a s-    where-      symRotateUnsigned :: a -> a -> a-      symRotateUnsigned a s =-        rotate a (fromIntegral (s `mod` fromIntegral (finiteBitSize a)))-      symRotateSigned :: a -> a -> a-      symRotateSigned a s-        | finiteBitSize s == 1 = a-        | finiteBitSize s == 2 = rotate a (fromIntegral s)-        | otherwise =-            rotate a (fromIntegral (s `mod` fromIntegral (finiteBitSize a)))--deriving via (DefaultFiniteBitsSymRotate Int8) instance SymRotate Int8--deriving via (DefaultFiniteBitsSymRotate Int16) instance SymRotate Int16--deriving via (DefaultFiniteBitsSymRotate Int32) instance SymRotate Int32--deriving via (DefaultFiniteBitsSymRotate Int64) instance SymRotate Int64--deriving via (DefaultFiniteBitsSymRotate Word8) instance SymRotate Word8--deriving via (DefaultFiniteBitsSymRotate Word16) instance SymRotate Word16--deriving via (DefaultFiniteBitsSymRotate Word32) instance SymRotate Word32--deriving via (DefaultFiniteBitsSymRotate Word64) instance SymRotate Word64--deriving via (DefaultFiniteBitsSymRotate Word) instance SymRotate Word
− src/Grisette/Core/Data/Class/SymShift.hs 
@@ -1,73 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DerivingVia #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE UndecidableInstances #-}--module Grisette.Core.Data.Class.SymShift-  ( SymShift (..),-    DefaultFiniteBitsSymShift (..),-  )-where--import Data.Bits (Bits (isSigned, shift), FiniteBits (finiteBitSize))-import Data.Int (Int16, Int32, Int64, Int8)-import Data.Word (Word16, Word32, Word64, Word8)--class (Bits a) => SymShift a where-  symShift :: a -> a -> a--instance SymShift Int where-  symShift a s-    | s >= finiteBitSize s = 0-    | s <= -finiteBitSize s = if a >= 0 then 0 else -1-    | otherwise = shift a s--newtype DefaultFiniteBitsSymShift a = DefaultFiniteBitsSymShift-  { unDefaultFiniteBitsSymShift :: a-  }-  deriving newtype (Eq, Bits)--instance-  (Integral a, FiniteBits a) =>-  SymShift (DefaultFiniteBitsSymShift a)-  where-  symShift (DefaultFiniteBitsSymShift a) (DefaultFiniteBitsSymShift s)-    | isSigned a = DefaultFiniteBitsSymShift $ symShiftSigned a s-    | otherwise = DefaultFiniteBitsSymShift $ symShiftUnsigned a s-    where-      symShiftUnsigned :: (Integral a, FiniteBits a) => a -> a -> a-      symShiftUnsigned a s | s >= fromIntegral (finiteBitSize a) = 0-      symShiftUnsigned a s = shift a (fromIntegral s)--      symShiftSigned :: (Integral a, FiniteBits a) => a -> a -> a-      symShiftSigned a s | finiteBitSize s == 1 = a-      symShiftSigned a s-        | finiteBitSize s == 2 =-            if s == -2-              then if a < 0 then -1 else 0-              else shift a (fromIntegral s)-      symShiftSigned a s | s >= fromIntegral (finiteBitSize a) = 0-      symShiftSigned a s-        | s <= fromIntegral (-finiteBitSize a) =-            if a < 0 then -1 else 0-      symShiftSigned a s = shift a (fromIntegral s)--deriving via (DefaultFiniteBitsSymShift Int8) instance SymShift Int8--deriving via (DefaultFiniteBitsSymShift Int16) instance SymShift Int16--deriving via (DefaultFiniteBitsSymShift Int32) instance SymShift Int32--deriving via (DefaultFiniteBitsSymShift Int64) instance SymShift Int64--deriving via (DefaultFiniteBitsSymShift Word8) instance SymShift Word8--deriving via (DefaultFiniteBitsSymShift Word16) instance SymShift Word16--deriving via (DefaultFiniteBitsSymShift Word32) instance SymShift Word32--deriving via (DefaultFiniteBitsSymShift Word64) instance SymShift Word64--deriving via (DefaultFiniteBitsSymShift Word) instance SymShift Word
− src/Grisette/Core/Data/Class/ToCon.hs 
@@ -1,343 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DerivingVia #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}---- |--- Module      :   Grisette.Core.Data.Class.ToCon--- 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.Core.Data.Class.ToCon-  ( -- * Converting to concrete values-    ToCon (..),-  )-where--import Control.Monad.Except (ExceptT (ExceptT))-import Control.Monad.Identity-  ( Identity (Identity, runIdentity),-    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.Generics-  ( Generic (Rep, from, to),-    K1 (K1),-    M1 (M1),-    U1,-    type (:*:) ((:*:)),-    type (:+:) (L1, R1),-  )-import GHC.TypeNats (KnownNat, type (<=))-import Generics.Deriving (Default (Default))-import Generics.Deriving.Instances ()-import Grisette.Core.Control.Exception (AssertionError, VerificationConditions)-import Grisette.Core.Data.BV-  ( IntN (IntN),-    SomeIntN (SomeIntN),-    SomeWordN (SomeWordN),-    WordN (WordN),-  )-import Grisette.Core.Data.Class.Solvable (Solvable (conView), pattern Con)-import Grisette.IR.SymPrim.Data.IntBitwidth (intBitwidthQ)-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term-  ( LinkedRep,-    SupportedPrim,-    type (-->),-  )-import Grisette.IR.SymPrim.Data.SymPrim-  ( SomeSymIntN (SomeSymIntN),-    SomeSymWordN (SomeSymWordN),-    SymBool,-    SymIntN,-    SymInteger,-    SymWordN,-    type (-~>),-    type (=~>),-  )-import Grisette.IR.SymPrim.Data.TabularFun (type (=->))---- $setup--- >>> import Grisette.Core--- >>> import Grisette.IR.SymPrim---- | Convert a symbolic value to concrete value if possible.-class ToCon a b where-  -- | Convert a symbolic value to concrete value if possible.-  -- If the symbolic value cannot be converted to concrete, the result will be 'Nothing'.-  ---  -- >>> toCon (ssym "a" :: SymInteger) :: Maybe Integer-  -- Nothing-  ---  -- >>> toCon (con 1 :: SymInteger) :: Maybe Integer-  -- Just 1-  ---  -- 'toCon' works on complex types too.-  ---  -- >>> toCon ([con 1, con 2] :: [SymInteger]) :: Maybe [Integer]-  -- Just [1,2]-  ---  -- >>> toCon ([con 1, ssym "a"] :: [SymInteger]) :: Maybe [Integer]-  -- Nothing-  toCon :: a -> Maybe b--#define CONCRETE_TOCON(type) \-instance ToCon type type where \-  toCon = Just--#define CONCRETE_TOCON_BV(type) \-instance (KnownNat n, 1 <= n) => ToCon (type n) (type n) where \-  toCon = Just--#if 1-CONCRETE_TOCON(Bool)-CONCRETE_TOCON(Integer)-CONCRETE_TOCON(Char)-CONCRETE_TOCON(Int)-CONCRETE_TOCON(Int8)-CONCRETE_TOCON(Int16)-CONCRETE_TOCON(Int32)-CONCRETE_TOCON(Int64)-CONCRETE_TOCON(Word)-CONCRETE_TOCON(Word8)-CONCRETE_TOCON(Word16)-CONCRETE_TOCON(Word32)-CONCRETE_TOCON(Word64)-CONCRETE_TOCON(SomeWordN)-CONCRETE_TOCON(SomeIntN)-CONCRETE_TOCON(B.ByteString)-CONCRETE_TOCON(T.Text)-CONCRETE_TOCON_BV(WordN)-CONCRETE_TOCON_BV(IntN)-#endif---- 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--#define TO_CON_SYMID_BV(symtype) \-instance (KnownNat n, 1 <= n) => ToCon (symtype n) (symtype n) where \-  toCon = Just--#define TO_CON_SYMID_FUN(op) \-instance (SupportedPrim a, SupportedPrim b) => ToCon (a op b) (a op b) where \-  toCon = Just--#if 1-TO_CON_SYMID_SIMPLE(SymBool)-TO_CON_SYMID_SIMPLE(SymInteger)-TO_CON_SYMID_BV(SymIntN)-TO_CON_SYMID_BV(SymWordN)-TO_CON_SYMID_FUN(=~>)-TO_CON_SYMID_FUN(-~>)-TO_CON_SYMID_SIMPLE(SomeSymIntN)-TO_CON_SYMID_SIMPLE(SomeSymWordN)--#endif--#define TO_CON_FROMSYM_SIMPLE(contype, symtype) \-instance ToCon symtype contype where \-  toCon = conView--#define TO_CON_FROMSYM_BV(contype, symtype) \-instance (KnownNat n, 1 <= n) => ToCon (symtype n) (contype n) where \-  toCon = conView--#define TO_CON_FROMSYM_FUN(conop, symop) \-instance (SupportedPrim ca, SupportedPrim cb, LinkedRep ca sa, LinkedRep cb sb) => ToCon (symop sa sb) (conop ca cb) where \-  toCon = conView--#define TO_CON_FROMSYM_BV_SOME(contype, symtype) \-instance ToCon symtype contype where \-  toCon (symtype v) = contype <$> conView v--#if 1-TO_CON_FROMSYM_SIMPLE(Bool, SymBool)-TO_CON_FROMSYM_SIMPLE(Integer, SymInteger)-TO_CON_FROMSYM_BV(IntN, SymIntN)-TO_CON_FROMSYM_BV(WordN, SymWordN)-TO_CON_FROMSYM_FUN((=->), (=~>))-TO_CON_FROMSYM_FUN((-->), (-~>))-TO_CON_FROMSYM_BV_SOME(SomeIntN, SomeSymIntN)-TO_CON_FROMSYM_BV_SOME(SomeWordN, SomeSymWordN)-#endif--#define TOCON_MACHINE_INTEGER(sbvw, bvw, n, int) \-instance ToCon (sbvw n) int where \-  toCon (Con (bvw v :: bvw n)) = Just $ fromIntegral v; \-  toCon _ = Nothing--#if 1-TOCON_MACHINE_INTEGER(SymIntN, IntN, 8, Int8)-TOCON_MACHINE_INTEGER(SymIntN, IntN, 16, Int16)-TOCON_MACHINE_INTEGER(SymIntN, IntN, 32, Int32)-TOCON_MACHINE_INTEGER(SymIntN, IntN, 64, Int64)-TOCON_MACHINE_INTEGER(SymWordN, WordN, 8, Word8)-TOCON_MACHINE_INTEGER(SymWordN, WordN, 16, Word16)-TOCON_MACHINE_INTEGER(SymWordN, WordN, 32, Word32)-TOCON_MACHINE_INTEGER(SymWordN, WordN, 64, Word64)-TOCON_MACHINE_INTEGER(SymIntN, IntN, $intBitwidthQ, Int)-TOCON_MACHINE_INTEGER(SymWordN, WordN, $intBitwidthQ, Word)-#endif--deriving via-  (Default AssertionError)-  instance-    ToCon AssertionError AssertionError--deriving via-  (Default VerificationConditions)-  instance-    ToCon VerificationConditions VerificationConditions---- 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--class ToCon' a b where-  toCon' :: a c -> Maybe (b c)--instance ToCon' U1 U1 where-  toCon' = Just--instance (ToCon a b) => ToCon' (K1 i a) (K1 i b) where-  toCon' (K1 a) = K1 <$> toCon a--instance (ToCon' a b) => ToCon' (M1 i c1 a) (M1 i c2 b) where-  toCon' (M1 a) = M1 <$> toCon' 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--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
− src/Grisette/Core/Data/Class/ToSym.hs 
@@ -1,349 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DerivingVia #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}---- |--- Module      :   Grisette.Core.Data.Class.ToSym--- 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.Core.Data.Class.ToSym-  ( -- * Converting to symbolic values-    ToSym (..),-  )-where--import Control.Monad.Identity-  ( Identity (Identity),-    IdentityT (IdentityT),-  )-import Control.Monad.Reader (ReaderT (ReaderT))-import qualified Control.Monad.State.Lazy as StateLazy-import qualified Control.Monad.State.Strict as StateStrict-import Control.Monad.Trans.Except (ExceptT (ExceptT))-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, to),-    K1 (K1),-    M1 (M1),-    U1,-    type (:*:) ((:*:)),-    type (:+:) (L1, R1),-  )-import Grisette.Core.Control.Exception (AssertionError, VerificationConditions)-import Grisette.Core.Data.BV-  ( IntN,-    SomeIntN (SomeIntN),-    SomeWordN (SomeWordN),-    WordN,-  )-import Grisette.Core.Data.Class.Solvable (Solvable (con))-import Grisette.IR.SymPrim.Data.IntBitwidth (intBitwidthQ)-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term-  ( LinkedRep,-    SupportedPrim,-    type (-->),-  )-import Grisette.IR.SymPrim.Data.SymPrim-  ( SomeSymIntN (SomeSymIntN),-    SomeSymWordN (SomeSymWordN),-    SymBool,-    SymIntN,-    SymInteger,-    SymWordN,-    type (-~>),-    type (=~>),-  )-import Grisette.IR.SymPrim.Data.TabularFun (type (=->))---- $setup--- >>> import Grisette.IR.SymPrim---- | Convert a concrete value to symbolic value.-class ToSym a b where-  -- | Convert a concrete value to symbolic value.-  ---  -- >>> toSym False :: SymBool-  -- false-  ---  -- >>> toSym [False, True] :: [SymBool]-  -- [false,true]-  toSym :: a -> b--#define CONCRETE_TOSYM(type) \-instance ToSym type type where \-  toSym = id--#define CONCRETE_TOSYM_BV(type) \-instance (KnownNat n, 1 <= n) => ToSym (type n) (type n) where \-  toSym = id--#if 1-CONCRETE_TOSYM(Bool)-CONCRETE_TOSYM(Integer)-CONCRETE_TOSYM(Char)-CONCRETE_TOSYM(Int)-CONCRETE_TOSYM(Int8)-CONCRETE_TOSYM(Int16)-CONCRETE_TOSYM(Int32)-CONCRETE_TOSYM(Int64)-CONCRETE_TOSYM(Word)-CONCRETE_TOSYM(Word8)-CONCRETE_TOSYM(Word16)-CONCRETE_TOSYM(Word32)-CONCRETE_TOSYM(Word64)-CONCRETE_TOSYM(SomeIntN)-CONCRETE_TOSYM(SomeWordN)-CONCRETE_TOSYM(B.ByteString)-CONCRETE_TOSYM(T.Text)-CONCRETE_TOSYM_BV(IntN)-CONCRETE_TOSYM_BV(WordN)-#endif---- 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--#define TO_SYM_SYMID_BV(symtype) \-instance (KnownNat n, 1 <= n) => ToSym (symtype n) (symtype n) where \-  toSym = id--#define TO_SYM_SYMID_FUN(op) \-instance (SupportedPrim a, SupportedPrim b) => ToSym (a op b) (a op b) where \-  toSym = id--#if 1-TO_SYM_SYMID_SIMPLE(SymBool)-TO_SYM_SYMID_SIMPLE(SymInteger)-TO_SYM_SYMID_BV(SymIntN)-TO_SYM_SYMID_BV(SymWordN)-TO_SYM_SYMID_FUN(=~>)-TO_SYM_SYMID_FUN(-~>)-TO_SYM_SYMID_SIMPLE(SomeSymIntN)-TO_SYM_SYMID_SIMPLE(SomeSymWordN)-#endif--#define TO_SYM_FROMCON_SIMPLE(contype, symtype) \-instance ToSym contype symtype where \-  toSym = con--#define TO_SYM_FROMCON_BV(contype, symtype) \-instance (KnownNat n, 1 <= n) => ToSym (contype n) (symtype n) where \-  toSym = con--#define TO_SYM_FROMCON_FUN(conop, symop) \-instance (SupportedPrim ca, SupportedPrim cb, LinkedRep ca sa, LinkedRep cb sb) => ToSym (conop ca cb) (symop sa sb) where \-  toSym = con--#define TO_SYM_FROMCON_BV_SOME(contype, symtype) \-instance ToSym contype symtype where \-  toSym (contype v) = symtype (con v)--#if 1-TO_SYM_FROMCON_SIMPLE(Bool, SymBool)-TO_SYM_FROMCON_SIMPLE(Integer, SymInteger)-TO_SYM_FROMCON_BV(IntN, SymIntN)-TO_SYM_FROMCON_BV(WordN, SymWordN)-TO_SYM_FROMCON_FUN((=->), (=~>))-TO_SYM_FROMCON_FUN((-->), (-~>))-TO_SYM_FROMCON_BV_SOME(SomeIntN, SomeSymIntN)-TO_SYM_FROMCON_BV_SOME(SomeWordN, SomeSymWordN)-#endif--#define TO_SYM_FROMBV_SOME(somesymbv, bv) \-instance (KnownNat n, 1 <= n) => ToSym (bv n) somesymbv where \-  toSym = somesymbv . con--#if 1-TO_SYM_FROMBV_SOME(SomeSymIntN, IntN)-TO_SYM_FROMBV_SOME(SomeSymWordN, WordN)-#endif--#define TOSYM_MACHINE_INTEGER(int, bv) \-instance ToSym int (bv) where \-  toSym = fromIntegral--#define TOSYM_MACHINE_INTEGER_SOME(int, somesymbv, bv, bitwidth) \-instance ToSym int somesymbv where \-  toSym v = somesymbv (con (fromIntegral v :: bv bitwidth))--#if 1-TOSYM_MACHINE_INTEGER(Int8, SymIntN 8)-TOSYM_MACHINE_INTEGER(Int16, SymIntN 16)-TOSYM_MACHINE_INTEGER(Int32, SymIntN 32)-TOSYM_MACHINE_INTEGER(Int64, SymIntN 64)-TOSYM_MACHINE_INTEGER(Word8, SymWordN 8)-TOSYM_MACHINE_INTEGER(Word16, SymWordN 16)-TOSYM_MACHINE_INTEGER(Word32, SymWordN 32)-TOSYM_MACHINE_INTEGER(Word64, SymWordN 64)-TOSYM_MACHINE_INTEGER(Int, SymIntN $intBitwidthQ)-TOSYM_MACHINE_INTEGER(Word, SymWordN $intBitwidthQ)--TOSYM_MACHINE_INTEGER_SOME(Int8, SomeSymIntN, IntN, 8)-TOSYM_MACHINE_INTEGER_SOME(Int16, SomeSymIntN, IntN, 16)-TOSYM_MACHINE_INTEGER_SOME(Int32, SomeSymIntN, IntN, 32)-TOSYM_MACHINE_INTEGER_SOME(Int64, SomeSymIntN, IntN, 64)-TOSYM_MACHINE_INTEGER_SOME(Word8, SomeSymWordN, WordN, 8)-TOSYM_MACHINE_INTEGER_SOME(Word16, SomeSymWordN, WordN, 16)-TOSYM_MACHINE_INTEGER_SOME(Word32, SomeSymWordN, WordN, 32)-TOSYM_MACHINE_INTEGER_SOME(Word64, SomeSymWordN, WordN, 64)-TOSYM_MACHINE_INTEGER_SOME(Int, SomeSymIntN, IntN, $intBitwidthQ)-TOSYM_MACHINE_INTEGER_SOME(Word, SomeSymWordN, WordN, $intBitwidthQ)-#endif---- Exception-deriving via-  (Default AssertionError)-  instance-    ToSym AssertionError AssertionError--deriving via-  (Default VerificationConditions)-  instance-    ToSym VerificationConditions VerificationConditions--instance (Generic a, Generic b, ToSym' (Rep a) (Rep b)) => ToSym a (Default b) where-  toSym = Default . to . toSym' . from--class ToSym' a b where-  toSym' :: a c -> b c--instance ToSym' U1 U1 where-  toSym' = id--instance (ToSym a b) => ToSym' (K1 i a) (K1 i b) where-  toSym' (K1 a) = K1 $ toSym a--instance (ToSym' a b) => ToSym' (M1 i c1 a) (M1 i c2 b) where-  toSym' (M1 a) = M1 $ toSym' 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--instance (ToSym' a1 a2, ToSym' b1 b2) => ToSym' (a1 :*: b1) (a2 :*: b2) where-  toSym' (a :*: b) = toSym' a :*: toSym' b
− src/Grisette/Core/Data/FileLocation.hs 
@@ -1,94 +0,0 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveLift #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE Trustworthy #-}--{- HLINT ignore "Unused LANGUAGE pragma" -}---- |--- Module      :   Grisette.Core.Data.FileLocation--- 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.Core.Data.FileLocation-  ( -- * Symbolic constant generation with location-    FileLocation (..),-    nameWithLoc,-    slocsym,-    ilocsym,-  )-where--import Control.DeepSeq (NFData)-import Data.Hashable (Hashable)-import qualified Data.Text as T-import Debug.Trace.LocationTH (__LOCATION__)-import GHC.Generics (Generic)-import Grisette.Core.Data.Class.GenSym (FreshIdent, nameWithInfo)-import Grisette.Core.Data.Class.Solvable-  ( Solvable (iinfosym, sinfosym),-  )-import Language.Haskell.TH.Syntax (Lift, unsafeTExpCoerce)-import Language.Haskell.TH.Syntax.Compat (SpliceQ, liftSplice)---- $setup--- >>> import Grisette.Core--- >>> import Grisette.IR.SymPrim--- >>> :set -XTemplateHaskell---- File location type.-data FileLocation = FileLocation {locPath :: String, locLineno :: Int, locSpan :: (Int, Int)}-  deriving (Eq, Ord, Generic, Lift, NFData, Hashable)--instance Show FileLocation where-  show (FileLocation p l (s1, s2)) = p ++ ":" ++ show l ++ ":" ++ show s1 ++ "-" ++ show s2--parseFileLocation :: String -> FileLocation-parseFileLocation str =-  let r = reverse str-      (s2, r1) = break (== '-') r-      (s1, r2) = break (== ':') $ tail r1-      (l, p) = break (== ':') $ tail r2-   in FileLocation (reverse $ tail p) (read $ reverse l) (read $ reverse s1, read $ reverse s2)---- | Identifier with the current location as extra information.------ >>> $$(nameWithLoc "a") -- a sample result could be "a:<interactive>:18:4-18"--- a:<interactive>:...------ The uniqueness is ensured for the call to 'nameWithLoc' at different location.-nameWithLoc :: T.Text -> SpliceQ FreshIdent-nameWithLoc s = [||nameWithInfo s (parseFileLocation $$(liftSplice $ unsafeTExpCoerce __LOCATION__))||]---- | Generate simply-named symbolic variables. The file location will be--- attached to the identifier.------ >>> $$(slocsym "a") :: SymBool--- a:<interactive>:...------ Calling 'slocsymb' with the same name at different location will always--- generate different symbolic constants. Calling 'slocsymb' at the same--- location for multiple times will generate the same symbolic constants.------ >>> ($$(slocsym "a") :: SymBool) == $$(slocsym "a")--- False--- >>> let f _ = $$(slocsym "a") :: SymBool--- >>> f () == f ()--- True-slocsym :: (Solvable c s) => T.Text -> SpliceQ s-slocsym nm = [||sinfosym nm (parseFileLocation $$(liftSplice $ unsafeTExpCoerce __LOCATION__))||]---- | Generate indexed symbolic variables. The file location will be attached to identifier.------ >>> $$(ilocsym "a" 1) :: SymBool--- a@1:<interactive>:...------ Calling 'ilocsymb' with the same name and index at different location will--- always generate different symbolic constants. Calling 'slocsymb' at the same--- location for multiple times will generate the same symbolic constants.-ilocsym :: (Solvable c s) => T.Text -> Int -> SpliceQ s-ilocsym nm idx = [||iinfosym nm idx (parseFileLocation $$(liftSplice $ unsafeTExpCoerce __LOCATION__))||]
− src/Grisette/Core/Data/MemoUtils.hs 
@@ -1,62 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE TypeFamilies #-}---- |--- Module      :   Grisette.Core.Data.MemoUtils--- 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.Core.Data.MemoUtils-  ( -- * Hashtable-based memoization-    htmemo,-    htmemo2,-    htmemo3,-    htmup,-    htmemoFix,-  )-where--import Data.Function (fix)-import qualified Data.HashTable.IO as H-import Data.Hashable (Hashable)-import System.IO.Unsafe (unsafePerformIO)--type HashTable k v = H.BasicHashTable k v---- | Function memoizer with mutable hash table.-htmemo :: (Eq k, Hashable k) => (k -> a) -> k -> a-htmemo f = unsafePerformIO $ do-  cache <- H.new :: IO (HashTable k v)-  return $ \x -> unsafePerformIO $ do-    tryV <- H.lookup cache x-    case tryV of-      Nothing -> do-        -- traceM "New value"-        let v = f x-        H.insert cache x v-        return v-      Just v -> return v---- | Lift a memoizer to work with one more argument.-htmup :: (Eq k, Hashable k) => (b -> c) -> (k -> b) -> (k -> c)-htmup mem f = htmemo (mem . f)---- | Function memoizer with mutable hash table. Works on binary functions.-htmemo2 :: (Eq k1, Hashable k1, Eq k2, Hashable k2) => (k1 -> k2 -> a) -> (k1 -> k2 -> a)-htmemo2 = htmup htmemo---- | Function memoizer with mutable hash table. Works on ternary functions.-htmemo3 ::-  (Eq k1, Hashable k1, Eq k2, Hashable k2, Eq k3, Hashable k3) =>-  (k1 -> k2 -> k3 -> a) ->-  (k1 -> k2 -> k3 -> a)-htmemo3 = htmup htmemo2---- | Memoizing recursion. Use like 'fix'.-htmemoFix :: (Eq k, Hashable k) => ((k -> a) -> (k -> a)) -> k -> a-htmemoFix h = fix (htmemo . h)
− src/Grisette/Core/Data/Union.hs 
@@ -1,305 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveLift #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE TypeFamilies #-}---- |--- Module      :   Grisette.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.Core.Data.Union-  ( -- * The union data structure.--    -- | Please consider using 'Grisette.Core.Control.Monad.UnionM' instead.-    Union (..),-    ifWithLeftMost,-    ifWithStrategy,-    fullReconstruct,-  )-where--import Control.DeepSeq (NFData (rnf), NFData1 (liftRnf), rnf1)-import Data.Functor.Classes-  ( Eq1 (liftEq),-    Show1 (liftShowsPrec),-    showsPrec1,-    showsUnaryWith,-  )-import Data.Hashable (Hashable (hashWithSalt))-import GHC.Generics (Generic, Generic1)-import Grisette.Core.Data.Class.GPretty-  ( GPretty (gprettyPrec),-    condEnclose,-  )-import Grisette.Core.Data.Class.ITEOp (ITEOp (symIte))-import Grisette.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.&&), (.||)))-import Grisette.Core.Data.Class.Mergeable-  ( Mergeable (rootStrategy),-    Mergeable1 (liftRootStrategy),-    MergingStrategy (NoStrategy, SimpleStrategy, SortedStrategy),-  )-import Grisette.Core.Data.Class.SimpleMergeable-  ( SimpleMergeable (mrgIte),-    SimpleMergeable1 (liftMrgIte),-    UnionLike-      ( mergeWithStrategy,-        mrgIfWithStrategy,-        mrgSingleWithStrategy,-        single,-        unionIf-      ),-    UnionPrjOp (ifView, leftMost, singleView),-    mrgIf,-  )-import Grisette.Core.Data.Class.Solvable (pattern Con)-import Grisette.IR.SymPrim.Data.SymPrim-  ( AllSyms (allSymsS),-    SomeSym (SomeSym),-    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-  = -- | A single value-    UnionSingle a-  | -- | A if value-    UnionIf-      a-      -- ^ Cached leftmost value-      !Bool-      -- ^ Is merged invariant already maintained?-      !SymBool-      -- ^ If condition-      (Union a)-      -- ^ True branch-      (Union a)-      -- ^ False branch-  deriving (Generic, Eq, Lift, Generic1)--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 UnionPrjOp 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 (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 UnionLike Union where-  mergeWithStrategy = fullReconstruct-  {-# INLINE mergeWithStrategy #-}-  single = UnionSingle-  {-# INLINE single #-}-  unionIf = ifWithLeftMost False-  {-# INLINE unionIf #-}-  mrgIfWithStrategy = ifWithStrategy-  {-# INLINE mrgIfWithStrategy #-}-  mrgSingleWithStrategy _ = UnionSingle-  {-# INLINE mrgSingleWithStrategy #-}--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 #-}
− src/Grisette/Core/TH.hs 
@@ -1,142 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TemplateHaskellQuotes #-}-{-# LANGUAGE Trustworthy #-}---- |--- Module      :   Grisette.Core.TH--- 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.Core.TH-  ( -- * Template Haskell procedures for building constructor wrappers-    makeUnionWrapper,-    makeUnionWrapper',-  )-where--import Control.Monad (join, replicateM, when, zipWithM)-import Grisette.Core.THCompat (augmentFinalType)-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),-    Q,-    Type (ForallT),-    mkName,-    newName,-    pprint,-    reify,-  )-import Language.Haskell.TH.Syntax (Name (Name), OccName (OccName))---- | Generate constructor wrappers that wraps the result in a union-like monad with provided names.------ > $(makeUnionWrapper' ["mrgTuple2"] ''(,))------ generates------ > mrgTuple2 :: (SymBoolOp bool, Monad u, Mergeable bool t1, Mergeable bool t2, MonadUnion bool u) => t1 -> t2 -> u (t1, t2)--- > mrgTuple2 = \v1 v2 -> mrgSingle (v1, v2)-makeUnionWrapper' ::-  -- | Names for generated wrappers-  [String] ->-  -- | The type to generate the wrappers for-  Name ->-  Q [Dec]-makeUnionWrapper' 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 makeUnionWrapper' 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 union-like monad.------ > $(makeUnionWrapper "mrg" ''Maybe)------ generates------ > mrgNothing :: (SymBoolOp bool, Monad u, Mergeable bool t, MonadUnion bool u) => u (Maybe t)--- > mrgNothing = mrgSingle Nothing--- > mrgJust :: (SymBoolOp bool, Monad u, Mergeable bool t, MonadUnion bool u) => t -> u (Maybe t)--- > mrgJust = \x -> mrgSingle (Just x)-makeUnionWrapper ::-  -- | Prefix for generated wrappers-  String ->-  -- | The type to generate the wrappers for-  Name ->-  Q [Dec]-makeUnionWrapper prefix typName = do-  constructors <- getConstructors typName-  constructorNames <- mapM getConstructorName constructors-  makeUnionWrapper' ((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)-      )--augmentNormalCType :: Type -> Q Type-augmentNormalCType (ForallT tybinders ctx ty1) = do-  ((bndrs, preds), augmentedTyp) <- augmentFinalType ty1-  return $ ForallT (bndrs ++ tybinders) (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
− src/Grisette/Core/THCompat.hs 
@@ -1,74 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TemplateHaskellQuotes #-}-{-# LANGUAGE Trustworthy #-}---- |--- Module      :   Grisette.Core.THCompat--- 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.Core.THCompat (augmentFinalType) where--import Data.Bifunctor (Bifunctor (second))-import Grisette.Core.Control.Monad.UnionM (UnionM)-import Grisette.Core.Data.Class.Mergeable (Mergeable)-#if MIN_VERSION_template_haskell(2,17,0)-import Language.Haskell.TH.Syntax-  ( Pred,-    Q,-    Specificity,-    TyVarBndr,-    Type-      ( AppT,-        ArrowT,-        MulArrowT-      ),-  )-#else-import Language.Haskell.TH.Syntax-  ( Pred,-    Q,-    TyVarBndr,-    Type-      ( AppT,-        ArrowT-      ),-  )-#endif--#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-  unionType <- [t|UnionM|]-  mergeable <- [t|Mergeable|]-#if MIN_VERSION_template_haskell(2,17,0)-  return-    ( ( [ ],-        [ AppT mergeable t-        ]-      ),-      AppT unionType t-    )-#elif MIN_VERSION_template_haskell(2,16,0)-  return-    ( ( [ ],-        [ AppT mergeable t-        ]-      ),-      AppT unionType t-    )-#endif
src/Grisette/Experimental.hs view
@@ -1,6 +1,14 @@ -- Disable this warning because we are re-exporting things. {-# OPTIONS_GHC -Wno-missing-import-lists #-} +-- |+-- Module      :   Grisette.Experimental+-- 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.Experimental   ( -- * Experimental features @@ -19,18 +27,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,
src/Grisette/Experimental/GenSymConstrained.hs view
@@ -11,6 +11,14 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +-- |+-- Module      :   Grisette.Experimental.GenSymConstrained+-- 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.Experimental.GenSymConstrained   ( -- * Symbolic value generation with errors     GenSymConstrained (..),@@ -22,9 +30,9 @@     derivedSimpleFreshConstrainedSameShape,      -- * Some common GenSymConstrained specifications-    SOrdUpperBound (..),-    SOrdLowerBound (..),-    SOrdBound (..),+    SymOrdUpperBound (..),+    SymOrdLowerBound (..),+    SymOrdBound (..),   ) where @@ -38,13 +46,12 @@     type (:*:) ((:*:)),     type (:+:) (L1, R1),   )-import Grisette.Core.Control.Monad.UnionM-  ( UnionM,-    liftToMonadUnion,+import Grisette.Internal.Core.Control.Monad.Class.Union (MonadUnion)+import Grisette.Internal.Core.Control.Monad.Union+  ( Union,   )-import Grisette.Core.Data.Class.GenSym-  ( FreshIdent,-    GenSym (fresh),+import Grisette.Internal.Core.Data.Class.GenSym+  ( GenSym (fresh),     GenSymSimple (simpleFresh),     ListSpec (ListSpec),     MonadFresh,@@ -53,22 +60,23 @@     chooseUnionFresh,     runFreshT,   )-import Grisette.Core.Data.Class.LogicalOp (LogicalOp ((.||)))-import Grisette.Core.Data.Class.Mergeable (Mergeable, Mergeable1)-import Grisette.Core.Data.Class.SOrd (SOrd ((.<), (.>=)))-import Grisette.Core.Data.Class.SimpleMergeable-  ( UnionLike,-    merge,-    mrgIf,-    mrgSingle,+import Grisette.Internal.Core.Data.Class.LogicalOp (LogicalOp ((.||)))+import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable, Mergeable1)+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,+  )+import Grisette.Internal.Core.Data.Class.UnionView (liftUnion)+import Grisette.Internal.Core.Data.Symbol (Identifier)  -- $setup -- >>> import Grisette.Core -- >>> import Grisette.Experimental--- >>> import Grisette.IR.SymPrim--- >>> :set -XOverloadedStrings--- >>> :set -XTypeApplications+-- >>> import Grisette.SymPrim  -- | Class of types in which symbolic values can be generated with some -- specification.@@ -80,26 +88,28 @@   --   -- 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 <If (<= 1 a@0) (Left ()) (Right {a@0})>   freshConstrained ::-    (MonadFresh m, MonadError e m, UnionLike m) =>+    (MonadFresh m, MonadError e m, MonadUnion m) =>     e ->     spec ->-    m (UnionM a)+    m (Union a)   default freshConstrained ::     (GenSymSimpleConstrained spec a) =>     ( MonadFresh m,       MonadError e m,-      UnionLike m+      MonadUnion m     ) =>     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 -> FreshIdent -> ExceptT e UnionM (UnionM a)-genSymConstrained e spec = merge . runFreshT (freshConstrained e spec)+-- | Generates a symbolic value with the given specification, also place the+-- necessary constraints.+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 -- specification.@@ -111,16 +121,18 @@   --   -- 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 <If (<= 1 a@0) (Left ()) (Right a@0)>   simpleFreshConstrained ::-    (MonadFresh m, MonadError e m, UnionLike m) =>+    (MonadFresh m, MonadError e m, MonadUnion m) =>     e ->     spec ->     m a -genSymSimpleConstrained :: forall spec a e. (GenSymSimpleConstrained spec a, Mergeable e) => e -> spec -> FreshIdent -> ExceptT e UnionM a-genSymSimpleConstrained e spec = merge . runFreshT (simpleFreshConstrained e spec)+-- | Generates a symbolic value with the given specification, also place the+-- necessary constraints.+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   freshConstrained _ = fresh@@ -130,57 +142,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+    v <- liftUnion 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+    v <- liftUnion 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+    v <- liftUnion 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@@ -191,8 +203,8 @@   ) =>   GenSymConstrained (Either aspec bspec) (Either a b)   where-  freshConstrained e (Left aspec) = merge $ (merge . fmap Left) <$> freshConstrained e aspec-  freshConstrained e (Right bspec) = merge $ (merge . fmap Right) <$> freshConstrained e bspec+  freshConstrained e (Left aspec) = tryMerge $ (tryMerge . fmap Left) <$> freshConstrained e aspec+  freshConstrained e (Right bspec) = tryMerge $ (tryMerge . fmap Right) <$> freshConstrained e bspec  instance   ( GenSymSimpleConstrained a a,@@ -214,19 +226,19 @@   GenSymConstrained (Maybe aspec) (Maybe a)   where   freshConstrained _ Nothing = mrgSingle $ mrgSingle Nothing-  freshConstrained e (Just aspec) = merge $ (merge . fmap Just) <$> freshConstrained e aspec+  freshConstrained e (Just aspec) = tryMerge $ (tryMerge . fmap Just) <$> freshConstrained e aspec  instance   (GenSymSimpleConstrained aspec a) =>   GenSymSimpleConstrained (Maybe aspec) (Maybe a)   where   simpleFreshConstrained _ Nothing = mrgSingle Nothing-  simpleFreshConstrained e (Just aspec) = merge $ Just <$> simpleFreshConstrained e aspec+  simpleFreshConstrained e (Just aspec) = tryMerge $ Just <$> simpleFreshConstrained e aspec  instance (GenSymConstrained aspec a, Mergeable a) => GenSymConstrained aspec (Maybe a) where   freshConstrained e aspec = do-    a :: UnionM a <- freshConstrained e aspec-    merge $ chooseUnionFresh [return Nothing, Just <$> a]+    a :: Union a <- freshConstrained e aspec+    tryMerge $ chooseUnionFresh [return Nothing, Just <$> a]  -- List instance@@ -236,9 +248,9 @@   freshConstrained e v = do     l <- gl e v     let xs = reverse $ scanr (:) [] l-    merge $ chooseUnionFresh $ merge . sequence <$> xs+    tryMerge $ chooseUnionFresh $ tryMerge . sequence <$> xs     where-      gl :: (MonadFresh m, MonadError e m, UnionLike 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@@ -256,9 +268,9 @@       else do         l <- gl e maxLen         let xs = drop minLen $ reverse $ scanr (:) [] l-        merge $ chooseUnionFresh $ merge . sequence <$> xs+        tryMerge $ chooseUnionFresh $ tryMerge . sequence <$> xs     where-      gl :: (MonadFresh m, MonadError e m, UnionLike 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@@ -271,8 +283,8 @@   GenSymConstrained [a] [a]   where   freshConstrained e l = do-    r :: [UnionM a] <- traverse (freshConstrained e) l-    mrgSingle $ merge $ sequence r+    r :: [Union a] <- traverse (freshConstrained e) l+    mrgSingle $ tryMerge $ sequence r  instance   (GenSymSimpleConstrained a a) =>@@ -288,9 +300,9 @@     if len < 0       then error $ "Bad lengths: " ++ show len       else do-        merge $ merge . sequence <$> gl e len+        tryMerge $ tryMerge . sequence <$> gl e len     where-      gl :: (MonadFresh m, MonadError e m, UnionLike 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@@ -308,7 +320,7 @@       else do         gl e len     where-      gl :: (MonadFresh m, MonadError e m, UnionLike m) => e -> Int -> m [a]+      gl :: (MonadFresh m, MonadError e m, MonadUnion m) => e -> Int -> m [a]       gl e1 currLen         | currLen <= 0 = mrgSingle []         | otherwise = do@@ -340,7 +352,7 @@   GenSymSimpleConstrained (aspec, bspec) (a, b)   where   simpleFreshConstrained e (aspec, bspec) = do-    merge $+    tryMerge $       (,)         <$> simpleFreshConstrained e aspec         <*> simpleFreshConstrained e bspec@@ -374,7 +386,7 @@   GenSymSimpleConstrained (aspec, bspec, cspec) (a, b, c)   where   simpleFreshConstrained e (aspec, bspec, cspec) = do-    merge $+    tryMerge $       (,,)         <$> simpleFreshConstrained e aspec         <*> simpleFreshConstrained e bspec@@ -414,7 +426,7 @@   GenSymSimpleConstrained (aspec, bspec, cspec, dspec) (a, b, c, d)   where   simpleFreshConstrained e (aspec, bspec, cspec, dspec) = do-    merge $+    tryMerge $       (,,,)         <$> simpleFreshConstrained e aspec         <*> simpleFreshConstrained e bspec@@ -460,7 +472,7 @@   GenSymSimpleConstrained (aspec, bspec, cspec, dspec, espec) (a, b, c, d, e)   where   simpleFreshConstrained e (aspec, bspec, cspec, dspec, espec) = do-    merge $+    tryMerge $       (,,,,)         <$> simpleFreshConstrained e aspec         <*> simpleFreshConstrained e bspec@@ -512,7 +524,7 @@   GenSymSimpleConstrained (aspec, bspec, cspec, dspec, espec, fspec) (a, b, c, d, e, f)   where   simpleFreshConstrained e (aspec, bspec, cspec, dspec, espec, fspec) = do-    merge $+    tryMerge $       (,,,,,)         <$> simpleFreshConstrained e aspec         <*> simpleFreshConstrained e bspec@@ -570,7 +582,7 @@   GenSymSimpleConstrained (aspec, bspec, cspec, dspec, espec, fspec, gspec) (a, b, c, d, e, f, g)   where   simpleFreshConstrained e (aspec, bspec, cspec, dspec, espec, fspec, gspec) = do-    merge $+    tryMerge $       (,,,,,,)         <$> simpleFreshConstrained e aspec         <*> simpleFreshConstrained e bspec@@ -634,7 +646,7 @@   GenSymSimpleConstrained (aspec, bspec, cspec, dspec, espec, fspec, gspec, hspec) (a, b, c, d, e, f, g, h)   where   simpleFreshConstrained e (aspec, bspec, cspec, dspec, espec, fspec, gspec, hspec) = do-    merge $+    tryMerge $       (,,,,,,,)         <$> simpleFreshConstrained e aspec         <*> simpleFreshConstrained e bspec@@ -656,7 +668,7 @@   where   freshConstrained e v = do     x <- freshConstrained e v-    mrgSingle $ merge . fmap MaybeT $ x+    mrgSingle $ tryMerge . fmap MaybeT $ x  instance   {-# OVERLAPPABLE #-}@@ -666,7 +678,7 @@   ) =>   GenSymSimpleConstrained spec (MaybeT m a)   where-  simpleFreshConstrained e v = merge $ MaybeT <$> simpleFreshConstrained e v+  simpleFreshConstrained e v = tryMerge $ MaybeT <$> simpleFreshConstrained e v  instance   {-# OVERLAPPING #-}@@ -676,7 +688,7 @@   ) =>   GenSymSimpleConstrained (MaybeT m a) (MaybeT m a)   where-  simpleFreshConstrained e (MaybeT v) = merge $ MaybeT <$> simpleFreshConstrained e v+  simpleFreshConstrained e (MaybeT v) = tryMerge $ MaybeT <$> simpleFreshConstrained e v  instance   {-# OVERLAPPING #-}@@ -698,7 +710,7 @@   where   freshConstrained e v = do     x <- freshConstrained e v-    mrgSingle $ merge . fmap ExceptT $ x+    mrgSingle $ tryMerge . fmap ExceptT $ x  instance   {-# OVERLAPPABLE #-}@@ -709,7 +721,7 @@   ) =>   GenSymSimpleConstrained spec (ExceptT a m b)   where-  simpleFreshConstrained e v = merge $ ExceptT <$> simpleFreshConstrained e v+  simpleFreshConstrained e v = tryMerge $ ExceptT <$> simpleFreshConstrained e v  instance   {-# OVERLAPPING #-}@@ -720,7 +732,7 @@   ) =>   GenSymSimpleConstrained (ExceptT e m a) (ExceptT e m a)   where-  simpleFreshConstrained e (ExceptT v) = merge $ ExceptT <$> simpleFreshConstrained e v+  simpleFreshConstrained e (ExceptT v) = tryMerge $ ExceptT <$> simpleFreshConstrained e v  instance   {-# OVERLAPPING #-}@@ -737,10 +749,10 @@   freshConstrainedNoSpec ::     ( MonadFresh m,       MonadError e m,-      UnionLike m+      MonadUnion m     ) =>     e ->-    m (UnionM (a c))+    m (Union (a c))  instance GenSymConstrainedNoSpec U1 where   freshConstrainedNoSpec _ = return $ mrgSingle U1@@ -763,14 +775,14 @@     forall m c e.     ( MonadFresh m,       MonadError e m,-      UnionLike m+      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@@ -781,13 +793,13 @@     forall m c e.     ( MonadFresh m,       MonadError e m,-      UnionLike m+      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@@ -808,18 +820,18 @@     Mergeable a,     MonadFresh m,     MonadError e m,-    UnionLike m+    MonadUnion m   ) =>   e ->   () ->-  m (UnionM a)-derivedFreshConstrainedNoSpec e _ = merge $ (merge . fmap to) <$> freshConstrainedNoSpec e+  m (Union a)+derivedFreshConstrainedNoSpec e _ = tryMerge $ (tryMerge . fmap to) <$> freshConstrainedNoSpec e  class GenSymSimpleConstrainedNoSpec a where   simpleFreshConstrainedNoSpec ::     ( MonadFresh m,       MonadError e m,-      UnionLike m+      MonadUnion m     ) =>     e ->     m (a c)@@ -847,7 +859,7 @@ -- your own types. -- -- This 'simpleFreshConstrained' 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.@@ -857,19 +869,19 @@     GenSymSimpleConstrainedNoSpec (Rep a),     MonadFresh m,     MonadError e m,-    UnionLike m,+    MonadUnion m,     Mergeable a   ) =>   e ->   () ->   m a-derivedSimpleFreshConstrainedNoSpec e _ = merge $ (merge . fmap to) $ simpleFreshConstrainedNoSpec e+derivedSimpleFreshConstrainedNoSpec e _ = tryMerge $ (tryMerge . fmap to) $ simpleFreshConstrainedNoSpec e  class GenSymConstrainedSameShape a where   simpleFreshConstrainedSameShape ::     ( MonadFresh m,       MonadError e m,-      UnionLike m+      MonadUnion m     ) =>     e ->     a c ->@@ -918,9 +930,9 @@     Mergeable a,     MonadFresh m,     MonadError e m,-    UnionLike m+    MonadUnion m   ) =>   e ->   a ->   m a-derivedSimpleFreshConstrainedSameShape e a = merge $ (merge . fmap to) $ simpleFreshConstrainedSameShape e (from a)+derivedSimpleFreshConstrainedSameShape e a = tryMerge $ (tryMerge . fmap to) $ simpleFreshConstrainedSameShape e (from a)
+ src/Grisette/Experimental/MonadParallelUnion.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE LambdaCase #-}++-- |+-- Module      :   Grisette.Experimental.MonadParallelUnion+-- Copyright   :   (c) Sirui Lu 2023+-- License     :   BSD-3-Clause (see the LICENSE file)+--+-- Maintainer  :   siruilu@cs.washington.edu+-- Stability   :   Experimental+-- Portability :   GHC only+module Grisette.Experimental.MonadParallelUnion+  ( MonadParallelUnion (..),+  )+where++import Control.DeepSeq (NFData, force)+import Control.Monad.Except (ExceptT (ExceptT), runExceptT)+import Control.Monad.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 Control.Parallel.Strategies (rpar, rseq, runEval)+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.UnionBase (UnionBase (UnionIf, UnionSingle))++-- | Parallel union monad.+--+-- With the @QualifiedDo@ extension and the "Grisette.Qualified.ParallelUnionDo"+-- module, one can execute the paths in parallel and merge the results with:+--+-- > import Grisette+-- > import qualified Grisette.Qualified.ParallelUnionDo as P+-- > P.do+-- >   x <- mrgIf "a" (return 1) (return 2) :: Union Int+-- >   return $ x + 1+-- >+-- > -- {If a 2 3}+class (MonadUnion m, TryMerge m) => MonadParallelUnion m where+  parBindUnion :: (Mergeable b, NFData b) => m a -> (a -> m b) -> m b++instance (MonadParallelUnion m) => MonadParallelUnion (MaybeT m) where+  parBindUnion (MaybeT x) f =+    MaybeT $+      x `parBindUnion` \case+        Nothing -> return Nothing+        Just x'' -> runMaybeT $ f x''+  {-# INLINE parBindUnion #-}++instance (MonadParallelUnion m, Mergeable e, NFData e) => MonadParallelUnion (ExceptT e m) where+  parBindUnion (ExceptT x) f =+    ExceptT $+      x `parBindUnion` \case+        Left e -> return $ Left e+        Right x'' -> runExceptT $ f x''+  {-# INLINE parBindUnion #-}++instance (MonadParallelUnion m, Mergeable s, NFData s) => MonadParallelUnion (StateLazy.StateT s m) where+  parBindUnion (StateLazy.StateT x) f = StateLazy.StateT $ \s ->+    x s `parBindUnion` \case+      ~(a, s') -> StateLazy.runStateT (f a) s'+  {-# INLINE parBindUnion #-}++instance (MonadParallelUnion m, Mergeable s, NFData s) => MonadParallelUnion (StateStrict.StateT s m) where+  parBindUnion (StateStrict.StateT x) f = StateStrict.StateT $ \s ->+    x s `parBindUnion` \case+      (a, s') -> StateStrict.runStateT (f a) s'+  {-# INLINE parBindUnion #-}++instance (MonadParallelUnion m, Mergeable s, Monoid s, NFData s) => MonadParallelUnion (WriterLazy.WriterT s m) where+  parBindUnion (WriterLazy.WriterT x) f =+    WriterLazy.WriterT $+      x `parBindUnion` \case+        ~(a, w) ->+          WriterLazy.runWriterT (f a) `parBindUnion` \case+            ~(b, w') -> return (b, w <> w')+  {-# INLINE parBindUnion #-}++instance (MonadParallelUnion m, Mergeable s, Monoid s, NFData s) => MonadParallelUnion (WriterStrict.WriterT s m) where+  parBindUnion (WriterStrict.WriterT x) f =+    WriterStrict.WriterT $+      x `parBindUnion` \case+        (a, w) ->+          WriterStrict.runWriterT (f a) `parBindUnion` \case+            (b, w') -> return (b, w <> w')+  {-# INLINE parBindUnion #-}++instance (MonadParallelUnion m, Mergeable a, NFData a) => MonadParallelUnion (ReaderT a m) where+  parBindUnion (ReaderT x) f = ReaderT $ \a ->+    x a `parBindUnion` \a' -> runReaderT (f a') a+  {-# INLINE parBindUnion #-}++instance (MonadParallelUnion m) => MonadParallelUnion (IdentityT m) where+  parBindUnion (IdentityT x) f = IdentityT $ x `parBindUnion` (tryMerge . runIdentityT . f)+  {-# INLINE parBindUnion #-}++instance+  (MonadParallelUnion m, Mergeable s, Mergeable r, Mergeable w, Monoid w, NFData r, NFData w, NFData s) =>+  MonadParallelUnion (RWSStrict.RWST r w s m)+  where+  parBindUnion m k = RWSStrict.RWST $ \r s ->+    RWSStrict.runRWST m r s `parBindUnion` \case+      (a, s', w) ->+        RWSStrict.runRWST (k a) r s' `parBindUnion` \case+          (b, s'', w') -> return (b, s'', w <> w')+  {-# INLINE parBindUnion #-}++instance+  (MonadParallelUnion m, Mergeable s, Mergeable r, Mergeable w, Monoid w, NFData r, NFData w, NFData s) =>+  MonadParallelUnion (RWSLazy.RWST r w s m)+  where+  parBindUnion m k = RWSLazy.RWST $ \r s ->+    RWSLazy.runRWST m r s `parBindUnion` \case+      ~(a, s', w) ->+        RWSLazy.runRWST (k a) r s' `parBindUnion` \case+          ~(b, s'', w') -> return (b, s'', w <> w')+  {-# INLINE parBindUnion #-}++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) => 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'+  r <- rpar $ force $ parBindUnion' ifFalse f'+  l' <- rseq l+  r' <- rseq r+  rseq $ mrgIf cond l' r'+{-# INLINE parBindUnion' #-}++instance MonadParallelUnion Union where+  parBindUnion = parBindUnion'' . unionBase+  {-# INLINE parBindUnion #-}
+ src/Grisette/Experimental/Qualified/ParallelUnionDo.hs view
@@ -0,0 +1,24 @@+-- |+-- Module      :   Grisette.Qualified.ParallelUnionDo+-- Copyright   :   (c) Sirui Lu 2023+-- License     :   BSD-3-Clause (see the LICENSE file)+--+-- Maintainer  :   siruilu@cs.washington.edu+-- Stability   :   Experimental+-- Portability :   GHC only+module Grisette.Experimental.Qualified.ParallelUnionDo ((>>=), (>>)) where++import Control.Parallel.Strategies (NFData)+import Grisette.Experimental.MonadParallelUnion+  ( MonadParallelUnion (parBindUnion),+  )+import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable)+import Prelude (const, ($))++-- | Parallel '(>>=)' operation.+(>>=) :: (MonadParallelUnion m, Mergeable b, NFData b) => m a -> (a -> m b) -> m b+(>>=) = parBindUnion++-- | Parallel '(>>)' operation.+(>>) :: (MonadParallelUnion m, Mergeable b, NFData b) => m a -> m b -> m b+(>>) a b = parBindUnion a $ const b
− src/Grisette/IR/SymPrim.hs 
@@ -1,87 +0,0 @@-{-# LANGUAGE ExplicitNamespaces #-}--- Disable this warning because we are re-exporting things.-{-# OPTIONS_GHC -Wno-missing-import-lists #-}---- |--- Module      :   Grisette.IR.SymPrim--- 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.IR.SymPrim-  ( -- * Symbolic type implementation--    -- ** Extended types-    IntN,-    WordN,-    SomeWordN (..),-    SomeIntN (..),-    type (=->) (..),-    type (-->),-    (-->),--    -- ** Symbolic types-    SupportedPrim,-    SymRep (SymType),-    ConRep (ConType),-    LinkedRep,-    SymBool (..),-    SymInteger (..),-    SymWordN (..),-    SymIntN (..),-    SomeSymWordN (..),-    SomeSymIntN (..),-    type (=~>) (..),-    type (-~>) (..),-    TypedSymbol (..),-    symSize,-    symsSize,-    AllSyms (..),-    allSymsSize,--    -- ** Symbolic constant sets and models-    SymbolSet (..),-    Model (..),-    ModelValuePair (..),-    ModelSymPair (..),-  )-where--import Grisette.Core.Data.BV-  ( IntN,-    SomeIntN (..),-    SomeWordN (..),-    WordN,-  )-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term-  ( ConRep (..),-    LinkedRep,-    SupportedPrim,-    SymRep (..),-    TypedSymbol (..),-    type (-->),-  )-import Grisette.IR.SymPrim.Data.Prim.Model-  ( Model (..),-    ModelValuePair (..),-    SymbolSet (..),-  )-import Grisette.IR.SymPrim.Data.SymPrim-  ( AllSyms (..),-    ModelSymPair (..),-    SomeSymIntN (..),-    SomeSymWordN (..),-    SymBool (..),-    SymIntN (..),-    SymInteger (..),-    SymWordN (..),-    allSymsSize,-    symSize,-    symsSize,-    (-->),-    type (-~>) (..),-    type (=~>) (..),-  )-import Grisette.IR.SymPrim.Data.TabularFun (type (=->) (..))
− src/Grisette/IR/SymPrim/Data/IntBitwidth.hs 
@@ -1,15 +0,0 @@--- |--- Module      :   Grisette.IR.SymPrim.Data.IntBitwidth--- 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.IR.SymPrim.Data.IntBitwidth (intBitwidthQ) where--import Data.Bits (FiniteBits (finiteBitSize))-import Language.Haskell.TH (TyLit (NumTyLit), Type (LitT), TypeQ)--intBitwidthQ :: TypeQ-intBitwidthQ = return $ LitT (NumTyLit $ toInteger $ finiteBitSize (undefined :: Int))
− src/Grisette/IR/SymPrim/Data/Prim/Helpers.hs 
@@ -1,124 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE ViewPatterns #-}---- |--- Module      :   Grisette.IR.SymPrim.Data.Prim.Helpers--- 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.IR.SymPrim.Data.Prim.Helpers-  ( pattern UnaryTermPatt,-    pattern BinaryTermPatt,-    pattern TernaryTermPatt,-    pattern UnsafeUnaryTermPatt,-    pattern UnsafeBinaryTermPatt,-    pattern Unsafe1t21BinaryTermPatt,-    pattern Unsafe1u2t32TernaryTermPatt,-  )-where--import Data.Typeable (Typeable, cast)-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term-  ( Term (BinaryTerm, TernaryTerm, UnaryTerm),-  )-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermUtils-  ( castTerm,-  )-import Unsafe.Coerce (unsafeCoerce)--unsafeUnaryTermView :: forall a b tag. (Typeable tag) => Term a -> Maybe (tag, Term b)-unsafeUnaryTermView (UnaryTerm _ (tag :: tagt) t1) =-  case cast tag of-    Just t -> Just (t, unsafeCoerce t1)-    Nothing -> Nothing--- (,) <$> cast tag <*> castTerm t1-unsafeUnaryTermView _ = Nothing--pattern UnsafeUnaryTermPatt :: forall a b tag. (Typeable tag) => tag -> Term b -> Term a-pattern UnsafeUnaryTermPatt tag t <- (unsafeUnaryTermView @a @b @tag -> Just (tag, t))--unaryTermView :: forall a b tag. (Typeable tag, Typeable b) => Term a -> Maybe (tag, Term b)-unaryTermView (UnaryTerm _ (tag :: tagt) t1) =-  (,) <$> cast tag <*> castTerm t1-unaryTermView _ = Nothing--pattern UnaryTermPatt :: forall a b tag. (Typeable tag, Typeable b) => tag -> Term b -> Term a-pattern UnaryTermPatt tag t <- (unaryTermView @a @b @tag -> Just (tag, t))--unsafeBinaryTermView :: forall a b c tag. (Typeable tag) => Term a -> Maybe (tag, Term b, Term c)-unsafeBinaryTermView (BinaryTerm _ (tag :: tagt) t1 t2) =-  case cast tag of-    Just t -> Just (t, unsafeCoerce t1, unsafeCoerce t2)-    Nothing -> Nothing--- (,) <$> cast tag <*> castTerm t1-unsafeBinaryTermView _ = Nothing--pattern UnsafeBinaryTermPatt :: forall a b c tag. (Typeable tag) => tag -> Term b -> Term c -> Term a-pattern UnsafeBinaryTermPatt tag t1 t2 <- (unsafeBinaryTermView @a @b @c @tag -> Just (tag, t1, t2))--unsafe1t21BinaryTermView :: forall a b tag. (Typeable tag, Typeable b) => Term a -> Maybe (tag, Term b, Term b)-unsafe1t21BinaryTermView (BinaryTerm _ (tag :: tagt) t1 t2) =-  case (cast tag, cast t1) of-    (Just tg, Just t1') -> Just (tg, t1', unsafeCoerce t2)-    _ -> Nothing--- (,) <$> cast tag <*> castTerm t1-unsafe1t21BinaryTermView _ = Nothing--pattern Unsafe1t21BinaryTermPatt :: forall a b tag. (Typeable tag, Typeable b) => tag -> Term b -> Term b -> Term a-pattern Unsafe1t21BinaryTermPatt tag t1 t2 <- (unsafe1t21BinaryTermView @a @b @tag -> Just (tag, t1, t2))--binaryTermView :: forall a b c tag. (Typeable tag, Typeable b, Typeable c) => Term a -> Maybe (tag, Term b, Term c)-binaryTermView (BinaryTerm _ (tag :: tagt) t1 t2) =-  (,,) <$> cast tag <*> castTerm t1 <*> castTerm t2-binaryTermView _ = Nothing--pattern BinaryTermPatt :: forall a b c tag. (Typeable tag, Typeable b, Typeable c) => tag -> Term b -> Term c -> Term a-pattern BinaryTermPatt tag l r <- (binaryTermView @a @b @c @tag -> Just (tag, l, r))--unsafe1u2t32TernaryTermView ::-  forall a b c tag.-  (Typeable tag, Typeable c) =>-  Term a ->-  Maybe (tag, Term b, Term c, Term c)-unsafe1u2t32TernaryTermView (TernaryTerm _ (tag :: tagt) t1 t2 t3) =-  case (cast tag, castTerm t2) of-    (Just tg, Just t2') -> Just (tg, unsafeCoerce t1, t2', unsafeCoerce t3)-    _ -> Nothing-unsafe1u2t32TernaryTermView _ = Nothing--pattern Unsafe1u2t32TernaryTermPatt ::-  forall a b c tag.-  (Typeable tag, Typeable c) =>-  tag ->-  Term b ->-  Term c ->-  Term c ->-  Term a-pattern Unsafe1u2t32TernaryTermPatt tag a b c <--  (unsafe1u2t32TernaryTermView @a @b @c @tag -> Just (tag, a, b, c))--ternaryTermView ::-  forall a b c d tag.-  (Typeable tag, Typeable b, Typeable c, Typeable d) =>-  Term a ->-  Maybe (tag, Term b, Term c, Term d)-ternaryTermView (TernaryTerm _ (tag :: tagt) t1 t2 t3) =-  (,,,) <$> cast tag <*> castTerm t1 <*> castTerm t2 <*> castTerm t3-ternaryTermView _ = Nothing--pattern TernaryTermPatt ::-  forall a b c d tag.-  (Typeable tag, Typeable b, Typeable c, Typeable d) =>-  tag ->-  Term b ->-  Term c ->-  Term d ->-  Term a-pattern TernaryTermPatt tag a b c <- (ternaryTermView @a @b @c @d @tag -> Just (tag, a, b, c))
− src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/Caches.hs 
@@ -1,55 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# OPTIONS_GHC -fno-cse #-}---- |--- Module      :   Grisette.IR.SymPrim.Data.Prim.InternedTerm.Caches--- 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.IR.SymPrim.Data.Prim.InternedTerm.Caches (typeMemoizedCache) where--import Control.Concurrent-  ( forkIO,-    newEmptyMVar,-    putMVar,-    readMVar,-    takeMVar,-    tryPutMVar,-  )-import Data.Data (Proxy (Proxy), TypeRep, Typeable, typeRep)-import qualified Data.HashMap.Strict as M-import Data.IORef (IORef, atomicModifyIORef', newIORef)-import Data.Interned (Cache, Interned, mkCache)-import GHC.Base (Any)-import GHC.IO (unsafeDupablePerformIO, unsafePerformIO)-import Unsafe.Coerce (unsafeCoerce)--mkOnceIO :: IO a -> IO (IO a)-mkOnceIO io = do-  mv <- newEmptyMVar-  demand <- newEmptyMVar-  forkIO (takeMVar demand >> io >>= putMVar mv)-  return (tryPutMVar demand () >> readMVar mv)--termCacheCell :: IO (IORef (M.HashMap TypeRep Any))-termCacheCell = unsafePerformIO $ mkOnceIO $ newIORef M.empty-{-# NOINLINE termCacheCell #-}--typeMemoizedCache :: forall a. (Interned a, Typeable a) => Cache a-typeMemoizedCache = unsafeDupablePerformIO $ do-  c <- termCacheCell-  atomicModifyIORef' c $ \m ->-    case M.lookup (typeRep (Proxy @a)) m of-      Just d -> (m, unsafeCoerce d)-      Nothing -> (M.insert (typeRep (Proxy @a)) (unsafeCoerce r1) m, r1)-        where-          r1 :: Cache a-          !r1 = mkCache-          {-# NOINLINE r1 #-}
− src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/InternedCtors.hs 
@@ -1,448 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE QuantifiedConstraints #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}---- |--- Module      :   Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors--- 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.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors-  ( constructUnary,-    constructBinary,-    constructTernary,-    conTerm,-    symTerm,-    ssymTerm,-    isymTerm,-    sinfosymTerm,-    iinfosymTerm,-    notTerm,-    orTerm,-    andTerm,-    eqvTerm,-    iteTerm,-    addNumTerm,-    uminusNumTerm,-    timesNumTerm,-    absNumTerm,-    signumNumTerm,-    ltNumTerm,-    leNumTerm,-    andBitsTerm,-    orBitsTerm,-    xorBitsTerm,-    complementBitsTerm,-    shiftLeftTerm,-    shiftRightTerm,-    rotateLeftTerm,-    rotateRightTerm,-    toSignedTerm,-    toUnsignedTerm,-    bvconcatTerm,-    bvselectTerm,-    bvextendTerm,-    bvsignExtendTerm,-    bvzeroExtendTerm,-    tabularFunApplyTerm,-    generalFunApplyTerm,-    divIntegralTerm,-    modIntegralTerm,-    quotIntegralTerm,-    remIntegralTerm,-    divBoundedIntegralTerm,-    modBoundedIntegralTerm,-    quotBoundedIntegralTerm,-    remBoundedIntegralTerm,-  )-where--import Control.DeepSeq (NFData)-import Data.Array ((!))-import Data.Bits (Bits, FiniteBits)-import qualified Data.HashMap.Strict as M-import Data.Hashable (Hashable (hash))-import Data.IORef (atomicModifyIORef')-import Data.Interned-  ( Interned (Uninterned, cache, cacheWidth, describe, identify),-  )-import Data.Interned.Internal-  ( Cache (getCache),-    CacheState (CacheState),-  )-import qualified Data.Text as T-import GHC.IO (unsafeDupablePerformIO)-import GHC.TypeNats (KnownNat, type (+), type (<=))-import Grisette.Core.Data.Class.BitVector-  ( SizedBV,-  )-import Grisette.Core.Data.Class.SignConversion (SignConversion)-import Grisette.Core.Data.Class.SymRotate (SymRotate)-import Grisette.Core.Data.Class.SymShift (SymShift)-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term-  ( BinaryOp,-    SupportedPrim,-    Term,-    TernaryOp,-    TypedSymbol (IndexedSymbol, SimpleSymbol, WithInfo),-    UTerm-      ( UAbsNumTerm,-        UAddNumTerm,-        UAndBitsTerm,-        UAndTerm,-        UBVConcatTerm,-        UBVExtendTerm,-        UBVSelectTerm,-        UBinaryTerm,-        UComplementBitsTerm,-        UConTerm,-        UDivBoundedIntegralTerm,-        UDivIntegralTerm,-        UEqvTerm,-        UGeneralFunApplyTerm,-        UITETerm,-        ULENumTerm,-        ULTNumTerm,-        UModBoundedIntegralTerm,-        UModIntegralTerm,-        UNotTerm,-        UOrBitsTerm,-        UOrTerm,-        UQuotBoundedIntegralTerm,-        UQuotIntegralTerm,-        URemBoundedIntegralTerm,-        URemIntegralTerm,-        URotateLeftTerm,-        URotateRightTerm,-        UShiftLeftTerm,-        UShiftRightTerm,-        USignumNumTerm,-        USymTerm,-        UTabularFunApplyTerm,-        UTernaryTerm,-        UTimesNumTerm,-        UToSignedTerm,-        UToUnsignedTerm,-        UUMinusNumTerm,-        UUnaryTerm,-        UXorBitsTerm-      ),-    UnaryOp,-    type (-->),-  )-import Grisette.IR.SymPrim.Data.TabularFun-  ( type (=->),-  )-import Language.Haskell.TH.Syntax (Lift)-import Type.Reflection (Typeable, typeRep)--internTerm :: forall t. (SupportedPrim t) => Uninterned (Term t) -> Term t-internTerm !bt = unsafeDupablePerformIO $ atomicModifyIORef' slot go-  where-    slot = getCache cache ! r-    !dt = describe bt-    !hdt = hash dt-    !wid = cacheWidth dt-    r = hdt `mod` wid-    go (CacheState i m) = case M.lookup dt m of-      Nothing -> let t = identify (wid * i + r) bt in (CacheState (i + 1) (M.insert dt t m), t)-      Just t -> (CacheState i m, t)--constructUnary ::-  forall tag arg t.-  (SupportedPrim t, UnaryOp tag arg t, Typeable tag, Typeable t, Show tag) =>-  tag ->-  Term arg ->-  Term t-constructUnary tag tm = let x = internTerm $ UUnaryTerm tag tm in x-{-# INLINE constructUnary #-}--constructBinary ::-  forall tag arg1 arg2 t.-  (SupportedPrim t, BinaryOp tag arg1 arg2 t, Typeable tag, Typeable t, Show tag) =>-  tag ->-  Term arg1 ->-  Term arg2 ->-  Term t-constructBinary tag tm1 tm2 = internTerm $ UBinaryTerm tag tm1 tm2-{-# INLINE constructBinary #-}--constructTernary ::-  forall tag arg1 arg2 arg3 t.-  (SupportedPrim t, TernaryOp tag arg1 arg2 arg3 t, Typeable tag, Typeable t, Show tag) =>-  tag ->-  Term arg1 ->-  Term arg2 ->-  Term arg3 ->-  Term t-constructTernary tag tm1 tm2 tm3 = internTerm $ UTernaryTerm tag tm1 tm2 tm3-{-# INLINE constructTernary #-}--conTerm :: (SupportedPrim t, Typeable t, Hashable t, Eq t, Show t) => t -> Term t-conTerm t = internTerm $ UConTerm t-{-# INLINE conTerm #-}--symTerm :: forall t. (SupportedPrim t, Typeable t) => TypedSymbol t -> Term t-symTerm t = internTerm $ USymTerm t-{-# INLINE symTerm #-}--ssymTerm :: (SupportedPrim t, Typeable t) => T.Text -> Term t-ssymTerm = symTerm . SimpleSymbol-{-# INLINE ssymTerm #-}--isymTerm :: (SupportedPrim t, Typeable t) => T.Text -> Int -> Term t-isymTerm str idx = symTerm $ IndexedSymbol str idx-{-# INLINE isymTerm #-}--sinfosymTerm ::-  (SupportedPrim t, Typeable t, Typeable a, Ord a, Lift a, NFData a, Show a, Hashable a) =>-  T.Text ->-  a ->-  Term t-sinfosymTerm s info = symTerm $ WithInfo (SimpleSymbol s) info-{-# INLINE sinfosymTerm #-}--iinfosymTerm ::-  (SupportedPrim t, Typeable t, Typeable a, Ord a, Lift a, NFData a, Show a, Hashable a) =>-  T.Text ->-  Int ->-  a ->-  Term t-iinfosymTerm str idx info = symTerm $ WithInfo (IndexedSymbol str idx) info-{-# INLINE iinfosymTerm #-}--notTerm :: Term Bool -> Term Bool-notTerm = internTerm . UNotTerm-{-# INLINE notTerm #-}--orTerm :: Term Bool -> Term Bool -> Term Bool-orTerm l r = internTerm $ UOrTerm l r-{-# INLINE orTerm #-}--andTerm :: Term Bool -> Term Bool -> Term Bool-andTerm l r = internTerm $ UAndTerm l r-{-# INLINE andTerm #-}--eqvTerm :: (SupportedPrim a) => Term a -> Term a -> Term Bool-eqvTerm l r = internTerm $ UEqvTerm l r-{-# INLINE eqvTerm #-}--iteTerm :: (SupportedPrim a) => Term Bool -> Term a -> Term a -> Term a-iteTerm c l r = internTerm $ UITETerm c l r-{-# INLINE iteTerm #-}--addNumTerm :: (SupportedPrim a, Num a) => Term a -> Term a -> Term a-addNumTerm l r = internTerm $ UAddNumTerm l r-{-# INLINE addNumTerm #-}--uminusNumTerm :: (SupportedPrim a, Num a) => Term a -> Term a-uminusNumTerm = internTerm . UUMinusNumTerm-{-# INLINE uminusNumTerm #-}--timesNumTerm :: (SupportedPrim a, Num a) => Term a -> Term a -> Term a-timesNumTerm l r = internTerm $ UTimesNumTerm l r-{-# INLINE timesNumTerm #-}--absNumTerm :: (SupportedPrim a, Num a) => Term a -> Term a-absNumTerm = internTerm . UAbsNumTerm-{-# INLINE absNumTerm #-}--signumNumTerm :: (SupportedPrim a, Num a) => Term a -> Term a-signumNumTerm = internTerm . USignumNumTerm-{-# INLINE signumNumTerm #-}--ltNumTerm :: (SupportedPrim a, Num a, Ord a) => Term a -> Term a -> Term Bool-ltNumTerm l r = internTerm $ ULTNumTerm l r-{-# INLINE ltNumTerm #-}--leNumTerm :: (SupportedPrim a, Num a, Ord a) => Term a -> Term a -> Term Bool-leNumTerm l r = internTerm $ ULENumTerm l r-{-# INLINE leNumTerm #-}--andBitsTerm :: (SupportedPrim a, Bits a) => Term a -> Term a -> Term a-andBitsTerm l r = internTerm $ UAndBitsTerm l r-{-# INLINE andBitsTerm #-}--orBitsTerm :: (SupportedPrim a, Bits a) => Term a -> Term a -> Term a-orBitsTerm l r = internTerm $ UOrBitsTerm l r-{-# INLINE orBitsTerm #-}--xorBitsTerm :: (SupportedPrim a, Bits a) => Term a -> Term a -> Term a-xorBitsTerm l r = internTerm $ UXorBitsTerm l r-{-# INLINE xorBitsTerm #-}--complementBitsTerm :: (SupportedPrim a, Bits a) => Term a -> Term a-complementBitsTerm = internTerm . UComplementBitsTerm-{-# INLINE complementBitsTerm #-}--shiftLeftTerm :: (SupportedPrim a, Integral a, FiniteBits a, SymShift a) => Term a -> Term a -> Term a-shiftLeftTerm t n = internTerm $ UShiftLeftTerm t n-{-# INLINE shiftLeftTerm #-}--shiftRightTerm :: (SupportedPrim a, Integral a, FiniteBits a, SymShift a) => Term a -> Term a -> Term a-shiftRightTerm t n = internTerm $ UShiftRightTerm t n-{-# INLINE shiftRightTerm #-}--rotateLeftTerm :: (SupportedPrim a, Integral a, FiniteBits a, SymRotate a) => Term a -> Term a -> Term a-rotateLeftTerm t n = internTerm $ URotateLeftTerm t n-{-# INLINE rotateLeftTerm #-}--rotateRightTerm :: (SupportedPrim a, Integral a, FiniteBits a, SymRotate a) => Term a -> Term a -> Term a-rotateRightTerm t n = internTerm $ URotateRightTerm t n-{-# INLINE rotateRightTerm #-}--toSignedTerm ::-  ( SupportedPrim u,-    SupportedPrim s,-    SignConversion u s-  ) =>-  Term u ->-  Term s-toSignedTerm = internTerm . UToSignedTerm--toUnsignedTerm ::-  ( SupportedPrim u,-    SupportedPrim s,-    SignConversion u s-  ) =>-  Term s ->-  Term u-toUnsignedTerm = internTerm . UToUnsignedTerm--bvconcatTerm ::-  ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n),-    Typeable bv,-    KnownNat a,-    KnownNat b,-    KnownNat (a + b),-    1 <= a,-    1 <= b,-    1 <= a + b,-    SizedBV bv-  ) =>-  Term (bv a) ->-  Term (bv b) ->-  Term (bv (a + b))-bvconcatTerm l r = internTerm $ UBVConcatTerm l r-{-# INLINE bvconcatTerm #-}--bvselectTerm ::-  forall bv n ix w p q.-  ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n),-    Typeable bv,-    KnownNat n,-    KnownNat ix,-    KnownNat w,-    1 <= n,-    1 <= w,-    ix + w <= n,-    SizedBV bv-  ) =>-  p ix ->-  q w ->-  Term (bv n) ->-  Term (bv w)-bvselectTerm _ _ v = internTerm $ UBVSelectTerm (typeRep @ix) (typeRep @w) v-{-# INLINE bvselectTerm #-}--bvextendTerm ::-  forall bv l r proxy.-  ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n),-    Typeable bv,-    KnownNat l,-    KnownNat r,-    1 <= l,-    1 <= r,-    l <= r,-    SizedBV bv-  ) =>-  Bool ->-  proxy r ->-  Term (bv l) ->-  Term (bv r)-bvextendTerm signed _ v = internTerm $ UBVExtendTerm signed (typeRep @r) v-{-# INLINE bvextendTerm #-}--bvsignExtendTerm ::-  forall bv l r proxy.-  ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n),-    Typeable bv,-    KnownNat l,-    KnownNat r,-    1 <= l,-    1 <= r,-    l <= r,-    SizedBV bv-  ) =>-  proxy r ->-  Term (bv l) ->-  Term (bv r)-bvsignExtendTerm _ v = internTerm $ UBVExtendTerm True (typeRep @r) v-{-# INLINE bvsignExtendTerm #-}--bvzeroExtendTerm ::-  forall bv l r proxy.-  ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n),-    Typeable bv,-    KnownNat l,-    KnownNat r,-    1 <= l,-    1 <= r,-    l <= r,-    SizedBV bv-  ) =>-  proxy r ->-  Term (bv l) ->-  Term (bv r)-bvzeroExtendTerm _ v = internTerm $ UBVExtendTerm False (typeRep @r) v-{-# INLINE bvzeroExtendTerm #-}--tabularFunApplyTerm :: (SupportedPrim a, SupportedPrim b) => Term (a =-> b) -> Term a -> Term b-tabularFunApplyTerm f a = internTerm $ UTabularFunApplyTerm f a-{-# INLINE tabularFunApplyTerm #-}--generalFunApplyTerm :: (SupportedPrim a, SupportedPrim b) => Term (a --> b) -> Term a -> Term b-generalFunApplyTerm f a = internTerm $ UGeneralFunApplyTerm f a-{-# INLINE generalFunApplyTerm #-}--divIntegralTerm :: (SupportedPrim a, Integral a) => Term a -> Term a -> Term a-divIntegralTerm l r = internTerm $ UDivIntegralTerm l r-{-# INLINE divIntegralTerm #-}--modIntegralTerm :: (SupportedPrim a, Integral a) => Term a -> Term a -> Term a-modIntegralTerm l r = internTerm $ UModIntegralTerm l r-{-# INLINE modIntegralTerm #-}--quotIntegralTerm :: (SupportedPrim a, Integral a) => Term a -> Term a -> Term a-quotIntegralTerm l r = internTerm $ UQuotIntegralTerm l r-{-# INLINE quotIntegralTerm #-}--remIntegralTerm :: (SupportedPrim a, Integral a) => Term a -> Term a -> Term a-remIntegralTerm l r = internTerm $ URemIntegralTerm l r-{-# INLINE remIntegralTerm #-}--divBoundedIntegralTerm :: (SupportedPrim a, Bounded a, Integral a) => Term a -> Term a -> Term a-divBoundedIntegralTerm l r = internTerm $ UDivBoundedIntegralTerm l r-{-# INLINE divBoundedIntegralTerm #-}--modBoundedIntegralTerm :: (SupportedPrim a, Bounded a, Integral a) => Term a -> Term a -> Term a-modBoundedIntegralTerm l r = internTerm $ UModBoundedIntegralTerm l r-{-# INLINE modBoundedIntegralTerm #-}--quotBoundedIntegralTerm :: (SupportedPrim a, Bounded a, Integral a) => Term a -> Term a -> Term a-quotBoundedIntegralTerm l r = internTerm $ UQuotBoundedIntegralTerm l r-{-# INLINE quotBoundedIntegralTerm #-}--remBoundedIntegralTerm :: (SupportedPrim a, Bounded a, Integral a) => Term a -> Term a -> Term a-remBoundedIntegralTerm l r = internTerm $ URemBoundedIntegralTerm l r-{-# INLINE remBoundedIntegralTerm #-}
− src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/InternedCtors.hs-boot 
@@ -1,237 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE QuantifiedConstraints #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}--module Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors-  ( constructUnary,-    constructBinary,-    constructTernary,-    conTerm,-    symTerm,-    ssymTerm,-    isymTerm,-    sinfosymTerm,-    iinfosymTerm,-    notTerm,-    orTerm,-    andTerm,-    eqvTerm,-    iteTerm,-    addNumTerm,-    uminusNumTerm,-    timesNumTerm,-    absNumTerm,-    signumNumTerm,-    ltNumTerm,-    leNumTerm,-    andBitsTerm,-    orBitsTerm,-    xorBitsTerm,-    complementBitsTerm,-    shiftLeftTerm,-    shiftRightTerm,-    rotateLeftTerm,-    rotateRightTerm,-    toSignedTerm,-    toUnsignedTerm,-    bvconcatTerm,-    bvselectTerm,-    bvextendTerm,-    bvsignExtendTerm,-    bvzeroExtendTerm,-    tabularFunApplyTerm,-    generalFunApplyTerm,-    divIntegralTerm,-    modIntegralTerm,-    quotIntegralTerm,-    remIntegralTerm,-    divBoundedIntegralTerm,-    modBoundedIntegralTerm,-    quotBoundedIntegralTerm,-    remBoundedIntegralTerm,-  )-where--import Control.DeepSeq (NFData)-import Data.Bits (Bits, FiniteBits)-import Data.Hashable (Hashable)-import qualified Data.Text as T-import Data.Typeable (Typeable)-import GHC.TypeNats (KnownNat, type (+), type (<=))-import Grisette.Core.Data.Class.BitVector-  ( SizedBV,-  )-import Grisette.Core.Data.Class.SignConversion (SignConversion)-import Grisette.Core.Data.Class.SymRotate (SymRotate)-import Grisette.Core.Data.Class.SymShift (SymShift)-import {-# SOURCE #-} Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term-  ( BinaryOp,-    SupportedPrim,-    Term,-    TernaryOp,-    TypedSymbol,-    UnaryOp,-    type (-->),-  )-import Grisette.IR.SymPrim.Data.TabularFun-  ( type (=->),-  )-import Language.Haskell.TH.Syntax (Lift)--constructUnary ::-  forall tag arg t.-  (SupportedPrim t, UnaryOp tag arg t, Typeable tag, Typeable t, Show tag) =>-  tag ->-  Term arg ->-  Term t-constructBinary ::-  forall tag arg1 arg2 t.-  (SupportedPrim t, BinaryOp tag arg1 arg2 t, Typeable tag, Typeable t, Show tag) =>-  tag ->-  Term arg1 ->-  Term arg2 ->-  Term t-constructTernary ::-  forall tag arg1 arg2 arg3 t.-  (SupportedPrim t, TernaryOp tag arg1 arg2 arg3 t, Typeable tag, Typeable t, Show tag) =>-  tag ->-  Term arg1 ->-  Term arg2 ->-  Term arg3 ->-  Term t-conTerm :: (SupportedPrim t, Typeable t, Hashable t, Eq t, Show t) => t -> Term t-symTerm :: (SupportedPrim t, Typeable t) => TypedSymbol t -> Term t-ssymTerm :: (SupportedPrim t, Typeable t) => T.Text -> Term t-isymTerm :: (SupportedPrim t, Typeable t) => T.Text -> Int -> Term t-sinfosymTerm ::-  (SupportedPrim t, Typeable t, Typeable a, Ord a, Lift a, NFData a, Show a, Hashable a) =>-  T.Text ->-  a ->-  Term t-iinfosymTerm ::-  (SupportedPrim t, Typeable t, Typeable a, Ord a, Lift a, NFData a, Show a, Hashable a) =>-  T.Text ->-  Int ->-  a ->-  Term t-notTerm :: Term Bool -> Term Bool-orTerm :: Term Bool -> Term Bool -> Term Bool-andTerm :: Term Bool -> Term Bool -> Term Bool-eqvTerm :: (SupportedPrim a) => Term a -> Term a -> Term Bool-iteTerm :: (SupportedPrim a) => Term Bool -> Term a -> Term a -> Term a-addNumTerm :: (SupportedPrim a, Num a) => Term a -> Term a -> Term a-uminusNumTerm :: (SupportedPrim a, Num a) => Term a -> Term a-timesNumTerm :: (SupportedPrim a, Num a) => Term a -> Term a -> Term a-absNumTerm :: (SupportedPrim a, Num a) => Term a -> Term a-signumNumTerm :: (SupportedPrim a, Num a) => Term a -> Term a-ltNumTerm :: (SupportedPrim a, Num a, Ord a) => Term a -> Term a -> Term Bool-leNumTerm :: (SupportedPrim a, Num a, Ord a) => Term a -> Term a -> Term Bool-andBitsTerm :: (SupportedPrim a, Bits a) => Term a -> Term a -> Term a-orBitsTerm :: (SupportedPrim a, Bits a) => Term a -> Term a -> Term a-xorBitsTerm :: (SupportedPrim a, Bits a) => Term a -> Term a -> Term a-complementBitsTerm :: (SupportedPrim a, Bits a) => Term a -> Term a-shiftLeftTerm :: (SupportedPrim a, Integral a, FiniteBits a, SymShift a) => Term a -> Term a -> Term a-shiftRightTerm :: (SupportedPrim a, Integral a, FiniteBits a, SymShift a) => Term a -> Term a -> Term a-rotateLeftTerm :: (SupportedPrim a, Integral a, FiniteBits a, SymRotate a) => Term a -> Term a -> Term a-rotateRightTerm :: (SupportedPrim a, Integral a, FiniteBits a, SymRotate a) => Term a -> Term a -> Term a-toSignedTerm ::-  ( SupportedPrim u,-    SupportedPrim s,-    SignConversion u s-  ) =>-  Term u ->-  Term s-toUnsignedTerm ::-  ( SupportedPrim u,-    SupportedPrim s,-    SignConversion u s-  ) =>-  Term s ->-  Term u-bvconcatTerm ::-  ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n),-    Typeable bv,-    KnownNat a,-    KnownNat b,-    KnownNat (a + b),-    1 <= a,-    1 <= b,-    1 <= a + b,-    SizedBV bv-  ) =>-  Term (bv a) ->-  Term (bv b) ->-  Term (bv (a + b))-bvselectTerm ::-  forall bv n ix w p q.-  ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n),-    Typeable bv,-    KnownNat n,-    KnownNat ix,-    KnownNat w,-    1 <= n,-    1 <= w,-    ix + w <= n,-    SizedBV bv-  ) =>-  p ix ->-  q w ->-  Term (bv n) ->-  Term (bv w)-bvextendTerm ::-  forall bv l r proxy.-  ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n),-    Typeable bv,-    KnownNat l,-    KnownNat r,-    1 <= l,-    1 <= r,-    l <= r,-    SizedBV bv-  ) =>-  Bool ->-  proxy r ->-  Term (bv l) ->-  Term (bv r)-bvsignExtendTerm ::-  forall bv l r proxy.-  ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n),-    Typeable bv,-    KnownNat l,-    KnownNat r,-    1 <= l,-    1 <= r,-    l <= r,-    SizedBV bv-  ) =>-  proxy r ->-  Term (bv l) ->-  Term (bv r)-bvzeroExtendTerm ::-  forall bv l r proxy.-  ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n),-    Typeable bv,-    KnownNat l,-    KnownNat r,-    1 <= l,-    1 <= r,-    l <= r,-    SizedBV bv-  ) =>-  proxy r ->-  Term (bv l) ->-  Term (bv r)-tabularFunApplyTerm :: (SupportedPrim a, SupportedPrim b) => Term (a =-> b) -> Term a -> Term b-generalFunApplyTerm :: (SupportedPrim a, SupportedPrim b) => Term (a --> b) -> Term a -> Term b-divIntegralTerm :: (SupportedPrim a, Integral a) => Term a -> Term a -> Term a-modIntegralTerm :: (SupportedPrim a, Integral a) => Term a -> Term a -> Term a-quotIntegralTerm :: (SupportedPrim a, Integral a) => Term a -> Term a -> Term a-remIntegralTerm :: (SupportedPrim a, Integral a) => Term a -> Term a -> Term a-divBoundedIntegralTerm :: (SupportedPrim a, Bounded a, Integral a) => Term a -> Term a -> Term a-modBoundedIntegralTerm :: (SupportedPrim a, Bounded a, Integral a) => Term a -> Term a -> Term a-quotBoundedIntegralTerm :: (SupportedPrim a, Bounded a, Integral a) => Term a -> Term a -> Term a-remBoundedIntegralTerm :: (SupportedPrim a, Bounded a, Integral a) => Term a -> Term a -> Term a
− src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/SomeTerm.hs 
@@ -1,36 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}---- |--- Module      :   Grisette.IR.SymPrim.Data.Prim.InternedTerm.SomeTerm--- 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.IR.SymPrim.Data.Prim.InternedTerm.SomeTerm (SomeTerm (..)) where--import Data.Hashable (Hashable (hashWithSalt))-import Data.Typeable (Proxy (Proxy), typeRep)-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term-  ( SupportedPrim,-    Term,-  )-import {-# SOURCE #-} Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermUtils-  ( identityWithTypeRep,-  )--data SomeTerm where-  SomeTerm :: forall a. (SupportedPrim a) => Term a -> SomeTerm--instance Eq SomeTerm where-  (SomeTerm t1) == (SomeTerm t2) = identityWithTypeRep t1 == identityWithTypeRep t2--instance Hashable SomeTerm where-  hashWithSalt s (SomeTerm t) = hashWithSalt s $ identityWithTypeRep t--instance Show SomeTerm where-  show (SomeTerm (t :: Term a)) = "<<" ++ show t ++ " :: " ++ show (typeRep (Proxy @a)) ++ ">>"
− src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/Term.hs 
@@ -1,1194 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveLift #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE QuantifiedConstraints #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskellQuotes #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}---- |--- Module      :   Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term--- 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.IR.SymPrim.Data.Prim.InternedTerm.Term-  ( SupportedPrim (..),-    SymRep (..),-    ConRep (..),-    LinkedRep (..),-    UnaryOp (..),-    BinaryOp (..),-    TernaryOp (..),-    TypedSymbol (..),-    SomeTypedSymbol (..),-    showUntyped,-    withSymbolSupported,-    someTypedSymbol,-    Term (..),-    UTerm (..),-    type (-->) (..),-    buildGeneralFun,-    prettyPrintTerm,-  )-where--import Control.DeepSeq (NFData (rnf))-import Data.Bits (Bits, FiniteBits)-import Data.Function (on)-import Data.Hashable (Hashable (hashWithSalt))-import Data.Interned-  ( Cache,-    Id,-    Interned (Description, Uninterned, cache, describe, identify),-  )-import Data.Kind (Constraint)-import Data.String (IsString (fromString))-import qualified Data.Text as T-import Data.Typeable (Proxy (Proxy), cast)-import GHC.Generics (Generic)-import GHC.TypeNats (KnownNat, Nat, type (+), type (<=))-import Grisette.Core.Data.BV (IntN, WordN)-import Grisette.Core.Data.Class.BitVector-  ( SizedBV,-  )-import Grisette.Core.Data.Class.Function (Function (Arg, Ret, (#)))-import Grisette.Core.Data.Class.SignConversion (SignConversion)-import Grisette.Core.Data.Class.SymRotate (SymRotate)-import Grisette.Core.Data.Class.SymShift (SymShift)-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Caches-  ( typeMemoizedCache,-  )-import {-# SOURCE #-} Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors-  ( absNumTerm,-    addNumTerm,-    andBitsTerm,-    andTerm,-    bvconcatTerm,-    bvextendTerm,-    bvselectTerm,-    complementBitsTerm,-    conTerm,-    constructBinary,-    constructTernary,-    constructUnary,-    divBoundedIntegralTerm,-    divIntegralTerm,-    eqvTerm,-    generalFunApplyTerm,-    iteTerm,-    leNumTerm,-    ltNumTerm,-    modBoundedIntegralTerm,-    modIntegralTerm,-    notTerm,-    orBitsTerm,-    orTerm,-    quotBoundedIntegralTerm,-    quotIntegralTerm,-    remBoundedIntegralTerm,-    remIntegralTerm,-    rotateLeftTerm,-    rotateRightTerm,-    shiftLeftTerm,-    shiftRightTerm,-    signumNumTerm,-    symTerm,-    tabularFunApplyTerm,-    timesNumTerm,-    toSignedTerm,-    toUnsignedTerm,-    uminusNumTerm,-    xorBitsTerm,-  )-import {-# SOURCE #-} Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermSubstitution-  ( substTerm,-  )-import {-# SOURCE #-} Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermUtils-  ( identity,-    introSupportedPrimConstraint,-    pformat,-  )-import Grisette.IR.SymPrim.Data.Prim.ModelValue-  ( ModelValue,-    toModelValue,-  )-import Grisette.IR.SymPrim.Data.Prim.Utils-  ( eqHeteroRep,-    eqTypeRepBool,-  )-import Grisette.IR.SymPrim.Data.TabularFun-  ( type (=->) (TabularFun),-  )-import Language.Haskell.TH.Syntax (Lift (lift, liftTyped))-import Language.Haskell.TH.Syntax.Compat (unTypeSplice)-import Type.Reflection-  ( SomeTypeRep (SomeTypeRep),-    TypeRep,-    Typeable,-    eqTypeRep,-    typeRep,-    type (:~~:) (HRefl),-  )--#if MIN_VERSION_prettyprinter(1,7,0)-import Prettyprinter-  ( column,-    pageWidth,-    Doc,-    PageWidth(Unbounded, AvailablePerLine),-    Pretty(pretty),-  )-#else-import Data.Text.Prettyprint.Doc-  ( column,-    pageWidth,-    Doc,-    PageWidth(Unbounded, AvailablePerLine),-    Pretty(pretty),-  )-#endif---- $setup--- >>> import Grisette.Core--- >>> import Grisette.IR.SymPrim---- | Indicates that a type is supported and can be represented as a symbolic--- term.-class (Lift t, Typeable t, Hashable t, Eq t, Show t, NFData t) => SupportedPrim t where-  type PrimConstraint t :: Constraint-  type PrimConstraint _ = ()-  default withPrim :: (PrimConstraint t) => proxy t -> ((PrimConstraint t) => a) -> a-  withPrim :: proxy t -> ((PrimConstraint t) => a) -> a-  withPrim _ i = i-  termCache :: Cache (Term t)-  termCache = typeMemoizedCache-  pformatCon :: t -> String-  default pformatCon :: (Show t) => t -> String-  pformatCon = show-  pformatSym :: TypedSymbol t -> String-  pformatSym = showUntyped-  defaultValue :: t-  defaultValueDynamic :: proxy t -> ModelValue-  defaultValueDynamic _ = toModelValue (defaultValue @t)---- | Type family to resolve the concrete type associated with a symbolic type.-class ConRep sym where-  type ConType sym---- | Type family to resolve the symbolic type associated with a concrete type.-class (SupportedPrim con) => SymRep con where-  type SymType con---- | One-to-one mapping between symbolic types and concrete types.-class-  (ConRep sym, SymRep con, sym ~ SymType con, con ~ ConType sym) =>-  LinkedRep con sym-    | con -> sym,-      sym -> con-  where-  underlyingTerm :: sym -> Term con-  wrapTerm :: Term con -> sym--class-  (SupportedPrim arg, SupportedPrim t, Lift tag, NFData tag, Show tag, Typeable tag, Eq tag, Hashable tag) =>-  UnaryOp tag arg t-    | tag arg -> t-  where-  partialEvalUnary :: (Typeable tag, Typeable t) => tag -> Term arg -> Term t-  pformatUnary :: tag -> Term arg -> String--class-  ( SupportedPrim arg1,-    SupportedPrim arg2,-    SupportedPrim t,-    Lift tag,-    NFData tag,-    Show tag,-    Typeable tag,-    Eq tag,-    Hashable tag-  ) =>-  BinaryOp tag arg1 arg2 t-    | tag arg1 arg2 -> t-  where-  partialEvalBinary :: (Typeable tag, Typeable t) => tag -> Term arg1 -> Term arg2 -> Term t-  pformatBinary :: tag -> Term arg1 -> Term arg2 -> String--class-  ( SupportedPrim arg1,-    SupportedPrim arg2,-    SupportedPrim arg3,-    SupportedPrim t,-    Lift tag,-    NFData tag,-    Show tag,-    Typeable tag,-    Eq tag,-    Hashable tag-  ) =>-  TernaryOp tag arg1 arg2 arg3 t-    | tag arg1 arg2 arg3 -> t-  where-  partialEvalTernary :: (Typeable tag, Typeable t) => tag -> Term arg1 -> Term arg2 -> Term arg3 -> Term t-  pformatTernary :: tag -> Term arg1 -> Term arg2 -> Term arg3 -> String---- | A typed symbol is a symbol that is associated with a type. Note that the--- 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:------ >>> :set -XOverloadedStrings--- >>> "a" :: TypedSymbol Bool--- a :: Bool-data TypedSymbol t where-  SimpleSymbol :: (SupportedPrim t) => T.Text -> TypedSymbol t-  IndexedSymbol :: (SupportedPrim t) => T.Text -> Int -> TypedSymbol t-  WithInfo ::-    forall t a.-    ( SupportedPrim t,-      Typeable a,-      Ord a,-      Lift a,-      NFData a,-      Show a,-      Hashable a-    ) =>-    TypedSymbol t ->-    a ->-    TypedSymbol t---- deriving (Eq, Ord, Generic, Lift, NFData)--instance Eq (TypedSymbol t) where-  SimpleSymbol x == SimpleSymbol y = x == y-  IndexedSymbol x i == IndexedSymbol y j = i == j && x == y-  WithInfo s1 (i1 :: a) == WithInfo s2 (i2 :: b) = case eqTypeRep (typeRep @a) (typeRep @b) of-    Just HRefl -> i1 == i2 && s1 == s2-    _ -> False-  _ == _ = False--instance Ord (TypedSymbol t) where-  SimpleSymbol x <= SimpleSymbol y = x <= y-  IndexedSymbol x i <= IndexedSymbol y j = i < j || (i == j && x <= y)-  WithInfo s1 (i1 :: a) <= WithInfo s2 (i2 :: b) = case eqTypeRep (typeRep @a) (typeRep @b) of-    Just HRefl -> s1 < s2 || (s1 == s2 && i1 <= i2)-    _ -> False-  _ <= _ = False--instance Lift (TypedSymbol t) where-  liftTyped (SimpleSymbol x) = [||SimpleSymbol x||]-  liftTyped (IndexedSymbol x i) = [||IndexedSymbol x i||]-  liftTyped (WithInfo s1 i1) = [||WithInfo s1 i1||]--instance Show (TypedSymbol t) where-  show (SimpleSymbol str) = T.unpack str ++ " :: " ++ show (typeRep @t)-  show (IndexedSymbol str i) = T.unpack str ++ "@" ++ show i ++ " :: " ++ show (typeRep @t)-  show (WithInfo s info) = showUntyped s ++ ":" ++ show info ++ " :: " ++ show (typeRep @t)--showUntyped :: TypedSymbol t -> String-showUntyped (SimpleSymbol str) = T.unpack str-showUntyped (IndexedSymbol str i) = T.unpack str ++ "@" ++ show i-showUntyped (WithInfo s info) = showUntyped s ++ ":" ++ show info--instance Hashable (TypedSymbol t) where-  s `hashWithSalt` SimpleSymbol x = s `hashWithSalt` x-  s `hashWithSalt` IndexedSymbol x i = s `hashWithSalt` x `hashWithSalt` i-  s `hashWithSalt` WithInfo sym info = s `hashWithSalt` sym `hashWithSalt` info--instance NFData (TypedSymbol t) where-  rnf (SimpleSymbol str) = rnf str-  rnf (IndexedSymbol str i) = rnf str `seq` rnf i-  rnf (WithInfo s info) = rnf s `seq` rnf info--instance (SupportedPrim t) => IsString (TypedSymbol t) where-  fromString = SimpleSymbol . T.pack--withSymbolSupported :: TypedSymbol t -> ((SupportedPrim t) => a) -> a-withSymbolSupported (SimpleSymbol _) a = a-withSymbolSupported (IndexedSymbol _ _) a = a-withSymbolSupported (WithInfo _ _) a = a--{--data TypedSymbol t where-  TypedSymbol :: (SupportedPrim t) => Symbol -> TypedSymbol t--typedSymbol :: forall proxy t. (SupportedPrim t) => proxy t -> Symbol -> TypedSymbol t-typedSymbol _ = TypedSymbol--instance NFData (TypedSymbol t) where-  rnf (TypedSymbol s) = rnf s--instance Eq (TypedSymbol t) where-  (TypedSymbol s1) == (TypedSymbol s2) = s1 == s2--instance Ord (TypedSymbol t) where-  (TypedSymbol s1) <= (TypedSymbol s2) = s1 <= s2--instance Hashable (TypedSymbol t) where-  hashWithSalt s (TypedSymbol s1) = s `hashWithSalt` s1--instance Show (TypedSymbol t) where-  show (TypedSymbol s) = show s ++ " :: " ++ show (typeRep @t)--instance Lift (TypedSymbol t) where-  liftTyped (TypedSymbol s) = [||TypedSymbol s||]-  -}--data SomeTypedSymbol where-  SomeTypedSymbol :: forall t. TypeRep t -> TypedSymbol t -> SomeTypedSymbol--instance NFData SomeTypedSymbol where-  rnf (SomeTypedSymbol p s) = rnf (SomeTypeRep p) `seq` rnf s--instance Eq SomeTypedSymbol where-  (SomeTypedSymbol t1 s1) == (SomeTypedSymbol t2 s2) = case eqTypeRep t1 t2 of-    Just HRefl -> s1 == s2-    _ -> False--instance Ord SomeTypedSymbol where-  (SomeTypedSymbol t1 s1) <= (SomeTypedSymbol t2 s2) =-    SomeTypeRep t1 < SomeTypeRep t2-      || ( case eqTypeRep t1 t2 of-             Just HRefl -> s1 <= s2-             _ -> False-         )--instance Hashable SomeTypedSymbol where-  hashWithSalt s (SomeTypedSymbol t1 s1) = s `hashWithSalt` s1 `hashWithSalt` t1--instance Show SomeTypedSymbol where-  show (SomeTypedSymbol _ s) = show s--someTypedSymbol :: forall t. TypedSymbol t -> SomeTypedSymbol-someTypedSymbol s@(SimpleSymbol _) = SomeTypedSymbol (typeRep @t) s-someTypedSymbol s@(IndexedSymbol _ _) = SomeTypedSymbol (typeRep @t) s-someTypedSymbol s@(WithInfo _ _) = SomeTypedSymbol (typeRep @t) s--data Term t where-  ConTerm :: (SupportedPrim t) => {-# UNPACK #-} !Id -> !t -> Term t-  SymTerm :: (SupportedPrim t) => {-# UNPACK #-} !Id -> !(TypedSymbol t) -> Term t-  UnaryTerm ::-    (UnaryOp tag arg t) =>-    {-# UNPACK #-} !Id ->-    !tag ->-    !(Term arg) ->-    Term t-  BinaryTerm ::-    (BinaryOp tag arg1 arg2 t) =>-    {-# UNPACK #-} !Id ->-    !tag ->-    !(Term arg1) ->-    !(Term arg2) ->-    Term t-  TernaryTerm ::-    (TernaryOp tag arg1 arg2 arg3 t) =>-    {-# UNPACK #-} !Id ->-    !tag ->-    !(Term arg1) ->-    !(Term arg2) ->-    !(Term arg3) ->-    Term t-  NotTerm :: {-# UNPACK #-} !Id -> !(Term Bool) -> Term Bool-  OrTerm :: {-# UNPACK #-} !Id -> !(Term Bool) -> !(Term Bool) -> Term Bool-  AndTerm :: {-# UNPACK #-} !Id -> !(Term Bool) -> !(Term Bool) -> Term Bool-  EqvTerm :: (SupportedPrim t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term Bool-  ITETerm :: (SupportedPrim t) => {-# UNPACK #-} !Id -> !(Term Bool) -> !(Term t) -> !(Term t) -> Term t-  AddNumTerm :: (SupportedPrim t, Num t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t-  UMinusNumTerm :: (SupportedPrim t, Num t) => {-# UNPACK #-} !Id -> !(Term t) -> Term t-  TimesNumTerm :: (SupportedPrim t, Num t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t-  AbsNumTerm :: (SupportedPrim t, Num t) => {-# UNPACK #-} !Id -> !(Term t) -> Term t-  SignumNumTerm :: (SupportedPrim t, Num t) => {-# UNPACK #-} !Id -> !(Term t) -> Term t-  LTNumTerm :: (SupportedPrim t, Num t, Ord t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term Bool-  LENumTerm :: (SupportedPrim t, Num t, Ord t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term Bool-  AndBitsTerm :: (SupportedPrim t, Bits t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t-  OrBitsTerm :: (SupportedPrim t, Bits t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t-  XorBitsTerm :: (SupportedPrim t, Bits t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t-  ComplementBitsTerm :: (SupportedPrim t, Bits t) => {-# UNPACK #-} !Id -> !(Term t) -> Term t-  ShiftLeftTerm :: (SupportedPrim t, Integral t, FiniteBits t, SymShift t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t-  ShiftRightTerm :: (SupportedPrim t, Integral t, FiniteBits t, SymShift t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t-  RotateLeftTerm :: (SupportedPrim t, Integral t, FiniteBits t, SymRotate t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t-  RotateRightTerm :: (SupportedPrim t, Integral t, FiniteBits t, SymRotate t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t-  ToSignedTerm ::-    ( SupportedPrim u,-      SupportedPrim s,-      SignConversion u s-    ) =>-    {-# UNPACK #-} !Id ->-    !(Term u) ->-    Term s-  ToUnsignedTerm ::-    ( SupportedPrim u,-      SupportedPrim s,-      SignConversion u s-    ) =>-    {-# UNPACK #-} !Id ->-    !(Term s) ->-    Term u-  BVConcatTerm ::-    ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n),-      Typeable bv,-      KnownNat a,-      KnownNat b,-      KnownNat (a + b),-      1 <= a,-      1 <= b,-      1 <= a + b,-      SizedBV bv-    ) =>-    {-# UNPACK #-} !Id ->-    !(Term (bv a)) ->-    !(Term (bv b)) ->-    Term (bv (a + b))-  BVSelectTerm ::-    ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n),-      Typeable bv,-      KnownNat n,-      KnownNat ix,-      KnownNat w,-      1 <= n,-      1 <= w,-      ix + w <= n,-      SizedBV bv-    ) =>-    {-# UNPACK #-} !Id ->-    !(TypeRep ix) ->-    !(TypeRep w) ->-    !(Term (bv n)) ->-    Term (bv w)-  BVExtendTerm ::-    ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n),-      Typeable bv,-      KnownNat l,-      KnownNat r,-      1 <= l,-      1 <= r,-      l <= r,-      SizedBV bv-    ) =>-    {-# UNPACK #-} !Id ->-    !Bool ->-    !(TypeRep r) ->-    !(Term (bv l)) ->-    Term (bv r)-  TabularFunApplyTerm ::-    ( SupportedPrim a,-      SupportedPrim b-    ) =>-    {-# UNPACK #-} !Id ->-    Term (a =-> b) ->-    Term a ->-    Term b-  GeneralFunApplyTerm ::-    ( SupportedPrim a,-      SupportedPrim b-    ) =>-    {-# UNPACK #-} !Id ->-    Term (a --> b) ->-    Term a ->-    Term b-  DivIntegralTerm :: (SupportedPrim t, Integral t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t-  ModIntegralTerm :: (SupportedPrim t, Integral t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t-  QuotIntegralTerm :: (SupportedPrim t, Integral t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t-  RemIntegralTerm :: (SupportedPrim t, Integral t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t-  DivBoundedIntegralTerm :: (SupportedPrim t, Bounded t, Integral t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t-  ModBoundedIntegralTerm :: (SupportedPrim t, Bounded t, Integral t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t-  QuotBoundedIntegralTerm :: (SupportedPrim t, Bounded t, Integral t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t-  RemBoundedIntegralTerm :: (SupportedPrim t, Bounded t, Integral t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t--instance NFData (Term a) where-  rnf i = identity i `seq` ()--instance Lift (Term t) where-  lift = unTypeSplice . liftTyped-  liftTyped (ConTerm _ i) = [||conTerm i||]-  liftTyped (SymTerm _ sym) = [||symTerm sym||]-  liftTyped (UnaryTerm _ tag arg) = [||constructUnary tag arg||]-  liftTyped (BinaryTerm _ tag arg1 arg2) = [||constructBinary tag arg1 arg2||]-  liftTyped (TernaryTerm _ tag arg1 arg2 arg3) = [||constructTernary tag arg1 arg2 arg3||]-  liftTyped (NotTerm _ arg) = [||notTerm arg||]-  liftTyped (OrTerm _ arg1 arg2) = [||orTerm arg1 arg2||]-  liftTyped (AndTerm _ arg1 arg2) = [||andTerm arg1 arg2||]-  liftTyped (EqvTerm _ arg1 arg2) = [||eqvTerm arg1 arg2||]-  liftTyped (ITETerm _ cond arg1 arg2) = [||iteTerm cond arg1 arg2||]-  liftTyped (AddNumTerm _ arg1 arg2) = [||addNumTerm arg1 arg2||]-  liftTyped (UMinusNumTerm _ arg) = [||uminusNumTerm arg||]-  liftTyped (TimesNumTerm _ arg1 arg2) = [||timesNumTerm arg1 arg2||]-  liftTyped (AbsNumTerm _ arg) = [||absNumTerm arg||]-  liftTyped (SignumNumTerm _ arg) = [||signumNumTerm arg||]-  liftTyped (LTNumTerm _ arg1 arg2) = [||ltNumTerm arg1 arg2||]-  liftTyped (LENumTerm _ arg1 arg2) = [||leNumTerm arg1 arg2||]-  liftTyped (AndBitsTerm _ arg1 arg2) = [||andBitsTerm arg1 arg2||]-  liftTyped (OrBitsTerm _ arg1 arg2) = [||orBitsTerm arg1 arg2||]-  liftTyped (XorBitsTerm _ arg1 arg2) = [||xorBitsTerm arg1 arg2||]-  liftTyped (ComplementBitsTerm _ arg) = [||complementBitsTerm arg||]-  liftTyped (ShiftLeftTerm _ arg n) = [||shiftLeftTerm arg n||]-  liftTyped (ShiftRightTerm _ arg n) = [||shiftRightTerm arg n||]-  liftTyped (RotateLeftTerm _ arg n) = [||rotateLeftTerm arg n||]-  liftTyped (RotateRightTerm _ arg n) = [||rotateRightTerm arg n||]-  liftTyped (ToSignedTerm _ v) = [||toSignedTerm v||]-  liftTyped (ToUnsignedTerm _ v) = [||toUnsignedTerm v||]-  liftTyped (BVConcatTerm _ arg1 arg2) = [||bvconcatTerm arg1 arg2||]-  liftTyped (BVSelectTerm _ (_ :: TypeRep ix) (_ :: TypeRep w) arg) = [||bvselectTerm (Proxy @ix) (Proxy @w) arg||]-  liftTyped (BVExtendTerm _ signed (_ :: TypeRep n) arg) = [||bvextendTerm signed (Proxy @n) arg||]-  liftTyped (TabularFunApplyTerm _ func arg) = [||tabularFunApplyTerm func arg||]-  liftTyped (GeneralFunApplyTerm _ func arg) = [||generalFunApplyTerm func arg||]-  liftTyped (DivIntegralTerm _ arg1 arg2) = [||divIntegralTerm arg1 arg2||]-  liftTyped (ModIntegralTerm _ arg1 arg2) = [||modIntegralTerm arg1 arg2||]-  liftTyped (QuotIntegralTerm _ arg1 arg2) = [||quotIntegralTerm arg1 arg2||]-  liftTyped (RemIntegralTerm _ arg1 arg2) = [||remIntegralTerm arg1 arg2||]-  liftTyped (DivBoundedIntegralTerm _ arg1 arg2) = [||divBoundedIntegralTerm arg1 arg2||]-  liftTyped (ModBoundedIntegralTerm _ arg1 arg2) = [||modBoundedIntegralTerm arg1 arg2||]-  liftTyped (QuotBoundedIntegralTerm _ arg1 arg2) = [||quotBoundedIntegralTerm arg1 arg2||]-  liftTyped (RemBoundedIntegralTerm _ arg1 arg2) = [||remBoundedIntegralTerm arg1 arg2||]--instance Show (Term ty) where-  show (ConTerm i v) = "ConTerm{id=" ++ show i ++ ", v=" ++ show v ++ "}"-  show (SymTerm i name) =-    "SymTerm{id="-      ++ show i-      ++ ", name="-      ++ show name-      ++ ", type="-      ++ show (typeRep @ty)-      ++ "}"-  show (UnaryTerm i tag arg) = "Unary{id=" ++ show i ++ ", tag=" ++ show tag ++ ", arg=" ++ show arg ++ "}"-  show (BinaryTerm i tag arg1 arg2) =-    "Binary{id="-      ++ show i-      ++ ", tag="-      ++ show tag-      ++ ", arg1="-      ++ show arg1-      ++ ", arg2="-      ++ show arg2-      ++ "}"-  show (TernaryTerm i tag arg1 arg2 arg3) =-    "Ternary{id="-      ++ show i-      ++ ", tag="-      ++ show tag-      ++ ", arg1="-      ++ show arg1-      ++ ", arg2="-      ++ show arg2-      ++ ", arg3="-      ++ show arg3-      ++ "}"-  show (NotTerm i arg) = "Not{id=" ++ show i ++ ", arg=" ++ show arg ++ "}"-  show (OrTerm i arg1 arg2) = "Or{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}"-  show (AndTerm i arg1 arg2) = "And{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}"-  show (EqvTerm i arg1 arg2) = "Eqv{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}"-  show (ITETerm i cond l r) =-    "ITE{id="-      ++ show i-      ++ ", cond="-      ++ show cond-      ++ ", then="-      ++ show l-      ++ ", else="-      ++ show r-      ++ "}"-  show (AddNumTerm i arg1 arg2) = "AddNum{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}"-  show (UMinusNumTerm i arg) = "UMinusNum{id=" ++ show i ++ ", arg=" ++ show arg ++ "}"-  show (TimesNumTerm i arg1 arg2) = "TimesNum{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}"-  show (AbsNumTerm i arg) = "AbsNum{id=" ++ show i ++ ", arg=" ++ show arg ++ "}"-  show (SignumNumTerm i arg) = "SignumNum{id=" ++ show i ++ ", arg=" ++ show arg ++ "}"-  show (LTNumTerm i arg1 arg2) = "LTNum{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}"-  show (LENumTerm i arg1 arg2) = "LENum{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}"-  show (AndBitsTerm i arg1 arg2) = "AndBits{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}"-  show (OrBitsTerm i arg1 arg2) = "OrBits{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}"-  show (XorBitsTerm i arg1 arg2) = "XorBits{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}"-  show (ComplementBitsTerm i arg) = "ComplementBits{id=" ++ show i ++ ", arg=" ++ show arg ++ "}"-  show (ShiftLeftTerm i arg n) = "ShiftLeft{id=" ++ show i ++ ", arg=" ++ show arg ++ ", n=" ++ show n ++ "}"-  show (ShiftRightTerm i arg n) = "ShiftRight{id=" ++ show i ++ ", arg=" ++ show arg ++ ", n=" ++ show n ++ "}"-  show (RotateLeftTerm i arg n) = "RotateLeft{id=" ++ show i ++ ", arg=" ++ show arg ++ ", n=" ++ show n ++ "}"-  show (RotateRightTerm i arg n) = "RotateRight{id=" ++ show i ++ ", arg=" ++ show arg ++ ", n=" ++ show n ++ "}"-  show (ToSignedTerm i arg) = "ToSigned{id=" ++ show i ++ ", arg=" ++ show arg ++ "}"-  show (ToUnsignedTerm i arg) = "ToUnsigned{id=" ++ show i ++ ", arg=" ++ show arg ++ "}"-  show (BVConcatTerm i arg1 arg2) = "BVConcat{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}"-  show (BVSelectTerm i ix w arg) =-    "BVSelect{id=" ++ show i ++ ", ix=" ++ show ix ++ ", w=" ++ show w ++ ", arg=" ++ show arg ++ "}"-  show (BVExtendTerm i signed n arg) =-    "BVExtend{id=" ++ show i ++ ", signed=" ++ show signed ++ ", n=" ++ show n ++ ", arg=" ++ show arg ++ "}"-  show (TabularFunApplyTerm i func arg) =-    "TabularFunApply{id=" ++ show i ++ ", func=" ++ show func ++ ", arg=" ++ show arg ++ "}"-  show (GeneralFunApplyTerm i func arg) =-    "GeneralFunApply{id=" ++ show i ++ ", func=" ++ show func ++ ", arg=" ++ show arg ++ "}"-  show (DivIntegralTerm i arg1 arg2) =-    "DivIntegral{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}"-  show (ModIntegralTerm i arg1 arg2) =-    "ModIntegral{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}"-  show (QuotIntegralTerm i arg1 arg2) =-    "QuotIntegral{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}"-  show (RemIntegralTerm i arg1 arg2) =-    "RemIntegral{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}"-  show (DivBoundedIntegralTerm i arg1 arg2) =-    "DivBoundedIntegral{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}"-  show (ModBoundedIntegralTerm i arg1 arg2) =-    "ModBoundedIntegral{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}"-  show (QuotBoundedIntegralTerm i arg1 arg2) =-    "QuotBoundedIntegral{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}"-  show (RemBoundedIntegralTerm i arg1 arg2) =-    "RemBoundedIntegral{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}"--prettyPrintTerm :: Term t -> Doc ann-prettyPrintTerm v =-  column-    ( \c ->-        pageWidth $ \case-          AvailablePerLine i r ->-            if fromIntegral (c + len) > fromIntegral i * r-              then "..."-              else pretty formatted-          Unbounded -> pretty formatted-    )-  where-    formatted = introSupportedPrimConstraint v $ pformat v-    len = length formatted--instance (SupportedPrim t) => Eq (Term t) where-  (==) = (==) `on` identity--instance (SupportedPrim t) => Hashable (Term t) where-  hashWithSalt s t = hashWithSalt s $ identity t--data UTerm t where-  UConTerm :: (SupportedPrim t) => !t -> UTerm t-  USymTerm :: (SupportedPrim t) => !(TypedSymbol t) -> UTerm t-  UUnaryTerm :: (UnaryOp tag arg t) => !tag -> !(Term arg) -> UTerm t-  UBinaryTerm ::-    (BinaryOp tag arg1 arg2 t) =>-    !tag ->-    !(Term arg1) ->-    !(Term arg2) ->-    UTerm t-  UTernaryTerm ::-    (TernaryOp tag arg1 arg2 arg3 t) =>-    !tag ->-    !(Term arg1) ->-    !(Term arg2) ->-    !(Term arg3) ->-    UTerm t-  UNotTerm :: !(Term Bool) -> UTerm Bool-  UOrTerm :: !(Term Bool) -> !(Term Bool) -> UTerm Bool-  UAndTerm :: !(Term Bool) -> !(Term Bool) -> UTerm Bool-  UEqvTerm :: (SupportedPrim t) => !(Term t) -> !(Term t) -> UTerm Bool-  UITETerm :: (SupportedPrim t) => !(Term Bool) -> !(Term t) -> !(Term t) -> UTerm t-  UAddNumTerm :: (SupportedPrim t, Num t) => !(Term t) -> !(Term t) -> UTerm t-  UUMinusNumTerm :: (SupportedPrim t, Num t) => !(Term t) -> UTerm t-  UTimesNumTerm :: (SupportedPrim t, Num t) => !(Term t) -> !(Term t) -> UTerm t-  UAbsNumTerm :: (SupportedPrim t, Num t) => !(Term t) -> UTerm t-  USignumNumTerm :: (SupportedPrim t, Num t) => !(Term t) -> UTerm t-  ULTNumTerm :: (SupportedPrim t, Num t, Ord t) => !(Term t) -> !(Term t) -> UTerm Bool-  ULENumTerm :: (SupportedPrim t, Num t, Ord t) => !(Term t) -> !(Term t) -> UTerm Bool-  UAndBitsTerm :: (SupportedPrim t, Bits t) => !(Term t) -> !(Term t) -> UTerm t-  UOrBitsTerm :: (SupportedPrim t, Bits t) => !(Term t) -> !(Term t) -> UTerm t-  UXorBitsTerm :: (SupportedPrim t, Bits t) => !(Term t) -> !(Term t) -> UTerm t-  UComplementBitsTerm :: (SupportedPrim t, Bits t) => !(Term t) -> UTerm t-  UShiftLeftTerm :: (SupportedPrim t, Integral t, FiniteBits t, SymShift t) => !(Term t) -> !(Term t) -> UTerm t-  UShiftRightTerm :: (SupportedPrim t, Integral t, FiniteBits t, SymShift t) => !(Term t) -> !(Term t) -> UTerm t-  URotateLeftTerm :: (SupportedPrim t, Integral t, FiniteBits t, SymRotate t) => !(Term t) -> !(Term t) -> UTerm t-  URotateRightTerm :: (SupportedPrim t, Integral t, FiniteBits t, SymRotate t) => !(Term t) -> !(Term t) -> UTerm t-  UToSignedTerm ::-    ( SupportedPrim u,-      SupportedPrim s,-      SignConversion u s-    ) =>-    !(Term u) ->-    UTerm s-  UToUnsignedTerm ::-    ( SupportedPrim u,-      SupportedPrim s,-      SignConversion u s-    ) =>-    !(Term s) ->-    UTerm u-  UBVConcatTerm ::-    ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n),-      Typeable bv,-      KnownNat a,-      KnownNat b,-      KnownNat (a + b),-      1 <= a,-      1 <= b,-      1 <= a + b,-      SizedBV bv-    ) =>-    !(Term (bv a)) ->-    !(Term (bv b)) ->-    UTerm (bv (a + b))-  UBVSelectTerm ::-    ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n),-      Typeable bv,-      KnownNat n,-      KnownNat ix,-      KnownNat w,-      1 <= n,-      1 <= w,-      ix + w <= n,-      SizedBV bv-    ) =>-    !(TypeRep ix) ->-    !(TypeRep w) ->-    !(Term (bv n)) ->-    UTerm (bv w)-  UBVExtendTerm ::-    ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n),-      Typeable bv,-      KnownNat l,-      KnownNat r,-      1 <= l,-      1 <= r,-      l <= r,-      SizedBV bv-    ) =>-    !Bool ->-    !(TypeRep r) ->-    !(Term (bv l)) ->-    UTerm (bv r)-  UTabularFunApplyTerm ::-    ( SupportedPrim a,-      SupportedPrim b-    ) =>-    Term (a =-> b) ->-    Term a ->-    UTerm b-  UGeneralFunApplyTerm ::-    ( SupportedPrim a,-      SupportedPrim b-    ) =>-    Term (a --> b) ->-    Term a ->-    UTerm b-  UDivIntegralTerm :: (SupportedPrim t, Integral t) => !(Term t) -> !(Term t) -> UTerm t-  UModIntegralTerm :: (SupportedPrim t, Integral t) => !(Term t) -> !(Term t) -> UTerm t-  UQuotIntegralTerm :: (SupportedPrim t, Integral t) => !(Term t) -> !(Term t) -> UTerm t-  URemIntegralTerm :: (SupportedPrim t, Integral t) => !(Term t) -> !(Term t) -> UTerm t-  UDivBoundedIntegralTerm :: (SupportedPrim t, Bounded t, Integral t) => !(Term t) -> !(Term t) -> UTerm t-  UModBoundedIntegralTerm :: (SupportedPrim t, Bounded t, Integral t) => !(Term t) -> !(Term t) -> UTerm t-  UQuotBoundedIntegralTerm :: (SupportedPrim t, Bounded t, Integral t) => !(Term t) -> !(Term t) -> UTerm t-  URemBoundedIntegralTerm :: (SupportedPrim t, Bounded t, Integral t) => !(Term t) -> !(Term t) -> UTerm t--eqTypedId :: (TypeRep a, Id) -> (TypeRep b, Id) -> Bool-eqTypedId (a, i1) (b, i2) = i1 == i2 && eqTypeRepBool a b-{-# INLINE eqTypedId #-}--eqHeteroTag :: (Eq a) => (TypeRep a, a) -> (TypeRep b, b) -> Bool-eqHeteroTag (tpa, taga) (tpb, tagb) = eqHeteroRep tpa tpb taga tagb-{-# INLINE eqHeteroTag #-}--instance (SupportedPrim t) => Interned (Term t) where-  type Uninterned (Term t) = UTerm t-  data Description (Term t) where-    DConTerm :: t -> Description (Term t)-    DSymTerm :: TypedSymbol t -> Description (Term t)-    DUnaryTerm ::-      (Eq tag, Hashable tag) =>-      {-# UNPACK #-} !(TypeRep tag, tag) ->-      {-# UNPACK #-} !(TypeRep arg, Id) ->-      Description (Term t)-    DBinaryTerm ::-      (Eq tag, Hashable tag) =>-      {-# UNPACK #-} !(TypeRep tag, tag) ->-      {-# UNPACK #-} !(TypeRep arg1, Id) ->-      {-# UNPACK #-} !(TypeRep arg2, Id) ->-      Description (Term t)-    DTernaryTerm ::-      (Eq tag, Hashable tag) =>-      {-# UNPACK #-} !(TypeRep tag, tag) ->-      {-# UNPACK #-} !(TypeRep arg1, Id) ->-      {-# UNPACK #-} !(TypeRep arg2, Id) ->-      {-# UNPACK #-} !(TypeRep arg3, Id) ->-      Description (Term t)-    DNotTerm :: {-# UNPACK #-} !Id -> Description (Term Bool)-    DOrTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term Bool)-    DAndTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term Bool)-    DEqvTerm :: TypeRep args -> {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term Bool)-    DITETerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term t)-    DAddNumTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term t)-    DUMinusNumTerm :: {-# UNPACK #-} !Id -> Description (Term t)-    DTimesNumTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term t)-    DAbsNumTerm :: {-# UNPACK #-} !Id -> Description (Term t)-    DSignumNumTerm :: {-# UNPACK #-} !Id -> Description (Term t)-    DLTNumTerm :: TypeRep args -> {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term Bool)-    DLENumTerm :: TypeRep args -> {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term Bool)-    DAndBitsTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term t)-    DOrBitsTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term t)-    DXorBitsTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term t)-    DComplementBitsTerm :: {-# UNPACK #-} !Id -> Description (Term t)-    DShiftLeftTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term t)-    DShiftRightTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term t)-    DRotateLeftTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term t)-    DRotateRightTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term t)-    DBVConcatTerm :: TypeRep bv1 -> TypeRep bv2 -> {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term t)-    DToSignedTerm ::-      !(TypeRep u, Id) ->-      Description (Term s)-    DToUnsignedTerm ::-      !(TypeRep s, Id) ->-      Description (Term u)-    DBVSelectTerm ::-      forall bv (n :: Nat) (w :: Nat) (ix :: Nat).-      !(TypeRep ix) ->-      !(TypeRep (bv n), Id) ->-      Description (Term (bv w))-    DBVExtendTerm ::-      forall bv (l :: Nat) (r :: Nat).-      !Bool ->-      !(TypeRep r) ->-      {-# UNPACK #-} !(TypeRep (bv l), Id) ->-      Description (Term (bv r))-    DTabularFunApplyTerm ::-      {-# UNPACK #-} !(TypeRep (a =-> b), Id) ->-      {-# UNPACK #-} !(TypeRep a, Id) ->-      Description (Term b)-    DGeneralFunApplyTerm ::-      {-# UNPACK #-} !(TypeRep (a --> b), Id) ->-      {-# UNPACK #-} !(TypeRep a, Id) ->-      Description (Term b)-    DDivIntegralTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term a)-    DModIntegralTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term a)-    DQuotIntegralTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term a)-    DRemIntegralTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term a)-    DDivBoundedIntegralTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term a)-    DModBoundedIntegralTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term a)-    DQuotBoundedIntegralTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term a)-    DRemBoundedIntegralTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term a)--  describe (UConTerm v) = DConTerm v-  describe ((USymTerm name) :: UTerm t) = DSymTerm @t name-  describe ((UUnaryTerm (tag :: tagt) (tm :: Term arg)) :: UTerm t) =-    DUnaryTerm (typeRep, tag) (typeRep :: TypeRep arg, identity tm)-  describe ((UBinaryTerm (tag :: tagt) (tm1 :: Term arg1) (tm2 :: Term arg2)) :: UTerm t) =-    DBinaryTerm @tagt @arg1 @arg2 @t (typeRep, tag) (typeRep, identity tm1) (typeRep, identity tm2)-  describe ((UTernaryTerm (tag :: tagt) (tm1 :: Term arg1) (tm2 :: Term arg2) (tm3 :: Term arg3)) :: UTerm t) =-    DTernaryTerm @tagt @arg1 @arg2 @arg3 @t-      (typeRep, tag)-      (typeRep, identity tm1)-      (typeRep, identity tm2)-      (typeRep, identity tm3)-  describe (UNotTerm arg) = DNotTerm (identity arg)-  describe (UOrTerm arg1 arg2) = DOrTerm (identity arg1) (identity arg2)-  describe (UAndTerm arg1 arg2) = DAndTerm (identity arg1) (identity arg2)-  describe (UEqvTerm (arg1 :: Term arg) arg2) = DEqvTerm (typeRep :: TypeRep arg) (identity arg1) (identity arg2)-  describe (UITETerm cond (l :: Term arg) r) = DITETerm (identity cond) (identity l) (identity r)-  describe (UAddNumTerm arg1 arg2) = DAddNumTerm (identity arg1) (identity arg2)-  describe (UUMinusNumTerm arg) = DUMinusNumTerm (identity arg)-  describe (UTimesNumTerm arg1 arg2) = DTimesNumTerm (identity arg1) (identity arg2)-  describe (UAbsNumTerm arg) = DAbsNumTerm (identity arg)-  describe (USignumNumTerm arg) = DSignumNumTerm (identity arg)-  describe (ULTNumTerm (arg1 :: arg) arg2) = DLTNumTerm (typeRep :: TypeRep arg) (identity arg1) (identity arg2)-  describe (ULENumTerm (arg1 :: arg) arg2) = DLENumTerm (typeRep :: TypeRep arg) (identity arg1) (identity arg2)-  describe (UAndBitsTerm arg1 arg2) = DAndBitsTerm (identity arg1) (identity arg2)-  describe (UOrBitsTerm arg1 arg2) = DOrBitsTerm (identity arg1) (identity arg2)-  describe (UXorBitsTerm arg1 arg2) = DXorBitsTerm (identity arg1) (identity arg2)-  describe (UComplementBitsTerm arg) = DComplementBitsTerm (identity arg)-  describe (UShiftLeftTerm arg n) = DShiftLeftTerm (identity arg) (identity n)-  describe (UShiftRightTerm arg n) = DShiftRightTerm (identity arg) (identity n)-  describe (URotateLeftTerm arg n) = DRotateLeftTerm (identity arg) (identity n)-  describe (URotateRightTerm arg n) = DRotateRightTerm (identity arg) (identity n)-  describe (UToSignedTerm (arg :: Term bv)) = DToSignedTerm (typeRep :: TypeRep bv, identity arg)-  describe (UToUnsignedTerm (arg :: Term bv)) = DToSignedTerm (typeRep :: TypeRep bv, identity arg)-  describe (UBVConcatTerm (arg1 :: bv1) (arg2 :: bv2)) =-    DBVConcatTerm (typeRep :: TypeRep bv1) (typeRep :: TypeRep bv2) (identity arg1) (identity arg2)-  describe (UBVSelectTerm (ix :: TypeRep ix) _ (arg :: Term arg)) =-    DBVSelectTerm ix (typeRep :: TypeRep arg, identity arg)-  describe (UBVExtendTerm signed (n :: TypeRep n) (arg :: Term arg)) =-    DBVExtendTerm signed n (typeRep :: TypeRep arg, identity arg)-  describe (UTabularFunApplyTerm (func :: Term f) (arg :: Term a)) =-    DTabularFunApplyTerm (typeRep :: TypeRep f, identity func) (typeRep :: TypeRep a, identity arg)-  describe (UGeneralFunApplyTerm (func :: Term f) (arg :: Term a)) =-    DGeneralFunApplyTerm (typeRep :: TypeRep f, identity func) (typeRep :: TypeRep a, identity arg)-  describe (UDivIntegralTerm arg1 arg2) = DDivIntegralTerm (identity arg1) (identity arg2)-  describe (UModIntegralTerm arg1 arg2) = DModIntegralTerm (identity arg1) (identity arg2)-  describe (UQuotIntegralTerm arg1 arg2) = DRemIntegralTerm (identity arg1) (identity arg2)-  describe (URemIntegralTerm arg1 arg2) = DQuotIntegralTerm (identity arg1) (identity arg2)-  describe (UDivBoundedIntegralTerm arg1 arg2) = DDivBoundedIntegralTerm (identity arg1) (identity arg2)-  describe (UModBoundedIntegralTerm arg1 arg2) = DModBoundedIntegralTerm (identity arg1) (identity arg2)-  describe (UQuotBoundedIntegralTerm arg1 arg2) = DRemBoundedIntegralTerm (identity arg1) (identity arg2)-  describe (URemBoundedIntegralTerm arg1 arg2) = DQuotBoundedIntegralTerm (identity arg1) (identity arg2)--  identify i = go-    where-      go (UConTerm v) = ConTerm i v-      go (USymTerm v) = SymTerm i v-      go (UUnaryTerm tag tm) = UnaryTerm i tag tm-      go (UBinaryTerm tag tm1 tm2) = BinaryTerm i tag tm1 tm2-      go (UTernaryTerm tag tm1 tm2 tm3) = TernaryTerm i tag tm1 tm2 tm3-      go (UNotTerm arg) = NotTerm i arg-      go (UOrTerm arg1 arg2) = OrTerm i arg1 arg2-      go (UAndTerm arg1 arg2) = AndTerm i arg1 arg2-      go (UEqvTerm arg1 arg2) = EqvTerm i arg1 arg2-      go (UITETerm cond l r) = ITETerm i cond l r-      go (UAddNumTerm arg1 arg2) = AddNumTerm i arg1 arg2-      go (UUMinusNumTerm arg) = UMinusNumTerm i arg-      go (UTimesNumTerm arg1 arg2) = TimesNumTerm i arg1 arg2-      go (UAbsNumTerm arg) = AbsNumTerm i arg-      go (USignumNumTerm arg) = SignumNumTerm i arg-      go (ULTNumTerm arg1 arg2) = LTNumTerm i arg1 arg2-      go (ULENumTerm arg1 arg2) = LENumTerm i arg1 arg2-      go (UAndBitsTerm arg1 arg2) = AndBitsTerm i arg1 arg2-      go (UOrBitsTerm arg1 arg2) = OrBitsTerm i arg1 arg2-      go (UXorBitsTerm arg1 arg2) = XorBitsTerm i arg1 arg2-      go (UComplementBitsTerm arg) = ComplementBitsTerm i arg-      go (UShiftLeftTerm arg n) = ShiftLeftTerm i arg n-      go (UShiftRightTerm arg n) = ShiftRightTerm i arg n-      go (URotateLeftTerm arg n) = RotateLeftTerm i arg n-      go (URotateRightTerm arg n) = RotateRightTerm i arg n-      go (UToSignedTerm arg) = ToSignedTerm i arg-      go (UToUnsignedTerm arg) = ToUnsignedTerm i arg-      go (UBVConcatTerm arg1 arg2) = BVConcatTerm i arg1 arg2-      go (UBVSelectTerm ix w arg) = BVSelectTerm i ix w arg-      go (UBVExtendTerm signed n arg) = BVExtendTerm i signed n arg-      go (UTabularFunApplyTerm func arg) = TabularFunApplyTerm i func arg-      go (UGeneralFunApplyTerm func arg) = GeneralFunApplyTerm i func arg-      go (UDivIntegralTerm arg1 arg2) = DivIntegralTerm i arg1 arg2-      go (UModIntegralTerm arg1 arg2) = ModIntegralTerm i arg1 arg2-      go (UQuotIntegralTerm arg1 arg2) = QuotIntegralTerm i arg1 arg2-      go (URemIntegralTerm arg1 arg2) = RemIntegralTerm i arg1 arg2-      go (UDivBoundedIntegralTerm arg1 arg2) = DivBoundedIntegralTerm i arg1 arg2-      go (UModBoundedIntegralTerm arg1 arg2) = ModBoundedIntegralTerm i arg1 arg2-      go (UQuotBoundedIntegralTerm arg1 arg2) = QuotBoundedIntegralTerm i arg1 arg2-      go (URemBoundedIntegralTerm arg1 arg2) = RemBoundedIntegralTerm i arg1 arg2-  cache = termCache--instance (SupportedPrim t) => Eq (Description (Term t)) where-  DConTerm (l :: tyl) == DConTerm (r :: tyr) = cast @tyl @tyr l == Just r-  DSymTerm ls == DSymTerm rs = ls == rs-  DUnaryTerm (tagl :: tagl) li == DUnaryTerm (tagr :: tagr) ri = eqHeteroTag tagl tagr && eqTypedId li ri-  DBinaryTerm (tagl :: tagl) li1 li2 == DBinaryTerm (tagr :: tagr) ri1 ri2 =-    eqHeteroTag tagl tagr && eqTypedId li1 ri1 && eqTypedId li2 ri2-  DTernaryTerm (tagl :: tagl) li1 li2 li3 == DTernaryTerm (tagr :: tagr) ri1 ri2 ri3 =-    eqHeteroTag tagl tagr && eqTypedId li1 ri1 && eqTypedId li2 ri2 && eqTypedId li3 ri3-  DNotTerm li == DNotTerm ri = li == ri-  DOrTerm li1 li2 == DOrTerm ri1 ri2 = li1 == ri1 && li2 == ri2-  DAndTerm li1 li2 == DAndTerm ri1 ri2 = li1 == ri1 && li2 == ri2-  DEqvTerm lrep li1 li2 == DEqvTerm rrep ri1 ri2 = eqTypeRepBool lrep rrep && li1 == ri1 && li2 == ri2-  DITETerm lc li1 li2 == DITETerm rc ri1 ri2 = lc == rc && li1 == ri1 && li2 == ri2-  DAddNumTerm li1 li2 == DAddNumTerm ri1 ri2 = li1 == ri1 && li2 == ri2-  DUMinusNumTerm li == DUMinusNumTerm ri = li == ri-  DTimesNumTerm li1 li2 == DTimesNumTerm ri1 ri2 = li1 == ri1 && li2 == ri2-  DAbsNumTerm li == DAbsNumTerm ri = li == ri-  DSignumNumTerm li == DSignumNumTerm ri = li == ri-  DLTNumTerm lrep li1 li2 == DLTNumTerm rrep ri1 ri2 = eqTypeRepBool lrep rrep && li1 == ri1 && li2 == ri2-  DLENumTerm lrep li1 li2 == DLENumTerm rrep ri1 ri2 = eqTypeRepBool lrep rrep && li1 == ri1 && li2 == ri2-  DAndBitsTerm li1 li2 == DAndBitsTerm ri1 ri2 = li1 == ri1 && li2 == ri2-  DOrBitsTerm li1 li2 == DOrBitsTerm ri1 ri2 = li1 == ri1 && li2 == ri2-  DXorBitsTerm li1 li2 == DXorBitsTerm ri1 ri2 = li1 == ri1 && li2 == ri2-  DComplementBitsTerm li == DComplementBitsTerm ri = li == ri-  DShiftLeftTerm li ln == DShiftLeftTerm ri rn = li == ri && ln == rn-  DShiftRightTerm li ln == DShiftRightTerm ri rn = li == ri && ln == rn-  DRotateLeftTerm li ln == DRotateLeftTerm ri rn = li == ri && ln == rn-  DRotateRightTerm li ln == DRotateRightTerm ri rn = li == ri && ln == rn-  DToSignedTerm li == DToSignedTerm ri = eqTypedId li ri-  DToUnsignedTerm li == DToUnsignedTerm ri = eqTypedId li ri-  DBVConcatTerm lrep1 lrep2 li1 li2 == DBVConcatTerm rrep1 rrep2 ri1 ri2 =-    eqTypeRepBool lrep1 rrep1 && eqTypeRepBool lrep2 rrep2 && li1 == ri1 && li2 == ri2-  DBVSelectTerm lix li == DBVSelectTerm rix ri =-    eqTypeRepBool lix rix && eqTypedId li ri-  DBVExtendTerm lIsSigned ln li == DBVExtendTerm rIsSigned rn ri =-    lIsSigned == rIsSigned-      && eqTypeRepBool ln rn-      && eqTypedId li ri-  DTabularFunApplyTerm lf li == DTabularFunApplyTerm rf ri = eqTypedId lf rf && eqTypedId li ri-  DGeneralFunApplyTerm lf li == DGeneralFunApplyTerm rf ri = eqTypedId lf rf && eqTypedId li ri-  DDivIntegralTerm li1 li2 == DDivIntegralTerm ri1 ri2 = li1 == ri1 && li2 == ri2-  DModIntegralTerm li1 li2 == DModIntegralTerm ri1 ri2 = li1 == ri1 && li2 == ri2-  DQuotIntegralTerm li1 li2 == DQuotIntegralTerm ri1 ri2 = li1 == ri1 && li2 == ri2-  DRemIntegralTerm li1 li2 == DRemIntegralTerm ri1 ri2 = li1 == ri1 && li2 == ri2-  DDivBoundedIntegralTerm li1 li2 == DDivBoundedIntegralTerm ri1 ri2 = li1 == ri1 && li2 == ri2-  DModBoundedIntegralTerm li1 li2 == DModBoundedIntegralTerm ri1 ri2 = li1 == ri1 && li2 == ri2-  DQuotBoundedIntegralTerm li1 li2 == DQuotBoundedIntegralTerm ri1 ri2 = li1 == ri1 && li2 == ri2-  DRemBoundedIntegralTerm li1 li2 == DRemBoundedIntegralTerm ri1 ri2 = li1 == ri1 && li2 == ri2-  _ == _ = False--instance (SupportedPrim t) => Hashable (Description (Term t)) where-  hashWithSalt s (DConTerm c) = s `hashWithSalt` (0 :: Int) `hashWithSalt` c-  hashWithSalt s (DSymTerm name) = s `hashWithSalt` (1 :: Int) `hashWithSalt` name-  hashWithSalt s (DUnaryTerm tag id1) = s `hashWithSalt` (2 :: Int) `hashWithSalt` tag `hashWithSalt` id1-  hashWithSalt s (DBinaryTerm tag id1 id2) =-    s `hashWithSalt` (3 :: Int) `hashWithSalt` tag `hashWithSalt` id1 `hashWithSalt` id2-  hashWithSalt s (DTernaryTerm tag id1 id2 id3) =-    s `hashWithSalt` (4 :: Int) `hashWithSalt` tag `hashWithSalt` id1 `hashWithSalt` id2 `hashWithSalt` id3-  hashWithSalt s (DNotTerm id1) = s `hashWithSalt` (5 :: Int) `hashWithSalt` id1-  hashWithSalt s (DOrTerm id1 id2) = s `hashWithSalt` (6 :: Int) `hashWithSalt` id1 `hashWithSalt` id2-  hashWithSalt s (DAndTerm id1 id2) = s `hashWithSalt` (7 :: Int) `hashWithSalt` id1 `hashWithSalt` id2-  hashWithSalt s (DEqvTerm rep id1 id2) =-    s-      `hashWithSalt` (8 :: Int)-      `hashWithSalt` rep-      `hashWithSalt` id1-      `hashWithSalt` id2-  hashWithSalt s (DITETerm idc id1 id2) =-    s-      `hashWithSalt` (9 :: Int)-      `hashWithSalt` idc-      `hashWithSalt` id1-      `hashWithSalt` id2-  hashWithSalt s (DAddNumTerm id1 id2) = s `hashWithSalt` (10 :: Int) `hashWithSalt` id1 `hashWithSalt` id2-  hashWithSalt s (DUMinusNumTerm id1) = s `hashWithSalt` (11 :: Int) `hashWithSalt` id1-  hashWithSalt s (DTimesNumTerm id1 id2) = s `hashWithSalt` (12 :: Int) `hashWithSalt` id1 `hashWithSalt` id2-  hashWithSalt s (DAbsNumTerm id1) = s `hashWithSalt` (13 :: Int) `hashWithSalt` id1-  hashWithSalt s (DSignumNumTerm id1) = s `hashWithSalt` (14 :: Int) `hashWithSalt` id1-  hashWithSalt s (DLTNumTerm rep id1 id2) =-    s `hashWithSalt` (15 :: Int) `hashWithSalt` rep `hashWithSalt` id1 `hashWithSalt` id2-  hashWithSalt s (DLENumTerm rep id1 id2) =-    s `hashWithSalt` (16 :: Int) `hashWithSalt` rep `hashWithSalt` id1 `hashWithSalt` id2-  hashWithSalt s (DAndBitsTerm id1 id2) = s `hashWithSalt` (17 :: Int) `hashWithSalt` id1 `hashWithSalt` id2-  hashWithSalt s (DOrBitsTerm id1 id2) = s `hashWithSalt` (18 :: Int) `hashWithSalt` id1 `hashWithSalt` id2-  hashWithSalt s (DXorBitsTerm id1 id2) = s `hashWithSalt` (19 :: Int) `hashWithSalt` id1 `hashWithSalt` id2-  hashWithSalt s (DComplementBitsTerm id1) = s `hashWithSalt` (20 :: Int) `hashWithSalt` id1-  hashWithSalt s (DShiftLeftTerm id1 idn) = s `hashWithSalt` (38 :: Int) `hashWithSalt` id1 `hashWithSalt` idn-  hashWithSalt s (DShiftRightTerm id1 idn) = s `hashWithSalt` (39 :: Int) `hashWithSalt` id1 `hashWithSalt` idn-  hashWithSalt s (DRotateLeftTerm id1 idn) = s `hashWithSalt` (40 :: Int) `hashWithSalt` id1 `hashWithSalt` idn-  hashWithSalt s (DRotateRightTerm id1 idn) = s `hashWithSalt` (41 :: Int) `hashWithSalt` id1 `hashWithSalt` idn-  hashWithSalt s (DToSignedTerm id) = s `hashWithSalt` (23 :: Int) `hashWithSalt` id-  hashWithSalt s (DToUnsignedTerm id) = s `hashWithSalt` (24 :: Int) `hashWithSalt` id-  hashWithSalt s (DBVConcatTerm rep1 rep2 id1 id2) =-    s `hashWithSalt` (25 :: Int) `hashWithSalt` rep1 `hashWithSalt` rep2 `hashWithSalt` id1 `hashWithSalt` id2-  hashWithSalt s (DBVSelectTerm ix id1) = s `hashWithSalt` (26 :: Int) `hashWithSalt` ix `hashWithSalt` id1-  hashWithSalt s (DBVExtendTerm signed n id1) =-    s-      `hashWithSalt` (27 :: Int)-      `hashWithSalt` signed-      `hashWithSalt` n-      `hashWithSalt` id1-  hashWithSalt s (DTabularFunApplyTerm id1 id2) = s `hashWithSalt` (28 :: Int) `hashWithSalt` id1 `hashWithSalt` id2-  hashWithSalt s (DGeneralFunApplyTerm id1 id2) = s `hashWithSalt` (29 :: Int) `hashWithSalt` id1 `hashWithSalt` id2-  hashWithSalt s (DDivIntegralTerm id1 id2) = s `hashWithSalt` (30 :: Int) `hashWithSalt` id1 `hashWithSalt` id2-  hashWithSalt s (DModIntegralTerm id1 id2) = s `hashWithSalt` (31 :: Int) `hashWithSalt` id1 `hashWithSalt` id2-  hashWithSalt s (DQuotIntegralTerm id1 id2) = s `hashWithSalt` (32 :: Int) `hashWithSalt` id1 `hashWithSalt` id2-  hashWithSalt s (DRemIntegralTerm id1 id2) = s `hashWithSalt` (33 :: Int) `hashWithSalt` id1 `hashWithSalt` id2-  hashWithSalt s (DDivBoundedIntegralTerm id1 id2) = s `hashWithSalt` (34 :: Int) `hashWithSalt` id1 `hashWithSalt` id2-  hashWithSalt s (DModBoundedIntegralTerm id1 id2) = s `hashWithSalt` (35 :: Int) `hashWithSalt` id1 `hashWithSalt` id2-  hashWithSalt s (DQuotBoundedIntegralTerm id1 id2) = s `hashWithSalt` (36 :: Int) `hashWithSalt` id1 `hashWithSalt` id2-  hashWithSalt s (DRemBoundedIntegralTerm id1 id2) = s `hashWithSalt` (37 :: Int) `hashWithSalt` id1 `hashWithSalt` id2---- Basic Bool-defaultValueForBool :: Bool-defaultValueForBool = False--defaultValueForBoolDyn :: ModelValue-defaultValueForBoolDyn = toModelValue defaultValueForBool--instance SupportedPrim Bool where-  pformatCon True = "true"-  pformatCon False = "false"-  defaultValue = defaultValueForBool-  defaultValueDynamic _ = defaultValueForBoolDyn--defaultValueForInteger :: Integer-defaultValueForInteger = 0--defaultValueForIntegerDyn :: ModelValue-defaultValueForIntegerDyn = toModelValue defaultValueForInteger---- Basic Integer-instance SupportedPrim Integer where-  pformatCon = show-  defaultValue = defaultValueForInteger-  defaultValueDynamic _ = defaultValueForIntegerDyn---- Signed BV-instance (KnownNat w, 1 <= w) => SupportedPrim (IntN w) where-  type PrimConstraint (IntN w) = (KnownNat w, 1 <= w)-  pformatCon = show-  defaultValue = 0---- Unsigned BV-instance (KnownNat w, 1 <= w) => SupportedPrim (WordN w) where-  type PrimConstraint (WordN w) = (KnownNat w, 1 <= w)-  pformatCon = show-  defaultValue = 0---- | General symbolic function type. Use the '#' operator to apply the function.--- Note that this function should be applied to symbolic values only. It is by--- itself already a symbolic value, but can be considered partially concrete--- as the function body is specified. Use 'Grisette.IR.SymPrim.Data.SymPrim.-~>' for uninterpreted general--- symbolic functions.------ The result would be partially evaluated.------ >>> :set -XOverloadedStrings--- >>> :set -XTypeOperators--- >>> let f = ("x" :: TypedSymbol Integer) --> ("x" + 1 + "y" :: SymInteger) :: Integer --> Integer--- >>> f # 1    -- 1 has the type SymInteger--- (+ 2 y)--- >>> f # "a"  -- "a" has the type SymInteger--- (+ 1 (+ a y))-data (-->) a b where-  GeneralFun :: (SupportedPrim a, SupportedPrim b) => TypedSymbol a -> Term b -> a --> b--instance (LinkedRep a sa, LinkedRep b sb) => Function (a --> b) where-  type Arg (a --> b) = SymType a-  type Ret (a --> b) = SymType b-  (GeneralFun s t) # x = wrapTerm $ substTerm s (underlyingTerm x) t--{--pattern GeneralFun :: () => (SupportedPrim a, SupportedPrim b) => TypedSymbol a -> Term b -> a --> b-pattern GeneralFun arg v <- GeneralFun arg v--{-# COMPLETE GeneralFun #-}--}--infixr 0 -->--buildGeneralFun :: () => (SupportedPrim a, SupportedPrim b) => TypedSymbol a -> Term b -> a --> b-buildGeneralFun arg v = GeneralFun newarg (substTerm arg (symTerm newarg) v)-  where-    newarg = WithInfo arg ARG--data ARG = ARG-  deriving (Eq, Ord, Lift, Show, Generic)--instance NFData ARG where-  rnf ARG = ()--instance Hashable ARG where-  hashWithSalt s ARG = s `hashWithSalt` (0 :: Int)--instance Eq (a --> b) where-  GeneralFun sym1 tm1 == GeneralFun sym2 tm2 = sym1 == sym2 && tm1 == tm2--instance Show (a --> b) where-  show (GeneralFun sym tm) = "\\(" ++ show sym ++ ") -> " ++ pformat tm--instance Lift (a --> b) where-  liftTyped (GeneralFun sym tm) = [||GeneralFun sym tm||]--instance Hashable (a --> b) where-  s `hashWithSalt` (GeneralFun sym tm) = s `hashWithSalt` sym `hashWithSalt` tm--instance NFData (a --> b) where-  rnf (GeneralFun sym tm) = rnf sym `seq` rnf tm--instance (SupportedPrim a, SupportedPrim b) => SupportedPrim (a --> b) where-  type PrimConstraint (a --> b) = (SupportedPrim a, SupportedPrim b)-  defaultValue = buildGeneralFun (SimpleSymbol "a") (conTerm defaultValue)--instance-  (SupportedPrim a, SupportedPrim b) =>-  SupportedPrim (a =-> b)-  where-  type PrimConstraint (a =-> b) = (SupportedPrim a, SupportedPrim b)-  defaultValue = TabularFun [] (defaultValue @b)
− src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/Term.hs-boot 
@@ -1,402 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE QuantifiedConstraints #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}--module Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term-  ( SupportedPrim (..),-    SymRep (..),-    ConRep (..),-    LinkedRep (..),-    UnaryOp (..),-    BinaryOp (..),-    TernaryOp (..),-    TypedSymbol (..),-    SomeTypedSymbol (..),-    Term (..),-    UTerm (..),-    type (-->) (..),-    buildGeneralFun,-  )-where--import Control.DeepSeq (NFData)-import Data.Bits (Bits, FiniteBits)-import Data.Hashable (Hashable)-import Data.Interned (Cache, Id)-import Data.Kind (Constraint)-import qualified Data.Text as T-import GHC.TypeNats (KnownNat, type (+), type (<=))-import Grisette.Core.Data.Class.BitVector-  ( SizedBV,-  )-import Grisette.Core.Data.Class.SignConversion (SignConversion)-import Grisette.Core.Data.Class.SymRotate (SymRotate)-import Grisette.Core.Data.Class.SymShift (SymShift)-import Grisette.IR.SymPrim.Data.Prim.ModelValue-  ( ModelValue,-    toModelValue,-  )-import Grisette.IR.SymPrim.Data.TabularFun-  ( type (=->),-  )-import Language.Haskell.TH.Syntax (Lift)-import Type.Reflection (TypeRep, Typeable)--class (Lift t, Typeable t, Hashable t, Eq t, Show t, NFData t) => SupportedPrim t where-  type PrimConstraint t :: Constraint-  type PrimConstraint _ = ()-  default withPrim :: (PrimConstraint t) => proxy t -> ((PrimConstraint t) => a) -> a-  withPrim :: proxy t -> ((PrimConstraint t) => a) -> a-  withPrim _ i = i-  termCache :: Cache (Term t)-  termCache = typeMemoizedCache-  pformatCon :: t -> String-  default pformatCon :: (Show t) => t -> String-  pformatCon = show-  pformatSym :: TypedSymbol t -> String-  pformatSym _ = showUntyped-  defaultValue :: t-  defaultValueDynamic :: proxy t -> ModelValue-  defaultValueDynamic _ = toModelValue (defaultValue @t)--class ConRep sym where-  type ConType sym--class (SupportedPrim con) => SymRep con where-  type SymType con--class-  (ConRep sym, SymRep con, sym ~ SymType con, con ~ ConType sym) =>-  LinkedRep con sym-    | con -> sym,-      sym -> con-  where-  underlyingTerm :: sym -> Term con-  wrapTerm :: Term con -> sym--class-  (SupportedPrim arg, SupportedPrim t, Lift tag, NFData tag, Show tag, Typeable tag, Eq tag, Hashable tag) =>-  UnaryOp tag arg t-    | tag arg -> t-  where-  partialEvalUnary :: (Typeable tag, Typeable t) => tag -> Term arg -> Term t-  pformatUnary :: tag -> Term arg -> String--class-  ( SupportedPrim arg1,-    SupportedPrim arg2,-    SupportedPrim t,-    Lift tag,-    NFData tag,-    Show tag,-    Typeable tag,-    Eq tag,-    Hashable tag-  ) =>-  BinaryOp tag arg1 arg2 t-    | tag arg1 arg2 -> t-  where-  partialEvalBinary :: (Typeable tag, Typeable t) => tag -> Term arg1 -> Term arg2 -> Term t-  pformatBinary :: tag -> Term arg1 -> Term arg2 -> String--class-  ( SupportedPrim arg1,-    SupportedPrim arg2,-    SupportedPrim arg3,-    SupportedPrim t,-    Lift tag,-    NFData tag,-    Show tag,-    Typeable tag,-    Eq tag,-    Hashable tag-  ) =>-  TernaryOp tag arg1 arg2 arg3 t-    | tag arg1 arg2 arg3 -> t-  where-  partialEvalTernary :: (Typeable tag, Typeable t) => tag -> Term arg1 -> Term arg2 -> Term arg3 -> Term t-  pformatTernary :: tag -> Term arg1 -> Term arg2 -> Term arg3 -> String--data TypedSymbol t where-  SimpleSymbol :: (SupportedPrim t) => T.Text -> TypedSymbol t-  IndexedSymbol :: (SupportedPrim t) => T.Text -> Int -> TypedSymbol t-  WithInfo ::-    forall t a.-    ( SupportedPrim t,-      Typeable a,-      Ord a,-      Lift a,-      NFData a,-      Show a,-      Hashable a-    ) =>-    TypedSymbol t ->-    a ->-    TypedSymbol t--data SomeTypedSymbol where-  SomeTypedSymbol :: forall t. TypeRep t -> TypedSymbol t -> SomeTypedSymbol--data Term t where-  ConTerm :: (SupportedPrim t) => {-# UNPACK #-} !Id -> !t -> Term t-  SymTerm :: (SupportedPrim t) => {-# UNPACK #-} !Id -> !(TypedSymbol t) -> Term t-  UnaryTerm ::-    (UnaryOp tag arg t) =>-    {-# UNPACK #-} !Id ->-    !tag ->-    !(Term arg) ->-    Term t-  BinaryTerm ::-    (BinaryOp tag arg1 arg2 t) =>-    {-# UNPACK #-} !Id ->-    !tag ->-    !(Term arg1) ->-    !(Term arg2) ->-    Term t-  TernaryTerm ::-    (TernaryOp tag arg1 arg2 arg3 t) =>-    {-# UNPACK #-} !Id ->-    !tag ->-    !(Term arg1) ->-    !(Term arg2) ->-    !(Term arg3) ->-    Term t-  NotTerm :: {-# UNPACK #-} !Id -> !(Term Bool) -> Term Bool-  OrTerm :: {-# UNPACK #-} !Id -> !(Term Bool) -> !(Term Bool) -> Term Bool-  AndTerm :: {-# UNPACK #-} !Id -> !(Term Bool) -> !(Term Bool) -> Term Bool-  EqvTerm :: (SupportedPrim t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term Bool-  ITETerm :: (SupportedPrim t) => {-# UNPACK #-} !Id -> !(Term Bool) -> !(Term t) -> !(Term t) -> Term t-  AddNumTerm :: (SupportedPrim t, Num t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t-  UMinusNumTerm :: (SupportedPrim t, Num t) => {-# UNPACK #-} !Id -> !(Term t) -> Term t-  TimesNumTerm :: (SupportedPrim t, Num t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t-  AbsNumTerm :: (SupportedPrim t, Num t) => {-# UNPACK #-} !Id -> !(Term t) -> Term t-  SignumNumTerm :: (SupportedPrim t, Num t) => {-# UNPACK #-} !Id -> !(Term t) -> Term t-  LTNumTerm :: (SupportedPrim t, Num t, Ord t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term Bool-  LENumTerm :: (SupportedPrim t, Num t, Ord t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term Bool-  AndBitsTerm :: (SupportedPrim t, Bits t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t-  OrBitsTerm :: (SupportedPrim t, Bits t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t-  XorBitsTerm :: (SupportedPrim t, Bits t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t-  ComplementBitsTerm :: (SupportedPrim t, Bits t) => {-# UNPACK #-} !Id -> !(Term t) -> Term t-  ShiftLeftTerm :: (SupportedPrim t, Integral t, FiniteBits t, SymShift t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t-  ShiftRightTerm :: (SupportedPrim t, Integral t, FiniteBits t, SymShift t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t-  RotateLeftTerm :: (SupportedPrim t, Integral t, FiniteBits t, SymRotate t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t-  RotateRightTerm :: (SupportedPrim t, Integral t, FiniteBits t, SymRotate t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t-  ToSignedTerm ::-    ( SupportedPrim u,-      SupportedPrim s,-      SignConversion u s-    ) =>-    {-# UNPACK #-} !Id ->-    !(Term u) ->-    Term s-  ToUnsignedTerm ::-    ( SupportedPrim u,-      SupportedPrim s,-      SignConversion u s-    ) =>-    {-# UNPACK #-} !Id ->-    !(Term s) ->-    Term u-  BVConcatTerm ::-    ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n),-      Typeable bv,-      KnownNat a,-      KnownNat b,-      KnownNat (a + b),-      1 <= a,-      1 <= b,-      1 <= (a + b),-      SizedBV bv-    ) =>-    {-# UNPACK #-} !Id ->-    !(Term (bv a)) ->-    !(Term (bv b)) ->-    Term (bv (a + b))-  BVSelectTerm ::-    ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n),-      Typeable bv,-      KnownNat n,-      KnownNat ix,-      KnownNat w,-      1 <= n,-      1 <= w,-      ix + w <= n,-      SizedBV bv-    ) =>-    {-# UNPACK #-} !Id ->-    !(TypeRep ix) ->-    !(TypeRep w) ->-    !(Term (bv n)) ->-    Term (bv w)-  BVExtendTerm ::-    ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n),-      Typeable bv,-      KnownNat l,-      KnownNat r,-      1 <= l,-      1 <= r,-      l <= r,-      SizedBV bv-    ) =>-    {-# UNPACK #-} !Id ->-    !Bool ->-    !(TypeRep r) ->-    !(Term (bv l)) ->-    Term (bv r)-  TabularFunApplyTerm ::-    ( SupportedPrim a,-      SupportedPrim b-    ) =>-    {-# UNPACK #-} !Id ->-    Term (a =-> b) ->-    Term a ->-    Term b-  GeneralFunApplyTerm ::-    ( SupportedPrim a,-      SupportedPrim b-    ) =>-    {-# UNPACK #-} !Id ->-    Term (a --> b) ->-    Term a ->-    Term b-  DivIntegralTerm :: (SupportedPrim t, Integral t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t-  ModIntegralTerm :: (SupportedPrim t, Integral t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t-  QuotIntegralTerm :: (SupportedPrim t, Integral t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t-  RemIntegralTerm :: (SupportedPrim t, Integral t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t-  DivBoundedIntegralTerm :: (SupportedPrim t, Bounded t, Integral t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t-  ModBoundedIntegralTerm :: (SupportedPrim t, Bounded t, Integral t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t-  QuotBoundedIntegralTerm :: (SupportedPrim t, Bounded t, Integral t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t-  RemBoundedIntegralTerm :: (SupportedPrim t, Bounded t, Integral t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t--data UTerm t where-  UConTerm :: (SupportedPrim t) => !t -> UTerm t-  USymTerm :: (SupportedPrim t) => !(TypedSymbol t) -> UTerm t-  UUnaryTerm :: (UnaryOp tag arg t) => !tag -> !(Term arg) -> UTerm t-  UBinaryTerm ::-    (BinaryOp tag arg1 arg2 t) =>-    !tag ->-    !(Term arg1) ->-    !(Term arg2) ->-    UTerm t-  UTernaryTerm ::-    (TernaryOp tag arg1 arg2 arg3 t) =>-    !tag ->-    !(Term arg1) ->-    !(Term arg2) ->-    !(Term arg3) ->-    UTerm t-  UNotTerm :: !(Term Bool) -> UTerm Bool-  UOrTerm :: !(Term Bool) -> !(Term Bool) -> UTerm Bool-  UAndTerm :: !(Term Bool) -> !(Term Bool) -> UTerm Bool-  UEqvTerm :: (SupportedPrim t) => !(Term t) -> !(Term t) -> UTerm Bool-  UITETerm :: (SupportedPrim t) => !(Term Bool) -> !(Term t) -> !(Term t) -> UTerm t-  UAddNumTerm :: (SupportedPrim t, Num t) => !(Term t) -> !(Term t) -> UTerm t-  UUMinusNumTerm :: (SupportedPrim t, Num t) => !(Term t) -> UTerm t-  UTimesNumTerm :: (SupportedPrim t, Num t) => !(Term t) -> !(Term t) -> UTerm t-  UAbsNumTerm :: (SupportedPrim t, Num t) => !(Term t) -> UTerm t-  USignumNumTerm :: (SupportedPrim t, Num t) => !(Term t) -> UTerm t-  ULTNumTerm :: (SupportedPrim t, Num t, Ord t) => !(Term t) -> !(Term t) -> UTerm Bool-  ULENumTerm :: (SupportedPrim t, Num t, Ord t) => !(Term t) -> !(Term t) -> UTerm Bool-  UAndBitsTerm :: (SupportedPrim t, Bits t) => !(Term t) -> !(Term t) -> UTerm t-  UOrBitsTerm :: (SupportedPrim t, Bits t) => !(Term t) -> !(Term t) -> UTerm t-  UXorBitsTerm :: (SupportedPrim t, Bits t) => !(Term t) -> !(Term t) -> UTerm t-  UComplementBitsTerm :: (SupportedPrim t, Bits t) => !(Term t) -> UTerm t-  UShiftLeftTerm :: (SupportedPrim t, Integral t, FiniteBits t, SymShift t) => !(Term t) -> !(Term t) -> UTerm t-  UShiftRightTerm :: (SupportedPrim t, Integral t, FiniteBits t, SymShift t) => !(Term t) -> !(Term t) -> UTerm t-  URotateLeftTerm :: (SupportedPrim t, Integral t, FiniteBits t, SymRotate t) => !(Term t) -> !(Term t) -> UTerm t-  URotateRightTerm :: (SupportedPrim t, Integral t, FiniteBits t, SymRotate t) => !(Term t) -> !(Term t) -> UTerm t-  UToSignedTerm ::-    ( SupportedPrim u,-      SupportedPrim s,-      SignConversion u s-    ) =>-    !(Term u) ->-    UTerm s-  UToUnsignedTerm ::-    ( SupportedPrim u,-      SupportedPrim s,-      SignConversion u s-    ) =>-    !(Term s) ->-    UTerm u-  UBVConcatTerm ::-    ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n),-      Typeable bv,-      KnownNat a,-      KnownNat b,-      KnownNat (a + b),-      1 <= a,-      1 <= b,-      1 <= a + b,-      SizedBV bv-    ) =>-    !(Term (bv a)) ->-    !(Term (bv b)) ->-    UTerm (bv (a + b))-  UBVSelectTerm ::-    ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n),-      Typeable bv,-      KnownNat n,-      KnownNat ix,-      KnownNat w,-      1 <= n,-      1 <= w,-      ix + w <= n,-      SizedBV bv-    ) =>-    !(TypeRep ix) ->-    !(TypeRep w) ->-    !(Term (bv n)) ->-    UTerm (bv w)-  UBVExtendTerm ::-    ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n),-      Typeable bv,-      KnownNat l,-      KnownNat r,-      1 <= l,-      1 <= r,-      l <= r,-      SizedBV bv-    ) =>-    !Bool ->-    !(TypeRep r) ->-    !(Term (bv l)) ->-    UTerm (bv r)-  UTabularFunApplyTerm ::-    ( SupportedPrim a,-      SupportedPrim b-    ) =>-    Term (a =-> b) ->-    Term a ->-    UTerm b-  UGeneralFunApplyTerm ::-    ( SupportedPrim a,-      SupportedPrim b-    ) =>-    Term (a --> b) ->-    Term a ->-    UTerm b-  UDivIntegralTerm :: (SupportedPrim t, Integral t) => !(Term t) -> !(Term t) -> UTerm t-  UModIntegralTerm :: (SupportedPrim t, Integral t) => !(Term t) -> !(Term t) -> UTerm t-  UQuotIntegralTerm :: (SupportedPrim t, Integral t) => !(Term t) -> !(Term t) -> UTerm t-  URemIntegralTerm :: (SupportedPrim t, Integral t) => !(Term t) -> !(Term t) -> UTerm t-  UDivBoundedIntegralTerm :: (SupportedPrim t, Bounded t, Integral t) => !(Term t) -> !(Term t) -> UTerm t-  UModBoundedIntegralTerm :: (SupportedPrim t, Bounded t, Integral t) => !(Term t) -> !(Term t) -> UTerm t-  UQuotBoundedIntegralTerm :: (SupportedPrim t, Bounded t, Integral t) => !(Term t) -> !(Term t) -> UTerm t-  URemBoundedIntegralTerm :: (SupportedPrim t, Bounded t, Integral t) => !(Term t) -> !(Term t) -> UTerm t--data (-->) a b where-  GeneralFun :: (SupportedPrim a, SupportedPrim b) => TypedSymbol a -> Term b -> a --> b--infixr 0 -->--buildGeneralFun :: (SupportedPrim a, SupportedPrim b) => TypedSymbol a -> Term b -> a --> b
− src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/TermSubstitution.hs 
@@ -1,194 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}---- |--- Module      :   Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermSubstitution--- 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.IR.SymPrim.Data.Prim.InternedTerm.TermSubstitution-  ( substTerm,-  )-where--import Grisette.Core.Data.MemoUtils (htmemo)-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors-  ( conTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.SomeTerm-  ( SomeTerm (SomeTerm),-  )-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term-  ( BinaryOp (partialEvalBinary),-    SupportedPrim,-    Term-      ( AbsNumTerm,-        AddNumTerm,-        AndBitsTerm,-        AndTerm,-        BVConcatTerm,-        BVExtendTerm,-        BVSelectTerm,-        BinaryTerm,-        ComplementBitsTerm,-        ConTerm,-        DivBoundedIntegralTerm,-        DivIntegralTerm,-        EqvTerm,-        GeneralFunApplyTerm,-        ITETerm,-        LENumTerm,-        LTNumTerm,-        ModBoundedIntegralTerm,-        ModIntegralTerm,-        NotTerm,-        OrBitsTerm,-        OrTerm,-        QuotBoundedIntegralTerm,-        QuotIntegralTerm,-        RemBoundedIntegralTerm,-        RemIntegralTerm,-        RotateLeftTerm,-        RotateRightTerm,-        ShiftLeftTerm,-        ShiftRightTerm,-        SignumNumTerm,-        SymTerm,-        TabularFunApplyTerm,-        TernaryTerm,-        TimesNumTerm,-        ToSignedTerm,-        ToUnsignedTerm,-        UMinusNumTerm,-        UnaryTerm,-        XorBitsTerm-      ),-    TernaryOp (partialEvalTernary),-    TypedSymbol,-    UnaryOp (partialEvalUnary),-    someTypedSymbol,-    type (-->) (GeneralFun),-  )-import Grisette.IR.SymPrim.Data.Prim.PartialEval.BV-  ( pevalBVConcatTerm,-    pevalBVExtendTerm,-    pevalBVSelectTerm,-    pevalToSignedTerm,-    pevalToUnsignedTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bits-  ( pevalAndBitsTerm,-    pevalComplementBitsTerm,-    pevalOrBitsTerm,-    pevalRotateLeftTerm,-    pevalRotateRightTerm,-    pevalShiftLeftTerm,-    pevalShiftRightTerm,-    pevalXorBitsTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool-  ( pevalAndTerm,-    pevalEqvTerm,-    pevalITETerm,-    pevalNotTerm,-    pevalOrTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.PartialEval.GeneralFun-  ( pevalGeneralFunApplyTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.PartialEval.Integral-  ( pevalDivBoundedIntegralTerm,-    pevalDivIntegralTerm,-    pevalModBoundedIntegralTerm,-    pevalModIntegralTerm,-    pevalQuotBoundedIntegralTerm,-    pevalQuotIntegralTerm,-    pevalRemBoundedIntegralTerm,-    pevalRemIntegralTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.PartialEval.Num-  ( pevalAbsNumTerm,-    pevalAddNumTerm,-    pevalLeNumTerm,-    pevalLtNumTerm,-    pevalSignumNumTerm,-    pevalTimesNumTerm,-    pevalUMinusNumTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.PartialEval.TabularFun-  ( pevalTabularFunApplyTerm,-  )-import Type.Reflection-  ( TypeRep,-    eqTypeRep,-    typeRep,-    pattern App,-    type (:~~:) (HRefl),-  )-import Unsafe.Coerce (unsafeCoerce)--substTerm :: forall a b. (SupportedPrim a, SupportedPrim b) => TypedSymbol a -> Term a -> Term b -> Term b-substTerm sym term = gov-  where-    gov :: (SupportedPrim x) => Term x -> Term x-    gov b = case go (SomeTerm b) of-      SomeTerm v -> unsafeCoerce v-    go :: SomeTerm -> SomeTerm-    go = htmemo $ \stm@(SomeTerm (tm :: Term v)) ->-      case tm of-        ConTerm _ cv -> case (typeRep :: TypeRep v) of-          App (App gf _) _ ->-            case eqTypeRep gf (typeRep @(-->)) of-              Just HRefl -> case cv of-                GeneralFun sym1 tm1 ->-                  if someTypedSymbol sym1 == someTypedSymbol sym-                    then stm-                    else SomeTerm $ conTerm $ GeneralFun sym1 (gov tm1)-              Nothing -> stm-          _ -> stm-        SymTerm _ ts -> SomeTerm $ if someTypedSymbol ts == someTypedSymbol sym then unsafeCoerce term else tm-        UnaryTerm _ tag te -> SomeTerm $ partialEvalUnary tag (gov te)-        BinaryTerm _ tag te te' -> SomeTerm $ partialEvalBinary tag (gov te) (gov te')-        TernaryTerm _ tag op1 op2 op3 -> SomeTerm $ partialEvalTernary tag (gov op1) (gov op2) (gov op3)-        NotTerm _ op -> SomeTerm $ pevalNotTerm (gov op)-        OrTerm _ op1 op2 -> SomeTerm $ pevalOrTerm (gov op1) (gov op2)-        AndTerm _ op1 op2 -> SomeTerm $ pevalAndTerm (gov op1) (gov op2)-        EqvTerm _ op1 op2 -> SomeTerm $ pevalEqvTerm (gov op1) (gov op2)-        ITETerm _ c op1 op2 -> SomeTerm $ pevalITETerm (gov c) (gov op1) (gov op2)-        AddNumTerm _ op1 op2 -> SomeTerm $ pevalAddNumTerm (gov op1) (gov op2)-        UMinusNumTerm _ op -> SomeTerm $ pevalUMinusNumTerm (gov op)-        TimesNumTerm _ op1 op2 -> SomeTerm $ pevalTimesNumTerm (gov op1) (gov op2)-        AbsNumTerm _ op -> SomeTerm $ pevalAbsNumTerm (gov op)-        SignumNumTerm _ op -> SomeTerm $ pevalSignumNumTerm (gov op)-        LTNumTerm _ op1 op2 -> SomeTerm $ pevalLtNumTerm (gov op1) (gov op2)-        LENumTerm _ op1 op2 -> SomeTerm $ pevalLeNumTerm (gov op1) (gov op2)-        AndBitsTerm _ op1 op2 -> SomeTerm $ pevalAndBitsTerm (gov op1) (gov op2)-        OrBitsTerm _ op1 op2 -> SomeTerm $ pevalOrBitsTerm (gov op1) (gov op2)-        XorBitsTerm _ op1 op2 -> SomeTerm $ pevalXorBitsTerm (gov op1) (gov op2)-        ComplementBitsTerm _ op -> SomeTerm $ pevalComplementBitsTerm (gov op)-        ShiftLeftTerm _ op n -> SomeTerm $ pevalShiftLeftTerm (gov op) (gov n)-        RotateLeftTerm _ op n -> SomeTerm $ pevalRotateLeftTerm (gov op) (gov n)-        ShiftRightTerm _ op n -> SomeTerm $ pevalShiftRightTerm (gov op) (gov n)-        RotateRightTerm _ op n -> SomeTerm $ pevalRotateRightTerm (gov op) (gov n)-        ToSignedTerm _ op -> SomeTerm $ pevalToSignedTerm op-        ToUnsignedTerm _ op -> SomeTerm $ pevalToUnsignedTerm op-        BVConcatTerm _ op1 op2 -> SomeTerm $ pevalBVConcatTerm (gov op1) (gov op2)-        BVSelectTerm _ ix w op -> SomeTerm $ pevalBVSelectTerm ix w (gov op)-        BVExtendTerm _ n signed op -> SomeTerm $ pevalBVExtendTerm n signed (gov op)-        TabularFunApplyTerm _ f op -> SomeTerm $ pevalTabularFunApplyTerm (gov f) (gov op)-        GeneralFunApplyTerm _ f op -> SomeTerm $ pevalGeneralFunApplyTerm (gov f) (gov op)-        DivIntegralTerm _ op1 op2 -> SomeTerm $ pevalDivIntegralTerm (gov op1) (gov op2)-        ModIntegralTerm _ op1 op2 -> SomeTerm $ pevalModIntegralTerm (gov op1) (gov op2)-        QuotIntegralTerm _ op1 op2 -> SomeTerm $ pevalQuotIntegralTerm (gov op1) (gov op2)-        RemIntegralTerm _ op1 op2 -> SomeTerm $ pevalRemIntegralTerm (gov op1) (gov op2)-        DivBoundedIntegralTerm _ op1 op2 -> SomeTerm $ pevalDivBoundedIntegralTerm (gov op1) (gov op2)-        ModBoundedIntegralTerm _ op1 op2 -> SomeTerm $ pevalModBoundedIntegralTerm (gov op1) (gov op2)-        QuotBoundedIntegralTerm _ op1 op2 -> SomeTerm $ pevalQuotBoundedIntegralTerm (gov op1) (gov op2)-        RemBoundedIntegralTerm _ op1 op2 -> SomeTerm $ pevalRemBoundedIntegralTerm (gov op1) (gov op2)
− src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/TermSubstitution.hs-boot 
@@ -1,20 +0,0 @@-{-# LANGUAGE RankNTypes #-}--module Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermSubstitution-  ( substTerm,-  )-where--import {-# SOURCE #-} Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term-  ( SupportedPrim,-    Term,-    TypedSymbol,-  )--substTerm ::-  forall a b.-  (SupportedPrim a, SupportedPrim b) =>-  TypedSymbol a ->-  Term a ->-  Term b ->-  Term b
− src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/TermUtils.hs 
@@ -1,449 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}---- |--- Module      :   Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermUtils--- 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.IR.SymPrim.Data.Prim.InternedTerm.TermUtils-  ( identity,-    identityWithTypeRep,-    introSupportedPrimConstraint,-    extractSymbolicsTerm,-    castTerm,-    pformat,-    someTermsSize,-    someTermSize,-    termSize,-    termsSize,-  )-where--import Control.Monad.State-  ( MonadState (get, put),-    State,-    evalState,-    execState,-    gets,-    modify',-  )-import qualified Data.HashMap.Strict as M-import qualified Data.HashSet as S-import Data.Interned (Id)-import Data.Typeable-  ( Proxy (Proxy),-    TypeRep,-    Typeable,-    cast,-    typeRep,-  )-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.SomeTerm-  ( SomeTerm (SomeTerm),-  )-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term-  ( BinaryOp (pformatBinary),-    SomeTypedSymbol (SomeTypedSymbol),-    SupportedPrim (pformatCon, pformatSym),-    Term-      ( AbsNumTerm,-        AddNumTerm,-        AndBitsTerm,-        AndTerm,-        BVConcatTerm,-        BVExtendTerm,-        BVSelectTerm,-        BinaryTerm,-        ComplementBitsTerm,-        ConTerm,-        DivBoundedIntegralTerm,-        DivIntegralTerm,-        EqvTerm,-        GeneralFunApplyTerm,-        ITETerm,-        LENumTerm,-        LTNumTerm,-        ModBoundedIntegralTerm,-        ModIntegralTerm,-        NotTerm,-        OrBitsTerm,-        OrTerm,-        QuotBoundedIntegralTerm,-        QuotIntegralTerm,-        RemBoundedIntegralTerm,-        RemIntegralTerm,-        RotateLeftTerm,-        RotateRightTerm,-        ShiftLeftTerm,-        ShiftRightTerm,-        SignumNumTerm,-        SymTerm,-        TabularFunApplyTerm,-        TernaryTerm,-        TimesNumTerm,-        ToSignedTerm,-        ToUnsignedTerm,-        UMinusNumTerm,-        UnaryTerm,-        XorBitsTerm-      ),-    TernaryOp (pformatTernary),-    TypedSymbol,-    UnaryOp (pformatUnary),-  )-import qualified Type.Reflection as R--identity :: Term t -> Id-identity = snd . identityWithTypeRep-{-# INLINE identity #-}--identityWithTypeRep :: forall t. Term t -> (TypeRep, Id)-identityWithTypeRep (ConTerm i _) = (typeRep (Proxy @t), i)-identityWithTypeRep (SymTerm i _) = (typeRep (Proxy @t), i)-identityWithTypeRep (UnaryTerm i _ _) = (typeRep (Proxy @t), i)-identityWithTypeRep (BinaryTerm i _ _ _) = (typeRep (Proxy @t), i)-identityWithTypeRep (TernaryTerm i _ _ _ _) = (typeRep (Proxy @t), i)-identityWithTypeRep (NotTerm i _) = (typeRep (Proxy @t), i)-identityWithTypeRep (OrTerm i _ _) = (typeRep (Proxy @t), i)-identityWithTypeRep (AndTerm i _ _) = (typeRep (Proxy @t), i)-identityWithTypeRep (EqvTerm i _ _) = (typeRep (Proxy @t), i)-identityWithTypeRep (ITETerm i _ _ _) = (typeRep (Proxy @t), i)-identityWithTypeRep (AddNumTerm i _ _) = (typeRep (Proxy @t), i)-identityWithTypeRep (UMinusNumTerm i _) = (typeRep (Proxy @t), i)-identityWithTypeRep (TimesNumTerm i _ _) = (typeRep (Proxy @t), i)-identityWithTypeRep (AbsNumTerm i _) = (typeRep (Proxy @t), i)-identityWithTypeRep (SignumNumTerm i _) = (typeRep (Proxy @t), i)-identityWithTypeRep (LTNumTerm i _ _) = (typeRep (Proxy @t), i)-identityWithTypeRep (LENumTerm i _ _) = (typeRep (Proxy @t), i)-identityWithTypeRep (AndBitsTerm i _ _) = (typeRep (Proxy @t), i)-identityWithTypeRep (OrBitsTerm i _ _) = (typeRep (Proxy @t), i)-identityWithTypeRep (XorBitsTerm i _ _) = (typeRep (Proxy @t), i)-identityWithTypeRep (ComplementBitsTerm i _) = (typeRep (Proxy @t), i)-identityWithTypeRep (ShiftLeftTerm i _ _) = (typeRep (Proxy @t), i)-identityWithTypeRep (ShiftRightTerm i _ _) = (typeRep (Proxy @t), i)-identityWithTypeRep (RotateLeftTerm i _ _) = (typeRep (Proxy @t), i)-identityWithTypeRep (RotateRightTerm i _ _) = (typeRep (Proxy @t), i)-identityWithTypeRep (ToSignedTerm i _) = (typeRep (Proxy @t), i)-identityWithTypeRep (ToUnsignedTerm i _) = (typeRep (Proxy @t), i)-identityWithTypeRep (BVConcatTerm i _ _) = (typeRep (Proxy @t), i)-identityWithTypeRep (BVSelectTerm i _ _ _) = (typeRep (Proxy @t), i)-identityWithTypeRep (BVExtendTerm i _ _ _) = (typeRep (Proxy @t), i)-identityWithTypeRep (TabularFunApplyTerm i _ _) = (typeRep (Proxy @t), i)-identityWithTypeRep (GeneralFunApplyTerm i _ _) = (typeRep (Proxy @t), i)-identityWithTypeRep (DivIntegralTerm i _ _) = (typeRep (Proxy @t), i)-identityWithTypeRep (ModIntegralTerm i _ _) = (typeRep (Proxy @t), i)-identityWithTypeRep (QuotIntegralTerm i _ _) = (typeRep (Proxy @t), i)-identityWithTypeRep (RemIntegralTerm i _ _) = (typeRep (Proxy @t), i)-identityWithTypeRep (DivBoundedIntegralTerm i _ _) = (typeRep (Proxy @t), i)-identityWithTypeRep (ModBoundedIntegralTerm i _ _) = (typeRep (Proxy @t), i)-identityWithTypeRep (QuotBoundedIntegralTerm i _ _) = (typeRep (Proxy @t), i)-identityWithTypeRep (RemBoundedIntegralTerm i _ _) = (typeRep (Proxy @t), i)-{-# INLINE identityWithTypeRep #-}--introSupportedPrimConstraint :: forall t a. Term t -> ((SupportedPrim t) => a) -> a-introSupportedPrimConstraint ConTerm {} x = x-introSupportedPrimConstraint SymTerm {} x = x-introSupportedPrimConstraint UnaryTerm {} x = x-introSupportedPrimConstraint BinaryTerm {} x = x-introSupportedPrimConstraint TernaryTerm {} x = x-introSupportedPrimConstraint NotTerm {} x = x-introSupportedPrimConstraint OrTerm {} x = x-introSupportedPrimConstraint AndTerm {} x = x-introSupportedPrimConstraint EqvTerm {} x = x-introSupportedPrimConstraint ITETerm {} x = x-introSupportedPrimConstraint AddNumTerm {} x = x-introSupportedPrimConstraint UMinusNumTerm {} x = x-introSupportedPrimConstraint TimesNumTerm {} x = x-introSupportedPrimConstraint AbsNumTerm {} x = x-introSupportedPrimConstraint SignumNumTerm {} x = x-introSupportedPrimConstraint LTNumTerm {} x = x-introSupportedPrimConstraint LENumTerm {} x = x-introSupportedPrimConstraint AndBitsTerm {} x = x-introSupportedPrimConstraint OrBitsTerm {} x = x-introSupportedPrimConstraint XorBitsTerm {} x = x-introSupportedPrimConstraint ComplementBitsTerm {} x = x-introSupportedPrimConstraint ShiftLeftTerm {} x = x-introSupportedPrimConstraint RotateLeftTerm {} x = x-introSupportedPrimConstraint ShiftRightTerm {} x = x-introSupportedPrimConstraint RotateRightTerm {} x = x-introSupportedPrimConstraint ToSignedTerm {} x = x-introSupportedPrimConstraint ToUnsignedTerm {} x = x-introSupportedPrimConstraint BVConcatTerm {} x = x-introSupportedPrimConstraint BVSelectTerm {} x = x-introSupportedPrimConstraint BVExtendTerm {} x = x-introSupportedPrimConstraint TabularFunApplyTerm {} x = x-introSupportedPrimConstraint GeneralFunApplyTerm {} x = x-introSupportedPrimConstraint DivIntegralTerm {} x = x-introSupportedPrimConstraint ModIntegralTerm {} x = x-introSupportedPrimConstraint QuotIntegralTerm {} x = x-introSupportedPrimConstraint RemIntegralTerm {} x = x-introSupportedPrimConstraint DivBoundedIntegralTerm {} x = x-introSupportedPrimConstraint ModBoundedIntegralTerm {} x = x-introSupportedPrimConstraint QuotBoundedIntegralTerm {} x = x-introSupportedPrimConstraint RemBoundedIntegralTerm {} x = x-{-# INLINE introSupportedPrimConstraint #-}--extractSymbolicsSomeTerm :: SomeTerm -> S.HashSet SomeTypedSymbol-extractSymbolicsSomeTerm t1 = evalState (gocached t1) M.empty-  where-    gocached :: SomeTerm -> State (M.HashMap SomeTerm (S.HashSet SomeTypedSymbol)) (S.HashSet SomeTypedSymbol)-    gocached t = do-      v <- gets (M.lookup t)-      case v of-        Just x -> return x-        Nothing -> do-          res <- go t-          st <- get-          put $ M.insert t res st-          return res-    go :: SomeTerm -> State (M.HashMap SomeTerm (S.HashSet SomeTypedSymbol)) (S.HashSet SomeTypedSymbol)-    go (SomeTerm ConTerm {}) = return S.empty-    go (SomeTerm (SymTerm _ (sym :: TypedSymbol a))) = return $ S.singleton $ SomeTypedSymbol (R.typeRep @a) sym-    go (SomeTerm (UnaryTerm _ _ arg)) = goUnary arg-    go (SomeTerm (BinaryTerm _ _ arg1 arg2)) = goBinary arg1 arg2-    go (SomeTerm (TernaryTerm _ _ arg1 arg2 arg3)) = goTernary arg1 arg2 arg3-    go (SomeTerm (NotTerm _ arg)) = goUnary arg-    go (SomeTerm (OrTerm _ arg1 arg2)) = goBinary arg1 arg2-    go (SomeTerm (AndTerm _ arg1 arg2)) = goBinary arg1 arg2-    go (SomeTerm (EqvTerm _ arg1 arg2)) = goBinary arg1 arg2-    go (SomeTerm (ITETerm _ cond arg1 arg2)) = goTernary cond arg1 arg2-    go (SomeTerm (AddNumTerm _ arg1 arg2)) = goBinary arg1 arg2-    go (SomeTerm (UMinusNumTerm _ arg)) = goUnary arg-    go (SomeTerm (TimesNumTerm _ arg1 arg2)) = goBinary arg1 arg2-    go (SomeTerm (AbsNumTerm _ arg)) = goUnary arg-    go (SomeTerm (SignumNumTerm _ arg)) = goUnary arg-    go (SomeTerm (LTNumTerm _ arg1 arg2)) = goBinary arg1 arg2-    go (SomeTerm (LENumTerm _ arg1 arg2)) = goBinary arg1 arg2-    go (SomeTerm (AndBitsTerm _ arg1 arg2)) = goBinary arg1 arg2-    go (SomeTerm (OrBitsTerm _ arg1 arg2)) = goBinary arg1 arg2-    go (SomeTerm (XorBitsTerm _ arg1 arg2)) = goBinary arg1 arg2-    go (SomeTerm (ComplementBitsTerm _ arg)) = goUnary arg-    go (SomeTerm (ShiftLeftTerm _ arg n1)) = goBinary arg n1-    go (SomeTerm (ShiftRightTerm _ arg n1)) = goBinary arg n1-    go (SomeTerm (RotateLeftTerm _ arg n1)) = goBinary arg n1-    go (SomeTerm (RotateRightTerm _ arg n1)) = goBinary arg n1-    go (SomeTerm (ToSignedTerm _ arg)) = goUnary arg-    go (SomeTerm (ToUnsignedTerm _ arg)) = goUnary arg-    go (SomeTerm (BVConcatTerm _ arg1 arg2)) = goBinary arg1 arg2-    go (SomeTerm (BVSelectTerm _ _ _ arg)) = goUnary arg-    go (SomeTerm (BVExtendTerm _ _ _ arg)) = goUnary arg-    go (SomeTerm (TabularFunApplyTerm _ func arg)) = goBinary func arg-    go (SomeTerm (GeneralFunApplyTerm _ func arg)) = goBinary func arg-    go (SomeTerm (DivIntegralTerm _ arg1 arg2)) = goBinary arg1 arg2-    go (SomeTerm (ModIntegralTerm _ arg1 arg2)) = goBinary arg1 arg2-    go (SomeTerm (QuotIntegralTerm _ arg1 arg2)) = goBinary arg1 arg2-    go (SomeTerm (RemIntegralTerm _ arg1 arg2)) = goBinary arg1 arg2-    go (SomeTerm (DivBoundedIntegralTerm _ arg1 arg2)) = goBinary arg1 arg2-    go (SomeTerm (ModBoundedIntegralTerm _ arg1 arg2)) = goBinary arg1 arg2-    go (SomeTerm (QuotBoundedIntegralTerm _ arg1 arg2)) = goBinary arg1 arg2-    go (SomeTerm (RemBoundedIntegralTerm _ arg1 arg2)) = goBinary arg1 arg2-    goUnary arg = gocached (SomeTerm arg)-    goBinary arg1 arg2 = do-      r1 <- gocached (SomeTerm arg1)-      r2 <- gocached (SomeTerm arg2)-      return $ r1 <> r2-    goTernary arg1 arg2 arg3 = do-      r1 <- gocached (SomeTerm arg1)-      r2 <- gocached (SomeTerm arg2)-      r3 <- gocached (SomeTerm arg3)-      return $ r1 <> r2 <> r3-{-# INLINEABLE extractSymbolicsSomeTerm #-}--extractSymbolicsTerm :: (SupportedPrim a) => Term a -> S.HashSet SomeTypedSymbol-extractSymbolicsTerm t = extractSymbolicsSomeTerm (SomeTerm t)-{-# INLINE extractSymbolicsTerm #-}--castTerm :: forall a b. (Typeable b) => Term a -> Maybe (Term b)-castTerm t@ConTerm {} = cast t-castTerm t@SymTerm {} = cast t-castTerm t@UnaryTerm {} = cast t-castTerm t@BinaryTerm {} = cast t-castTerm t@TernaryTerm {} = cast t-castTerm t@NotTerm {} = cast t-castTerm t@OrTerm {} = cast t-castTerm t@AndTerm {} = cast t-castTerm t@EqvTerm {} = cast t-castTerm t@ITETerm {} = cast t-castTerm t@AddNumTerm {} = cast t-castTerm t@UMinusNumTerm {} = cast t-castTerm t@TimesNumTerm {} = cast t-castTerm t@AbsNumTerm {} = cast t-castTerm t@SignumNumTerm {} = cast t-castTerm t@LTNumTerm {} = cast t-castTerm t@LENumTerm {} = cast t-castTerm t@AndBitsTerm {} = cast t-castTerm t@OrBitsTerm {} = cast t-castTerm t@XorBitsTerm {} = cast t-castTerm t@ComplementBitsTerm {} = cast t-castTerm t@ShiftLeftTerm {} = cast t-castTerm t@ShiftRightTerm {} = cast t-castTerm t@RotateLeftTerm {} = cast t-castTerm t@RotateRightTerm {} = cast t-castTerm t@ToSignedTerm {} = cast t-castTerm t@ToUnsignedTerm {} = cast t-castTerm t@BVConcatTerm {} = cast t-castTerm t@BVSelectTerm {} = cast t-castTerm t@BVExtendTerm {} = cast t-castTerm t@TabularFunApplyTerm {} = cast t-castTerm t@GeneralFunApplyTerm {} = cast t-castTerm t@DivIntegralTerm {} = cast t-castTerm t@ModIntegralTerm {} = cast t-castTerm t@QuotIntegralTerm {} = cast t-castTerm t@RemIntegralTerm {} = cast t-castTerm t@DivBoundedIntegralTerm {} = cast t-castTerm t@ModBoundedIntegralTerm {} = cast t-castTerm t@QuotBoundedIntegralTerm {} = cast t-castTerm t@RemBoundedIntegralTerm {} = cast t-{-# INLINE castTerm #-}--pformat :: forall t. (SupportedPrim t) => Term t -> String-pformat (ConTerm _ t) = pformatCon t-pformat (SymTerm _ sym) = pformatSym sym-pformat (UnaryTerm _ tag arg1) = pformatUnary tag arg1-pformat (BinaryTerm _ tag arg1 arg2) = pformatBinary tag arg1 arg2-pformat (TernaryTerm _ tag arg1 arg2 arg3) = pformatTernary tag arg1 arg2 arg3-pformat (NotTerm _ arg) = "(! " ++ pformat arg ++ ")"-pformat (OrTerm _ arg1 arg2) = "(|| " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")"-pformat (AndTerm _ arg1 arg2) = "(&& " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")"-pformat (EqvTerm _ arg1 arg2) = "(= " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")"-pformat (ITETerm _ cond arg1 arg2) = "(ite " ++ pformat cond ++ " " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")"-pformat (AddNumTerm _ arg1 arg2) = "(+ " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")"-pformat (UMinusNumTerm _ arg) = "(- " ++ pformat arg ++ ")"-pformat (TimesNumTerm _ arg1 arg2) = "(* " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")"-pformat (AbsNumTerm _ arg) = "(abs " ++ pformat arg ++ ")"-pformat (SignumNumTerm _ arg) = "(signum " ++ pformat arg ++ ")"-pformat (LTNumTerm _ arg1 arg2) = "(< " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")"-pformat (LENumTerm _ arg1 arg2) = "(<= " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")"-pformat (AndBitsTerm _ arg1 arg2) = "(& " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")"-pformat (OrBitsTerm _ arg1 arg2) = "(| " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")"-pformat (XorBitsTerm _ arg1 arg2) = "(^ " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")"-pformat (ComplementBitsTerm _ arg) = "(~ " ++ pformat arg ++ ")"-pformat (ShiftLeftTerm _ arg n) = "(shl " ++ pformat arg ++ " " ++ pformat n ++ ")"-pformat (ShiftRightTerm _ arg n) = "(shr " ++ pformat arg ++ " " ++ pformat n ++ ")"-pformat (RotateLeftTerm _ arg n) = "(rotl " ++ pformat arg ++ " " ++ pformat n ++ ")"-pformat (RotateRightTerm _ arg n) = "(rotr " ++ pformat arg ++ " " ++ pformat n ++ ")"-pformat (ToSignedTerm _ arg) = "(u2s " ++ pformat arg ++ " " ++ ")"-pformat (ToUnsignedTerm _ arg) = "(s2u " ++ pformat arg ++ " " ++ ")"-pformat (BVConcatTerm _ arg1 arg2) = "(bvconcat " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")"-pformat (BVSelectTerm _ ix w arg) = "(bvselect " ++ show ix ++ " " ++ show w ++ " " ++ pformat arg ++ ")"-pformat (BVExtendTerm _ signed n arg) =-  (if signed then "(bvsext " else "(bvzext ") ++ show n ++ " " ++ pformat arg ++ ")"-pformat (TabularFunApplyTerm _ func arg) = "(apply " ++ pformat func ++ " " ++ pformat arg ++ ")"-pformat (GeneralFunApplyTerm _ func arg) = "(apply " ++ pformat func ++ " " ++ pformat arg ++ ")"-pformat (DivIntegralTerm _ arg1 arg2) = "(div " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")"-pformat (ModIntegralTerm _ arg1 arg2) = "(mod " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")"-pformat (QuotIntegralTerm _ arg1 arg2) = "(quot " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")"-pformat (RemIntegralTerm _ arg1 arg2) = "(rem " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")"-pformat (DivBoundedIntegralTerm _ arg1 arg2) = "(div " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")"-pformat (ModBoundedIntegralTerm _ arg1 arg2) = "(mod " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")"-pformat (QuotBoundedIntegralTerm _ arg1 arg2) = "(quot " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")"-pformat (RemBoundedIntegralTerm _ arg1 arg2) = "(rem " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")"-{-# INLINE pformat #-}--someTermsSize :: [SomeTerm] -> Int-someTermsSize terms = S.size $ execState (traverse goSome terms) S.empty-  where-    exists t = gets (S.member (SomeTerm t))-    add t = modify' (S.insert (SomeTerm t))-    goSome :: SomeTerm -> State (S.HashSet SomeTerm) ()-    goSome (SomeTerm b) = go b-    go :: forall b. Term b -> State (S.HashSet SomeTerm) ()-    go t@ConTerm {} = add t-    go t@SymTerm {} = add t-    go t@(UnaryTerm _ _ arg) = goUnary t arg-    go t@(BinaryTerm _ _ arg1 arg2) = goBinary t arg1 arg2-    go t@(TernaryTerm _ _ arg1 arg2 arg3) = goTernary t arg1 arg2 arg3-    go t@(NotTerm _ arg) = goUnary t arg-    go t@(OrTerm _ arg1 arg2) = goBinary t arg1 arg2-    go t@(AndTerm _ arg1 arg2) = goBinary t arg1 arg2-    go t@(EqvTerm _ arg1 arg2) = goBinary t arg1 arg2-    go t@(ITETerm _ cond arg1 arg2) = goTernary t cond arg1 arg2-    go t@(AddNumTerm _ arg1 arg2) = goBinary t arg1 arg2-    go t@(UMinusNumTerm _ arg) = goUnary t arg-    go t@(TimesNumTerm _ arg1 arg2) = goBinary t arg1 arg2-    go t@(AbsNumTerm _ arg) = goUnary t arg-    go t@(SignumNumTerm _ arg) = goUnary t arg-    go t@(LTNumTerm _ arg1 arg2) = goBinary t arg1 arg2-    go t@(LENumTerm _ arg1 arg2) = goBinary t arg1 arg2-    go t@(AndBitsTerm _ arg1 arg2) = goBinary t arg1 arg2-    go t@(OrBitsTerm _ arg1 arg2) = goBinary t arg1 arg2-    go t@(XorBitsTerm _ arg1 arg2) = goBinary t arg1 arg2-    go t@(ComplementBitsTerm _ arg) = goUnary t arg-    go t@(ShiftLeftTerm _ arg n) = goBinary t arg n-    go t@(ShiftRightTerm _ arg n) = goBinary t arg n-    go t@(RotateLeftTerm _ arg n) = goBinary t arg n-    go t@(RotateRightTerm _ arg n) = goBinary t arg n-    go t@(ToSignedTerm _ arg) = goUnary t arg-    go t@(ToUnsignedTerm _ arg) = goUnary t arg-    go t@(BVConcatTerm _ arg1 arg2) = goBinary t arg1 arg2-    go t@(BVSelectTerm _ _ _ arg) = goUnary t arg-    go t@(BVExtendTerm _ _ _ arg) = goUnary t arg-    go t@(TabularFunApplyTerm _ func arg) = goBinary t func arg-    go t@(GeneralFunApplyTerm _ func arg) = goBinary t func arg-    go t@(DivIntegralTerm _ arg1 arg2) = goBinary t arg1 arg2-    go t@(ModIntegralTerm _ arg1 arg2) = goBinary t arg1 arg2-    go t@(QuotIntegralTerm _ arg1 arg2) = goBinary t arg1 arg2-    go t@(RemIntegralTerm _ arg1 arg2) = goBinary t arg1 arg2-    go t@(DivBoundedIntegralTerm _ arg1 arg2) = goBinary t arg1 arg2-    go t@(ModBoundedIntegralTerm _ arg1 arg2) = goBinary t arg1 arg2-    go t@(QuotBoundedIntegralTerm _ arg1 arg2) = goBinary t arg1 arg2-    go t@(RemBoundedIntegralTerm _ arg1 arg2) = goBinary t arg1 arg2-    goUnary :: forall a b. (SupportedPrim a) => Term a -> Term b -> State (S.HashSet SomeTerm) ()-    goUnary t arg = do-      b <- exists t-      if b-        then return ()-        else do-          add t-          go arg-    goBinary ::-      forall a b c.-      (SupportedPrim a, SupportedPrim b) =>-      Term a ->-      Term b ->-      Term c ->-      State (S.HashSet SomeTerm) ()-    goBinary t arg1 arg2 = do-      b <- exists t-      if b-        then return ()-        else do-          add t-          go arg1-          go arg2-    goTernary ::-      forall a b c d.-      (SupportedPrim a, SupportedPrim b, SupportedPrim c) =>-      Term a ->-      Term b ->-      Term c ->-      Term d ->-      State (S.HashSet SomeTerm) ()-    goTernary t arg1 arg2 arg3 = do-      b <- exists t-      if b-        then return ()-        else do-          add t-          go arg1-          go arg2-          go arg3-{-# INLINEABLE someTermsSize #-}--someTermSize :: SomeTerm -> Int-someTermSize term = someTermsSize [term]-{-# INLINE someTermSize #-}--termsSize :: [Term a] -> Int-termsSize terms = someTermsSize $ (\x -> introSupportedPrimConstraint x $ SomeTerm x) <$> terms-{-# INLINEABLE termsSize #-}--termSize :: Term a -> Int-termSize term = termsSize [term]-{-# INLINE termSize #-}
− src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/TermUtils.hs-boot 
@@ -1,31 +0,0 @@-{-# LANGUAGE RankNTypes #-}--module Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermUtils-  ( identity,-    identityWithTypeRep,-    introSupportedPrimConstraint,-    extractSymbolicsTerm,-    castTerm,-    pformat,-    termSize,-    termsSize,-  )-where--import qualified Data.HashSet as S-import Data.Interned (Id)-import Data.Typeable (TypeRep, Typeable)-import {-# SOURCE #-} Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term-  ( SomeTypedSymbol,-    SupportedPrim,-    Term,-  )--identity :: Term t -> Id-identityWithTypeRep :: forall t. Term t -> (TypeRep, Id)-introSupportedPrimConstraint :: forall t a. Term t -> ((SupportedPrim t) => a) -> a-extractSymbolicsTerm :: (SupportedPrim a) => Term a -> S.HashSet SomeTypedSymbol-castTerm :: forall a b. (Typeable b) => Term a -> Maybe (Term b)-pformat :: forall t. (SupportedPrim t) => Term t -> String-termsSize :: [Term a] -> Int-termSize :: Term a -> Int
− src/Grisette/IR/SymPrim/Data/Prim/Model.hs 
@@ -1,805 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}---- |--- Module      :   Grisette.IR.SymPrim.Data.Prim.Model--- 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.IR.SymPrim.Data.Prim.Model-  ( SymbolSet (..),-    Model (..),-    ModelValuePair (..),-    equation,-    evaluateTerm,-  )-where--import qualified Data.HashMap.Strict as M-import qualified Data.HashSet as S-import Data.Hashable (Hashable)-import Data.List (sort, sortOn)-import Data.Proxy (Proxy (Proxy))-import GHC.Generics (Generic)-import Grisette.Core.Data.Class.ModelOps-  ( ModelOps-      ( emptyModel,-        exceptFor,-        exceptFor',-        extendTo,-        insertValue,-        isEmptyModel,-        modelContains,-        restrictTo,-        valueOf-      ),-    ModelRep (buildModel),-    SymbolSetOps-      ( containsSymbol,-        differenceSet,-        emptySet,-        insertSymbol,-        intersectionSet,-        isEmptySet,-        unionSet-      ),-    SymbolSetRep (buildSymbolSet),-  )-import Grisette.Core.Data.MemoUtils (htmemo)-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors-  ( conTerm,-    symTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.SomeTerm-  ( SomeTerm (SomeTerm),-  )-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term-  ( BinaryOp (partialEvalBinary),-    SomeTypedSymbol (SomeTypedSymbol),-    SupportedPrim (defaultValue, defaultValueDynamic),-    Term-      ( AbsNumTerm,-        AddNumTerm,-        AndBitsTerm,-        AndTerm,-        BVConcatTerm,-        BVExtendTerm,-        BVSelectTerm,-        BinaryTerm,-        ComplementBitsTerm,-        ConTerm,-        DivBoundedIntegralTerm,-        DivIntegralTerm,-        EqvTerm,-        GeneralFunApplyTerm,-        ITETerm,-        LENumTerm,-        LTNumTerm,-        ModBoundedIntegralTerm,-        ModIntegralTerm,-        NotTerm,-        OrBitsTerm,-        OrTerm,-        QuotBoundedIntegralTerm,-        QuotIntegralTerm,-        RemBoundedIntegralTerm,-        RemIntegralTerm,-        RotateLeftTerm,-        RotateRightTerm,-        ShiftLeftTerm,-        ShiftRightTerm,-        SignumNumTerm,-        SymTerm,-        TabularFunApplyTerm,-        TernaryTerm,-        TimesNumTerm,-        ToSignedTerm,-        ToUnsignedTerm,-        UMinusNumTerm,-        UnaryTerm,-        XorBitsTerm-      ),-    TernaryOp (partialEvalTernary),-    TypedSymbol,-    UnaryOp (partialEvalUnary),-    showUntyped,-    someTypedSymbol,-    withSymbolSupported,-    type (-->) (GeneralFun),-  )-import Grisette.IR.SymPrim.Data.Prim.ModelValue-  ( ModelValue,-    toModelValue,-    unsafeFromModelValue,-  )-import Grisette.IR.SymPrim.Data.Prim.PartialEval.BV-  ( pevalBVConcatTerm,-    pevalBVExtendTerm,-    pevalBVSelectTerm,-    pevalToSignedTerm,-    pevalToUnsignedTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bits-  ( pevalAndBitsTerm,-    pevalComplementBitsTerm,-    pevalOrBitsTerm,-    pevalRotateLeftTerm,-    pevalRotateRightTerm,-    pevalShiftLeftTerm,-    pevalShiftRightTerm,-    pevalXorBitsTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool-  ( pevalAndTerm,-    pevalEqvTerm,-    pevalITETerm,-    pevalNotTerm,-    pevalOrTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.PartialEval.GeneralFun-  ( pevalGeneralFunApplyTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.PartialEval.Integral-  ( pevalDivBoundedIntegralTerm,-    pevalDivIntegralTerm,-    pevalModBoundedIntegralTerm,-    pevalModIntegralTerm,-    pevalQuotBoundedIntegralTerm,-    pevalQuotIntegralTerm,-    pevalRemBoundedIntegralTerm,-    pevalRemIntegralTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.PartialEval.Num-  ( pevalAbsNumTerm,-    pevalAddNumTerm,-    pevalLeNumTerm,-    pevalLtNumTerm,-    pevalSignumNumTerm,-    pevalTimesNumTerm,-    pevalUMinusNumTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.PartialEval.TabularFun-  ( pevalTabularFunApplyTerm,-  )-import Type.Reflection-  ( TypeRep,-    eqTypeRep,-    typeRep,-    pattern App,-    type (:~~:) (HRefl),-  )-import Unsafe.Coerce (unsafeCoerce)---- $setup--- >>> import Grisette.Core--- >>> import Grisette.IR.SymPrim--- >>> :set -XFlexibleContexts---- | Symbolic constant set.-newtype SymbolSet = SymbolSet {unSymbolSet :: S.HashSet SomeTypedSymbol}-  deriving (Eq, Generic, Hashable, Semigroup, Monoid)--instance Show SymbolSet where-  showsPrec prec (SymbolSet s) = showParen (prec >= 10) $ \x ->-    "SymbolSet {"-      ++ go0 (sort $ show <$> S.toList s)-      ++ "}"-      ++ x-    where-      go0 [] = ""-      go0 [x] = x-      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)--instance Show Model where-  showsPrec prec (Model m) = showParen (prec >= 10) $ \x ->-    "Model {"-      ++ go0 (sortOn (\(x, _) -> show x) $ M.toList m)-      ++ "}"-      ++ x-    where-      go0 [] = ""-      go0 [(SomeTypedSymbol _ s, v)] = showUntyped s ++ " -> " ++ show v-      go0 ((SomeTypedSymbol _ s, v) : xs) = showUntyped s ++ " -> " ++ show v ++ ", " ++ go0 xs--equation :: TypedSymbol a -> Model -> Maybe (Term Bool)-equation tsym m = withSymbolSupported tsym $-  case valueOf tsym m of-    Just v -> Just $ pevalEqvTerm (symTerm tsym) (conTerm v)-    Nothing -> Nothing--instance SymbolSetOps SymbolSet TypedSymbol where-  emptySet = SymbolSet S.empty-  isEmptySet (SymbolSet s) = S.null s-  containsSymbol s =-    S.member (someTypedSymbol s) . unSymbolSet-  insertSymbol s = SymbolSet . S.insert (someTypedSymbol s) . unSymbolSet-  intersectionSet (SymbolSet s1) (SymbolSet s2) = SymbolSet $ S.intersection s1 s2-  unionSet (SymbolSet s1) (SymbolSet s2) = SymbolSet $ S.union s1 s2-  differenceSet (SymbolSet s1) (SymbolSet s2) = SymbolSet $ S.difference s1 s2--instance SymbolSetRep (TypedSymbol t) SymbolSet TypedSymbol where-  buildSymbolSet sym = insertSymbol sym emptySet--instance-  SymbolSetRep-    ( TypedSymbol a,-      TypedSymbol b-    )-    SymbolSet-    TypedSymbol-  where-  buildSymbolSet (sym1, sym2) =-    insertSymbol sym2-      . insertSymbol sym1-      $ emptySet--instance-  SymbolSetRep-    ( TypedSymbol a,-      TypedSymbol b,-      TypedSymbol c-    )-    SymbolSet-    TypedSymbol-  where-  buildSymbolSet (sym1, sym2, sym3) =-    insertSymbol sym3-      . insertSymbol sym2-      . insertSymbol sym1-      $ emptySet--instance-  SymbolSetRep-    ( TypedSymbol a,-      TypedSymbol b,-      TypedSymbol c,-      TypedSymbol d-    )-    SymbolSet-    TypedSymbol-  where-  buildSymbolSet (sym1, sym2, sym3, sym4) =-    insertSymbol sym4-      . insertSymbol sym3-      . insertSymbol sym2-      . insertSymbol sym1-      $ emptySet--instance-  SymbolSetRep-    ( TypedSymbol a,-      TypedSymbol b,-      TypedSymbol c,-      TypedSymbol d,-      TypedSymbol e-    )-    SymbolSet-    TypedSymbol-  where-  buildSymbolSet (sym1, sym2, sym3, sym4, sym5) =-    insertSymbol sym5-      . insertSymbol sym4-      . insertSymbol sym3-      . insertSymbol sym2-      . insertSymbol sym1-      $ emptySet--instance-  SymbolSetRep-    ( TypedSymbol a,-      TypedSymbol b,-      TypedSymbol c,-      TypedSymbol d,-      TypedSymbol e,-      TypedSymbol f-    )-    SymbolSet-    TypedSymbol-  where-  buildSymbolSet (sym1, sym2, sym3, sym4, sym5, sym6) =-    insertSymbol sym6-      . insertSymbol sym5-      . insertSymbol sym4-      . insertSymbol sym3-      . insertSymbol sym2-      . insertSymbol sym1-      $ emptySet--instance-  SymbolSetRep-    ( TypedSymbol a,-      TypedSymbol b,-      TypedSymbol c,-      TypedSymbol d,-      TypedSymbol e,-      TypedSymbol f,-      TypedSymbol g-    )-    SymbolSet-    TypedSymbol-  where-  buildSymbolSet (sym1, sym2, sym3, sym4, sym5, sym6, sym7) =-    insertSymbol sym7-      . insertSymbol sym6-      . insertSymbol sym5-      . insertSymbol sym4-      . insertSymbol sym3-      . insertSymbol sym2-      . insertSymbol sym1-      $ emptySet--instance-  SymbolSetRep-    ( TypedSymbol a,-      TypedSymbol b,-      TypedSymbol c,-      TypedSymbol d,-      TypedSymbol e,-      TypedSymbol f,-      TypedSymbol g,-      TypedSymbol h-    )-    SymbolSet-    TypedSymbol-  where-  buildSymbolSet (sym1, sym2, sym3, sym4, sym5, sym6, sym7, sym8) =-    insertSymbol sym8-      . insertSymbol sym7-      . insertSymbol sym6-      . insertSymbol sym5-      . insertSymbol sym4-      . insertSymbol sym3-      . insertSymbol sym2-      . insertSymbol sym1-      $ emptySet--instance ModelOps Model SymbolSet TypedSymbol where-  emptyModel = Model M.empty-  isEmptyModel (Model m) = M.null m-  valueOf :: forall t. TypedSymbol t -> Model -> Maybe t-  valueOf sym (Model m) =-    withSymbolSupported sym $-      (unsafeFromModelValue @t)-        <$> M.lookup (someTypedSymbol sym) m-  modelContains sym (Model m) = M.member (someTypedSymbol sym) m-  exceptFor (SymbolSet s) (Model m) = Model $ S.foldl' (flip M.delete) m s-  exceptFor' s (Model m) = Model $ M.delete (someTypedSymbol s) m-  restrictTo (SymbolSet s) (Model m) =-    Model $-      S.foldl'-        ( \acc sym -> case M.lookup sym m of-            Just v -> M.insert sym v acc-            Nothing -> acc-        )-        M.empty-        s-  extendTo (SymbolSet s) (Model m) =-    Model $-      S.foldl'-        ( \acc sym@(SomeTypedSymbol _ (tsym :: TypedSymbol t)) -> case M.lookup sym acc of-            Just _ -> acc-            Nothing -> withSymbolSupported tsym $ M.insert sym (defaultValueDynamic (Proxy @t)) acc-        )-        m-        s-  insertValue sym (v :: t) (Model m) =-    withSymbolSupported sym $-      Model $-        M.insert (someTypedSymbol sym) (toModelValue v) m--evaluateSomeTerm :: Bool -> Model -> SomeTerm -> SomeTerm-evaluateSomeTerm fillDefault m@(Model ma) = gomemo-  where-    gomemo = htmemo go-    gotyped :: (SupportedPrim a) => Term a -> Term a-    gotyped a = case gomemo (SomeTerm a) of-      SomeTerm v -> unsafeCoerce v-    go c@(SomeTerm (ConTerm _ cv :: Term v)) =-      case (typeRep :: TypeRep v) of-        App (App gf _) _ ->-          case eqTypeRep gf (typeRep @(-->)) of-            Just HRefl -> case cv of-              GeneralFun sym tm ->-                if modelContains sym m -- someTypedSymbol sym1 == someTypedSymbol sym-                  then case evaluateSomeTerm fillDefault (exceptFor' sym m) (SomeTerm tm) of-                    SomeTerm tm' -> SomeTerm $ conTerm $ GeneralFun sym tm' -- stm-                  else SomeTerm $ conTerm $ GeneralFun sym (gotyped tm)-            Nothing -> c-        _ -> c-    go c@(SomeTerm ((SymTerm _ sym) :: Term a)) =-      case M.lookup (someTypedSymbol sym) ma of-        Nothing -> if fillDefault then SomeTerm $ conTerm (defaultValue @a) else c-        Just dy -> SomeTerm $ conTerm (unsafeFromModelValue @a dy)-    go (SomeTerm (UnaryTerm _ tag (arg :: Term a))) = goUnary (partialEvalUnary tag) arg-    go (SomeTerm (BinaryTerm _ tag (arg1 :: Term a1) (arg2 :: Term a2))) =-      goBinary (partialEvalBinary tag) arg1 arg2-    go (SomeTerm (TernaryTerm _ tag (arg1 :: Term a1) (arg2 :: Term a2) (arg3 :: Term a3))) = do-      goTernary (partialEvalTernary tag) arg1 arg2 arg3-    go (SomeTerm (NotTerm _ arg)) = goUnary pevalNotTerm arg-    go (SomeTerm (OrTerm _ arg1 arg2)) =-      goBinary pevalOrTerm arg1 arg2-    go (SomeTerm (AndTerm _ arg1 arg2)) =-      goBinary pevalAndTerm arg1 arg2-    go (SomeTerm (EqvTerm _ arg1 arg2)) =-      goBinary pevalEqvTerm arg1 arg2-    go (SomeTerm (ITETerm _ cond arg1 arg2)) =-      goTernary pevalITETerm cond arg1 arg2-    go (SomeTerm (AddNumTerm _ arg1 arg2)) =-      goBinary pevalAddNumTerm arg1 arg2-    go (SomeTerm (UMinusNumTerm _ arg)) = goUnary pevalUMinusNumTerm arg-    go (SomeTerm (TimesNumTerm _ arg1 arg2)) =-      goBinary pevalTimesNumTerm arg1 arg2-    go (SomeTerm (AbsNumTerm _ arg)) = goUnary pevalAbsNumTerm arg-    go (SomeTerm (SignumNumTerm _ arg)) = goUnary pevalSignumNumTerm arg-    go (SomeTerm (LTNumTerm _ arg1 arg2)) =-      goBinary pevalLtNumTerm arg1 arg2-    go (SomeTerm (LENumTerm _ arg1 arg2)) =-      goBinary pevalLeNumTerm arg1 arg2-    go (SomeTerm (AndBitsTerm _ arg1 arg2)) =-      goBinary pevalAndBitsTerm arg1 arg2-    go (SomeTerm (OrBitsTerm _ arg1 arg2)) =-      goBinary pevalOrBitsTerm arg1 arg2-    go (SomeTerm (XorBitsTerm _ arg1 arg2)) =-      goBinary pevalXorBitsTerm arg1 arg2-    go (SomeTerm (ComplementBitsTerm _ arg)) = goUnary pevalComplementBitsTerm arg-    go (SomeTerm (ShiftLeftTerm _ arg n)) = goBinary pevalShiftLeftTerm arg n-    go (SomeTerm (RotateLeftTerm _ arg n)) = goBinary pevalRotateLeftTerm arg n-    go (SomeTerm (ShiftRightTerm _ arg n)) = goBinary pevalShiftRightTerm arg n-    go (SomeTerm (RotateRightTerm _ arg n)) = goBinary pevalRotateRightTerm arg n-    go (SomeTerm (ToSignedTerm _ arg)) =-      goUnary pevalToSignedTerm arg-    go (SomeTerm (ToUnsignedTerm _ arg)) =-      goUnary pevalToUnsignedTerm arg-    go (SomeTerm (BVConcatTerm _ arg1 arg2)) =-      goBinary pevalBVConcatTerm arg1 arg2-    go (SomeTerm (BVSelectTerm _ ix w arg)) =-      goUnary (pevalBVSelectTerm ix w) arg-    go (SomeTerm (BVExtendTerm _ n signed arg)) =-      goUnary (pevalBVExtendTerm n signed) arg-    go (SomeTerm (TabularFunApplyTerm _ f arg)) =-      goBinary pevalTabularFunApplyTerm f arg-    go (SomeTerm (GeneralFunApplyTerm _ f arg)) =-      goBinary pevalGeneralFunApplyTerm f arg-    go (SomeTerm (DivIntegralTerm _ arg1 arg2)) =-      goBinary pevalDivIntegralTerm arg1 arg2-    go (SomeTerm (ModIntegralTerm _ arg1 arg2)) =-      goBinary pevalModIntegralTerm arg1 arg2-    go (SomeTerm (QuotIntegralTerm _ arg1 arg2)) =-      goBinary pevalQuotIntegralTerm arg1 arg2-    go (SomeTerm (RemIntegralTerm _ arg1 arg2)) =-      goBinary pevalRemIntegralTerm arg1 arg2-    go (SomeTerm (DivBoundedIntegralTerm _ arg1 arg2)) =-      goBinary pevalDivBoundedIntegralTerm arg1 arg2-    go (SomeTerm (ModBoundedIntegralTerm _ arg1 arg2)) =-      goBinary pevalModBoundedIntegralTerm arg1 arg2-    go (SomeTerm (QuotBoundedIntegralTerm _ arg1 arg2)) =-      goBinary pevalQuotBoundedIntegralTerm arg1 arg2-    go (SomeTerm (RemBoundedIntegralTerm _ arg1 arg2)) =-      goBinary pevalRemBoundedIntegralTerm arg1 arg2-    goUnary :: (SupportedPrim a, SupportedPrim b) => (Term a -> Term b) -> Term a -> SomeTerm-    goUnary f a = SomeTerm $ f (gotyped a)-    goBinary ::-      (SupportedPrim a, SupportedPrim b, SupportedPrim c) =>-      (Term a -> Term b -> Term c) ->-      Term a ->-      Term b ->-      SomeTerm-    goBinary f a b = SomeTerm $ f (gotyped a) (gotyped b)-    goTernary ::-      (SupportedPrim a, SupportedPrim b, SupportedPrim c, SupportedPrim d) =>-      (Term a -> Term b -> Term c -> Term d) ->-      Term a ->-      Term b ->-      Term c ->-      SomeTerm-    goTernary f a b c = SomeTerm $ f (gotyped a) (gotyped b) (gotyped c)--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---- |--- A type used for building a model by hand.------ >>> buildModel ("x" ::= (1 :: Integer), "y" ::= True) :: Model--- Model {x -> 1 :: Integer, y -> True :: Bool}-data ModelValuePair t = (TypedSymbol t) ::= t deriving (Show)--instance ModelRep (ModelValuePair t) Model where-  buildModel (sym ::= val) = insertValue sym val emptyModel--instance (ModelRep a Model, ModelRep b Model) => ModelRep (a, b) Model where-  buildModel (a, b) = buildModel a <> buildModel b--instance-  ( ModelRep a Model,-    ModelRep b Model,-    ModelRep c Model-  ) =>-  ModelRep (a, b, c) Model-  where-  buildModel (a, b, c) = buildModel a <> buildModel b <> buildModel c--instance-  ( ModelRep a Model,-    ModelRep b Model,-    ModelRep c Model,-    ModelRep d Model-  ) =>-  ModelRep (a, b, c, d) Model-  where-  buildModel (a, b, c, d) =-    buildModel a <> buildModel b <> buildModel c <> buildModel d--instance-  ( ModelRep a Model,-    ModelRep b Model,-    ModelRep c Model,-    ModelRep d Model,-    ModelRep e Model-  ) =>-  ModelRep (a, b, c, d, e) Model-  where-  buildModel (a, b, c, d, e) =-    buildModel a <> buildModel b <> buildModel c <> buildModel d <> buildModel e--instance-  ( ModelRep a Model,-    ModelRep b Model,-    ModelRep c Model,-    ModelRep d Model,-    ModelRep e Model,-    ModelRep f Model-  ) =>-  ModelRep (a, b, c, d, e, f) Model-  where-  buildModel (a, b, c, d, e, f) =-    buildModel a-      <> buildModel b-      <> buildModel c-      <> buildModel d-      <> buildModel e-      <> buildModel f--instance-  ( ModelRep a Model,-    ModelRep b Model,-    ModelRep c Model,-    ModelRep d Model,-    ModelRep e Model,-    ModelRep f Model,-    ModelRep g Model-  ) =>-  ModelRep (a, b, c, d, e, f, g) Model-  where-  buildModel (a, b, c, d, e, f, g) =-    buildModel a-      <> buildModel b-      <> buildModel c-      <> buildModel d-      <> buildModel e-      <> buildModel f-      <> buildModel g--instance-  ( ModelRep a Model,-    ModelRep b Model,-    ModelRep c Model,-    ModelRep d Model,-    ModelRep e Model,-    ModelRep f Model,-    ModelRep g Model,-    ModelRep h Model-  ) =>-  ModelRep (a, b, c, d, e, f, g, h) Model-  where-  buildModel (a, b, c, d, e, f, g, h) =-    buildModel a-      <> buildModel b-      <> buildModel c-      <> buildModel d-      <> buildModel e-      <> buildModel f-      <> buildModel g-      <> buildModel h--{--instance-  ModelRep-    ( ModelValuePair a,-      ModelValuePair b-    )-    Model-    SymbolSet-    TypedSymbol-  where-  buildModel-    ( sym1 ::= val1,-      sym2 ::= val2-      ) =-      insertValue sym2 val2-        . insertValue sym1 val1-        $ emptyModel--instance-  ModelRep-    ( ModelValuePair a,-      ModelValuePair b,-      ModelValuePair c-    )-    Model-    SymbolSet-    TypedSymbol-  where-  buildModel-    ( sym1 ::= val1,-      sym2 ::= val2,-      sym3 ::= val3-      ) =-      insertValue sym3 val3-        . insertValue sym2 val2-        . insertValue sym1 val1-        $ emptyModel--instance-  ModelRep-    ( ModelValuePair a,-      ModelValuePair b,-      ModelValuePair c,-      ModelValuePair d-    )-    Model-    SymbolSet-    TypedSymbol-  where-  buildModel-    ( sym1 ::= val1,-      sym2 ::= val2,-      sym3 ::= val3,-      sym4 ::= val4-      ) =-      insertValue sym4 val4-        . insertValue sym3 val3-        . insertValue sym2 val2-        . insertValue sym1 val1-        $ emptyModel--instance-  ModelRep-    ( ModelValuePair a,-      ModelValuePair b,-      ModelValuePair c,-      ModelValuePair d,-      ModelValuePair e-    )-    Model-    SymbolSet-    TypedSymbol-  where-  buildModel-    ( sym1 ::= val1,-      sym2 ::= val2,-      sym3 ::= val3,-      sym4 ::= val4,-      sym5 ::= val5-      ) =-      insertValue sym5 val5-        . insertValue sym4 val4-        . insertValue sym3 val3-        . insertValue sym2 val2-        . insertValue sym1 val1-        $ emptyModel--instance-  ModelRep-    ( ModelValuePair a,-      ModelValuePair b,-      ModelValuePair c,-      ModelValuePair d,-      ModelValuePair e,-      ModelValuePair f-    )-    Model-    SymbolSet-    TypedSymbol-  where-  buildModel-    ( sym1 ::= val1,-      sym2 ::= val2,-      sym3 ::= val3,-      sym4 ::= val4,-      sym5 ::= val5,-      sym6 ::= val6-      ) =-      insertValue sym6 val6-        . insertValue sym5 val5-        . insertValue sym4 val4-        . insertValue sym3 val3-        . insertValue sym2 val2-        . insertValue sym1 val1-        $ emptyModel--instance-  ModelRep-    ( ModelValuePair a,-      ModelValuePair b,-      ModelValuePair c,-      ModelValuePair d,-      ModelValuePair e,-      ModelValuePair f,-      ModelValuePair g-    )-    Model-    SymbolSet-    TypedSymbol-  where-  buildModel-    ( sym1 ::= val1,-      sym2 ::= val2,-      sym3 ::= val3,-      sym4 ::= val4,-      sym5 ::= val5,-      sym6 ::= val6,-      sym7 ::= val7-      ) =-      insertValue sym7 val7-        . insertValue sym6 val6-        . insertValue sym5 val5-        . insertValue sym4 val4-        . insertValue sym3 val3-        . insertValue sym2 val2-        . insertValue sym1 val1-        $ emptyModel--instance-  ModelRep-    ( ModelValuePair a,-      ModelValuePair b,-      ModelValuePair c,-      ModelValuePair d,-      ModelValuePair e,-      ModelValuePair f,-      ModelValuePair g,-      ModelValuePair h-    )-    Model-    SymbolSet-    TypedSymbol-  where-  buildModel-    ( sym1 ::= val1,-      sym2 ::= val2,-      sym3 ::= val3,-      sym4 ::= val4,-      sym5 ::= val5,-      sym6 ::= val6,-      sym7 ::= val7,-      sym8 ::= val8-      ) =-      insertValue sym8 val8-        . insertValue sym7 val7-        . insertValue sym6 val6-        . insertValue sym5 val5-        . insertValue sym4 val4-        . insertValue sym3 val3-        . insertValue sym2 val2-        . insertValue sym1 val1-        $ emptyModel---}
− src/Grisette/IR/SymPrim/Data/Prim/ModelValue.hs 
@@ -1,52 +0,0 @@-{-# LANGUAGE ExplicitNamespaces #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}---- |--- Module      :   Grisette.IR.SymPrim.Data.Prim.ModelValue--- 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.IR.SymPrim.Data.Prim.ModelValue-  ( ModelValue (..),-    toModelValue,-    unsafeFromModelValue,-  )-where--import Data.Hashable (Hashable (hashWithSalt))-import Type.Reflection-  ( TypeRep,-    Typeable,-    eqTypeRep,-    typeRep,-    type (:~~:) (HRefl),-  )--data ModelValue where-  ModelValue :: forall v. (Show v, Eq v, Hashable v) => TypeRep v -> v -> ModelValue--instance Show ModelValue where-  show (ModelValue t v) = show v ++ " :: " ++ show t--instance Eq ModelValue where-  (ModelValue t1 v1) == (ModelValue t2 v2) =-    case eqTypeRep t1 t2 of-      Just HRefl -> v1 == v2-      _ -> False--instance Hashable ModelValue where-  s `hashWithSalt` (ModelValue t v) = s `hashWithSalt` t `hashWithSalt` v--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--toModelValue :: forall a. (Show a, Eq a, Hashable a, Typeable a) => a -> ModelValue-toModelValue = ModelValue (typeRep @a)
− src/Grisette/IR/SymPrim/Data/Prim/PartialEval/BV.hs 
@@ -1,237 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE QuantifiedConstraints #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}---- |--- Module      :   Grisette.IR.SymPrim.Data.Prim.PartialEval.BV--- 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.IR.SymPrim.Data.Prim.PartialEval.BV-  ( pevalToSignedTerm,-    pevalToUnsignedTerm,-    pevalBVConcatTerm,-    pevalBVSelectTerm,-    pevalBVExtendTerm,-    pevalBVZeroExtendTerm,-    pevalBVSignExtendTerm,-  )-where--import Data.Typeable (Typeable)-import GHC.TypeNats (KnownNat, type (+), type (<=))-import Grisette.Core.Data.Class.BitVector-  ( SizedBV (sizedBVConcat, sizedBVSelect, sizedBVSext, sizedBVZext),-  )-import Grisette.Core.Data.Class.SignConversion (SignConversion (toSigned, toUnsigned))-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors-  ( bvconcatTerm,-    bvextendTerm,-    bvselectTerm,-    conTerm,-    toSignedTerm,-    toUnsignedTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term-  ( SupportedPrim,-    Term (ConTerm, ToSignedTerm, ToUnsignedTerm),-  )-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermUtils-  ( castTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.PartialEval.Unfold-  ( binaryUnfoldOnce,-    unaryUnfoldOnce,-  )---- ToSigned-pevalToSignedTerm ::-  ( SupportedPrim u,-    SupportedPrim s,-    SignConversion u s-  ) =>-  Term u ->-  Term s-pevalToSignedTerm = unaryUnfoldOnce doPevalToSignedTerm toSignedTerm--doPevalToSignedTerm ::-  ( SupportedPrim u,-    SupportedPrim s,-    SignConversion u s-  ) =>-  Term u ->-  Maybe (Term s)-doPevalToSignedTerm (ConTerm _ b) = Just $ conTerm $ toSigned b-doPevalToSignedTerm (ToUnsignedTerm _ b) = Just b >>= castTerm-doPevalToSignedTerm _ = Nothing---- ToUnsigned-pevalToUnsignedTerm ::-  ( SupportedPrim u,-    SupportedPrim s,-    SignConversion u s-  ) =>-  Term s ->-  Term u-pevalToUnsignedTerm = unaryUnfoldOnce doPevalToUnsignedTerm toUnsignedTerm--doPevalToUnsignedTerm ::-  ( SupportedPrim u,-    SupportedPrim s,-    SignConversion u s-  ) =>-  Term s ->-  Maybe (Term u)-doPevalToUnsignedTerm (ConTerm _ b) = Just $ conTerm $ toUnsigned b-doPevalToUnsignedTerm (ToSignedTerm _ b) = Just b >>= castTerm-doPevalToUnsignedTerm _ = Nothing---- select-pevalBVSelectTerm ::-  forall bv n ix w p q.-  ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n),-    Typeable bv,-    KnownNat n,-    KnownNat ix,-    KnownNat w,-    1 <= n,-    1 <= w,-    ix + w <= n,-    SizedBV bv-  ) =>-  p ix ->-  q w ->-  Term (bv n) ->-  Term (bv w)-pevalBVSelectTerm ix w = unaryUnfoldOnce (doPevalBVSelectTerm ix w) (bvselectTerm ix w)--doPevalBVSelectTerm ::-  forall bv n ix w p q.-  ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n),-    Typeable bv,-    KnownNat n,-    KnownNat ix,-    KnownNat w,-    1 <= n,-    1 <= w,-    ix + w <= n,-    SizedBV bv-  ) =>-  p ix ->-  q w ->-  Term (bv n) ->-  Maybe (Term (bv w))-doPevalBVSelectTerm ix w (ConTerm _ b) = Just $ conTerm $ sizedBVSelect ix w b-doPevalBVSelectTerm _ _ _ = Nothing---- ext-pevalBVZeroExtendTerm ::-  forall proxy l r bv.-  ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n),-    Typeable bv,-    KnownNat l,-    KnownNat r,-    1 <= l,-    1 <= r,-    l <= r,-    SizedBV bv-  ) =>-  proxy r ->-  Term (bv l) ->-  Term (bv r)-pevalBVZeroExtendTerm = pevalBVExtendTerm False--pevalBVSignExtendTerm ::-  forall proxy l r bv.-  ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n),-    Typeable bv,-    KnownNat l,-    KnownNat r,-    1 <= l,-    1 <= r,-    l <= r,-    SizedBV bv-  ) =>-  proxy r ->-  Term (bv l) ->-  Term (bv r)-pevalBVSignExtendTerm = pevalBVExtendTerm True--pevalBVExtendTerm ::-  forall proxy l r bv.-  ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n),-    Typeable bv,-    KnownNat l,-    KnownNat r,-    1 <= l,-    1 <= r,-    l <= r,-    SizedBV bv-  ) =>-  Bool ->-  proxy r ->-  Term (bv l) ->-  Term (bv r)-pevalBVExtendTerm signed p = unaryUnfoldOnce (doPevalBVExtendTerm signed p) (bvextendTerm signed p)--doPevalBVExtendTerm ::-  forall proxy l r bv.-  ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n),-    Typeable bv,-    KnownNat l,-    KnownNat r,-    1 <= l,-    1 <= r,-    l <= r,-    SizedBV bv-  ) =>-  Bool ->-  proxy r ->-  Term (bv l) ->-  Maybe (Term (bv r))-doPevalBVExtendTerm signed p (ConTerm _ b) = Just $ conTerm $ if signed then sizedBVSext p b else sizedBVZext p b-doPevalBVExtendTerm _ _ _ = Nothing--pevalBVConcatTerm ::-  ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n),-    Typeable bv,-    KnownNat a,-    KnownNat b,-    KnownNat (a + b),-    1 <= a,-    1 <= b,-    1 <= a + b,-    SizedBV bv-  ) =>-  Term (bv a) ->-  Term (bv b) ->-  Term (bv (a + b))-pevalBVConcatTerm = binaryUnfoldOnce doPevalBVConcatTerm bvconcatTerm--doPevalBVConcatTerm ::-  ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n),-    Typeable bv,-    KnownNat a,-    KnownNat b,-    KnownNat (a + b),-    1 <= a,-    1 <= b,-    1 <= (a + b),-    SizedBV bv-  ) =>-  Term (bv a) ->-  Term (bv b) ->-  Maybe (Term (bv (a + b)))-doPevalBVConcatTerm (ConTerm _ v) (ConTerm _ v') = Just $ conTerm $ sizedBVConcat v v'-doPevalBVConcatTerm _ _ = Nothing
− src/Grisette/IR/SymPrim/Data/Prim/PartialEval/Bits.hs 
@@ -1,209 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ViewPatterns #-}---- |--- Module      :   Grisette.IR.SymPrim.Data.Prim.PartialEval.Bits--- 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.IR.SymPrim.Data.Prim.PartialEval.Bits-  ( pattern BitsConTerm,-    pevalAndBitsTerm,-    pevalOrBitsTerm,-    pevalXorBitsTerm,-    pevalComplementBitsTerm,-    pevalShiftLeftTerm,-    pevalShiftRightTerm,-    pevalRotateLeftTerm,-    pevalRotateRightTerm,-  )-where--import Data.Bits-  ( Bits-      ( complement,-        isSigned,-        rotateR,-        shiftR,-        xor,-        zeroBits,-        (.&.),-        (.|.)-      ),-    FiniteBits (finiteBitSize),-  )-import Data.Typeable (Typeable, cast)-import Grisette.Core.Data.Class.SymRotate (SymRotate (symRotate))-import Grisette.Core.Data.Class.SymShift (SymShift (symShift))-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors-  ( andBitsTerm,-    complementBitsTerm,-    conTerm,-    orBitsTerm,-    rotateLeftTerm,-    rotateRightTerm,-    shiftLeftTerm,-    shiftRightTerm,-    xorBitsTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term-  ( SupportedPrim,-    Term-      ( ComplementBitsTerm,-        ConTerm-      ),-  )-import Grisette.IR.SymPrim.Data.Prim.PartialEval.Unfold-  ( binaryUnfoldOnce,-    unaryUnfoldOnce,-  )--bitsConTermView :: (Bits b, Typeable b) => Term a -> Maybe b-bitsConTermView (ConTerm _ b) = cast b-bitsConTermView _ = Nothing--pattern BitsConTerm :: forall b a. (Bits b, Typeable b) => b -> Term a-pattern BitsConTerm b <- (bitsConTermView -> Just b)---- bitand-pevalAndBitsTerm :: forall a. (Bits a, SupportedPrim a) => Term a -> Term a -> Term a-pevalAndBitsTerm = binaryUnfoldOnce doPevalAndBitsTerm andBitsTerm--doPevalAndBitsTerm :: forall a. (Bits a, SupportedPrim a) => Term a -> Term a -> Maybe (Term a)-doPevalAndBitsTerm (ConTerm _ a) (ConTerm _ b) = Just $ conTerm (a .&. b)-doPevalAndBitsTerm (ConTerm _ a) b-  | a == zeroBits = Just $ conTerm zeroBits-  | a == complement zeroBits = Just b-doPevalAndBitsTerm a (ConTerm _ b)-  | b == zeroBits = Just $ conTerm zeroBits-  | b == complement zeroBits = Just a-doPevalAndBitsTerm a b | a == b = Just a-doPevalAndBitsTerm _ _ = Nothing---- bitor-pevalOrBitsTerm :: forall a. (Bits a, SupportedPrim a) => Term a -> Term a -> Term a-pevalOrBitsTerm = binaryUnfoldOnce doPevalOrBitsTerm orBitsTerm--doPevalOrBitsTerm :: forall a. (Bits a, SupportedPrim a) => Term a -> Term a -> Maybe (Term a)-doPevalOrBitsTerm (ConTerm _ a) (ConTerm _ b) = Just $ conTerm (a .|. b)-doPevalOrBitsTerm (ConTerm _ a) b-  | a == zeroBits = Just b-  | a == complement zeroBits = Just $ conTerm $ complement zeroBits-doPevalOrBitsTerm a (ConTerm _ b)-  | b == zeroBits = Just a-  | b == complement zeroBits = Just $ conTerm $ complement zeroBits-doPevalOrBitsTerm a b | a == b = Just a-doPevalOrBitsTerm _ _ = Nothing---- bitxor-pevalXorBitsTerm :: forall a. (Bits a, SupportedPrim a) => Term a -> Term a -> Term a-pevalXorBitsTerm = binaryUnfoldOnce doPevalXorBitsTerm xorBitsTerm--doPevalXorBitsTerm :: forall a. (Bits a, SupportedPrim a) => Term a -> Term a -> Maybe (Term a)-doPevalXorBitsTerm (ConTerm _ a) (ConTerm _ b) = Just $ conTerm (a `xor` b)-doPevalXorBitsTerm (ConTerm _ a) b-  | a == zeroBits = Just b-  | a == complement zeroBits = Just $ pevalComplementBitsTerm b-doPevalXorBitsTerm a (ConTerm _ b)-  | b == zeroBits = Just a-  | b == complement zeroBits = Just $ pevalComplementBitsTerm a-doPevalXorBitsTerm a b | a == b = Just $ conTerm zeroBits-doPevalXorBitsTerm (ComplementBitsTerm _ i) (ComplementBitsTerm _ j) = Just $ pevalXorBitsTerm i j-doPevalXorBitsTerm (ComplementBitsTerm _ i) j = Just $ pevalComplementBitsTerm $ pevalXorBitsTerm i j-doPevalXorBitsTerm i (ComplementBitsTerm _ j) = Just $ pevalComplementBitsTerm $ pevalXorBitsTerm i j-doPevalXorBitsTerm _ _ = Nothing---- complement-pevalComplementBitsTerm :: forall a. (Bits a, SupportedPrim a) => Term a -> Term a-pevalComplementBitsTerm = unaryUnfoldOnce doPevalComplementBitsTerm complementBitsTerm--doPevalComplementBitsTerm :: forall a. (Bits a, SupportedPrim a) => Term a -> Maybe (Term a)-doPevalComplementBitsTerm (ConTerm _ a) = Just $ conTerm $ complement a-doPevalComplementBitsTerm (ComplementBitsTerm _ a) = Just a-doPevalComplementBitsTerm _ = Nothing---- shift-pevalShiftLeftTerm :: forall a. (Integral a, SymShift a, FiniteBits a, SupportedPrim a) => Term a -> Term a -> Term a-pevalShiftLeftTerm t n = unaryUnfoldOnce (`doPevalShiftLeftTerm` n) (`shiftLeftTerm` n) t--doPevalShiftLeftTerm :: forall a. (Integral a, SymShift a, FiniteBits a, SupportedPrim a) => Term a -> Term a -> Maybe (Term a)-doPevalShiftLeftTerm (ConTerm _ a) (ConTerm _ n)-  | n >= 0 =-      if (fromIntegral n :: Integer) >= fromIntegral (finiteBitSize n)-        then Just $ conTerm zeroBits-        else Just $ conTerm $ symShift a n-doPevalShiftLeftTerm x (ConTerm _ 0) = Just x--- TODO: Need to handle the overflow case.--- doPevalShiftLeftTerm (ShiftLeftTerm _ x (ConTerm _ n)) (ConTerm _ n1)---   | n >= 0 && n1 >= 0 = Just $ pevalShiftLeftTerm x (conTerm $ n + n1)-doPevalShiftLeftTerm _ (ConTerm _ n)-  | n >= 0 && (fromIntegral n :: Integer) >= fromIntegral (finiteBitSize n) =-      Just $ conTerm zeroBits-doPevalShiftLeftTerm _ _ = Nothing--pevalShiftRightTerm :: forall a. (Integral a, SymShift a, FiniteBits a, SupportedPrim a) => Term a -> Term a -> Term a-pevalShiftRightTerm t n = unaryUnfoldOnce (`doPevalShiftRightTerm` n) (`shiftRightTerm` n) t--doPevalShiftRightTerm :: forall a. (Integral a, SymShift a, FiniteBits a, SupportedPrim a) => Term a -> Term a -> Maybe (Term a)-doPevalShiftRightTerm (ConTerm _ a) (ConTerm _ n)-  | n >= 0 && not (isSigned a) =-      if (fromIntegral n :: Integer) >= fromIntegral (finiteBitSize n)-        then Just $ conTerm zeroBits-        else Just $ conTerm $ shiftR a (fromIntegral n)-doPevalShiftRightTerm (ConTerm _ a) (ConTerm _ n)-  | n >= 0 = Just $ conTerm $ symShift a (-n) -- if n >= 0 then -n must be in the range-doPevalShiftRightTerm x (ConTerm _ 0) = Just x--- doPevalShiftRightTerm (ShiftRightTerm _ x (ConTerm _ n)) (ConTerm _ n1)---   | n >= 0 && n1 >= 0 = Just $ pevalShiftRightTerm x (conTerm $ n + n1)-doPevalShiftRightTerm _ (ConTerm _ n)-  | not (isSigned n)-      && (fromIntegral n :: Integer) >= fromIntegral (finiteBitSize n) =-      Just $ conTerm zeroBits-doPevalShiftRightTerm _ _ = Nothing--pevalRotateLeftTerm :: forall a. (Integral a, SymRotate a, FiniteBits a, SupportedPrim a) => Term a -> Term a -> Term a-pevalRotateLeftTerm t n = unaryUnfoldOnce (`doPevalRotateLeftTerm` n) (`rotateLeftTerm` n) t--doPevalRotateLeftTerm :: forall a. (Integral a, SymRotate a, FiniteBits a, SupportedPrim a) => Term a -> Term a -> Maybe (Term a)-doPevalRotateLeftTerm (ConTerm _ a) (ConTerm _ n)-  | n >= 0 = Just $ conTerm $ symRotate a n -- Just $ conTerm $ rotateL a (fromIntegral n)-doPevalRotateLeftTerm x (ConTerm _ 0) = Just x--- doPevalRotateLeftTerm (RotateLeftTerm _ x (ConTerm _ n)) (ConTerm _ n1)---   | n >= 0 && n1 >= 0 = Just $ pevalRotateLeftTerm x (conTerm $ n + n1)-doPevalRotateLeftTerm x (ConTerm _ n)-  | n >= 0 && (fromIntegral n :: Integer) >= fromIntegral bs =-      Just $ pevalRotateLeftTerm x (conTerm $ n `mod` fromIntegral bs)-  where-    bs = finiteBitSize n-doPevalRotateLeftTerm _ _ = Nothing--pevalRotateRightTerm :: forall a. (Integral a, SymRotate a, FiniteBits a, SupportedPrim a) => Term a -> Term a -> Term a-pevalRotateRightTerm t n = unaryUnfoldOnce (`doPevalRotateRightTerm` n) (`rotateRightTerm` n) t--doPevalRotateRightTerm :: forall a. (Integral a, SymRotate a, FiniteBits a, SupportedPrim a) => Term a -> Term a -> Maybe (Term a)-doPevalRotateRightTerm (ConTerm _ a) (ConTerm _ n)-  | n >= 0 =-      Just . conTerm $-        rotateR-          a-          ( fromIntegral $-              (fromIntegral n :: Integer)-                `mod` fromIntegral (finiteBitSize n)-          )-doPevalRotateRightTerm x (ConTerm _ 0) = Just x--- doPevalRotateRightTerm (RotateRightTerm _ x (ConTerm _ n)) (ConTerm _ n1)---   | n >= 0 && n1 >= 0 = Just $ pevalRotateRightTerm x (conTerm $ n + n1)-doPevalRotateRightTerm x (ConTerm _ n)-  | n >= 0 && (fromIntegral n :: Integer) >= fromIntegral bs =-      Just $ pevalRotateRightTerm x (conTerm $ n `mod` fromIntegral bs)-  where-    bs = finiteBitSize n-doPevalRotateRightTerm _ _ = Nothing
− src/Grisette/IR/SymPrim/Data/Prim/PartialEval/Bool.hs 
@@ -1,453 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE ExplicitNamespaces #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ViewPatterns #-}---- |--- Module      :   Grisette.IR.SymPrim.Data.Prim.PartialEval.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.IR.SymPrim.Data.Prim.PartialEval.Bool-  ( trueTerm,-    falseTerm,-    pattern BoolConTerm,-    pattern TrueTerm,-    pattern FalseTerm,-    pattern BoolTerm,-    pevalNotTerm,-    pevalEqvTerm,-    pevalNotEqvTerm,-    pevalOrTerm,-    pevalAndTerm,-    pevalITETerm,-    pevalImplyTerm,-    pevalXorTerm,-  )-where--import Control.Monad (msum)-import Data.Maybe (fromMaybe)-import Data.Typeable (cast, eqT, type (:~:) (Refl))-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors-  ( andTerm,-    conTerm,-    eqvTerm,-    iteTerm,-    notTerm,-    orTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term-  ( SupportedPrim,-    Term-      ( AddNumTerm,-        AndTerm,-        ConTerm,-        EqvTerm,-        ITETerm,-        NotTerm,-        OrTerm-      ),-  )-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermUtils-  ( castTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.Utils (pattern Dyn)-import Unsafe.Coerce (unsafeCoerce)--trueTerm :: Term Bool-trueTerm = conTerm True-{-# INLINE trueTerm #-}--falseTerm :: Term Bool-falseTerm = conTerm False-{-# INLINE falseTerm #-}--boolConTermView :: forall a. Term a -> Maybe Bool-boolConTermView (ConTerm _ b) = cast b-boolConTermView _ = Nothing-{-# INLINE boolConTermView #-}--pattern BoolConTerm :: Bool -> Term a-pattern BoolConTerm b <- (boolConTermView -> Just b)--pattern TrueTerm :: Term a-pattern TrueTerm <- BoolConTerm True--pattern FalseTerm :: Term a-pattern FalseTerm <- BoolConTerm False--pattern BoolTerm :: Term Bool -> Term a-pattern BoolTerm b <- (castTerm -> Just b)---- Not-pevalNotTerm :: Term Bool -> Term Bool-pevalNotTerm (NotTerm _ tm) = tm-pevalNotTerm (ConTerm _ a) = if a then falseTerm else trueTerm-pevalNotTerm (OrTerm _ (NotTerm _ n1) n2) = pevalAndTerm n1 (pevalNotTerm n2)-pevalNotTerm (OrTerm _ n1 (NotTerm _ n2)) = pevalAndTerm (pevalNotTerm n1) n2-pevalNotTerm (AndTerm _ (NotTerm _ n1) n2) = pevalOrTerm n1 (pevalNotTerm n2)-pevalNotTerm (AndTerm _ n1 (NotTerm _ n2)) = pevalOrTerm (pevalNotTerm n1) n2-pevalNotTerm tm = notTerm tm-{-# INLINEABLE pevalNotTerm #-}---- Eqv-pevalEqvTerm :: forall a. (SupportedPrim a) => Term a -> Term a -> Term Bool-pevalEqvTerm l@ConTerm {} r@ConTerm {} = conTerm $ l == r-pevalEqvTerm l@ConTerm {} r = pevalEqvTerm r l-pevalEqvTerm l (BoolConTerm rv) = if rv then unsafeCoerce l else pevalNotTerm $ unsafeCoerce l-pevalEqvTerm (NotTerm _ lv) r-  | lv == unsafeCoerce r = falseTerm-pevalEqvTerm l (NotTerm _ rv)-  | unsafeCoerce l == rv = falseTerm-{--pevalBinary _ (ConTerm l) (ConTerm r) =-  if l == r then trueTerm else falseTerm-  -}-pevalEqvTerm-  ( AddNumTerm-      _-      (ConTerm _ c :: Term a)-      (Dyn (v :: Term a))-    )-  (Dyn (ConTerm _ c2 :: Term a)) =-    pevalEqvTerm v (conTerm $ c2 - c)-pevalEqvTerm-  (Dyn (ConTerm _ c2 :: Term a))-  ( AddNumTerm-      _-      (Dyn (ConTerm _ c :: Term a))-      (Dyn (v :: Term a))-    ) =-    pevalEqvTerm v (conTerm $ c2 - c)-pevalEqvTerm l (ITETerm _ c t f)-  | l == t = pevalOrTerm c (pevalEqvTerm l f)-  | l == f = pevalOrTerm (pevalNotTerm c) (pevalEqvTerm l t)-pevalEqvTerm (ITETerm _ c t f) r-  | t == r = pevalOrTerm c (pevalEqvTerm f r)-  | f == r = pevalOrTerm (pevalNotTerm c) (pevalEqvTerm t r)-pevalEqvTerm l r-  | l == r = trueTerm-  | otherwise = eqvTerm l r-{-# INLINEABLE pevalEqvTerm #-}--pevalNotEqvTerm :: (SupportedPrim a) => Term a -> Term a -> Term Bool-pevalNotEqvTerm l r = pevalNotTerm $ pevalEqvTerm l r-{-# INLINE pevalNotEqvTerm #-}--pevalImpliesTerm :: Term Bool -> Term Bool -> Bool-pevalImpliesTerm (ConTerm _ False) _ = True-pevalImpliesTerm _ (ConTerm _ True) = True-pevalImpliesTerm-  (EqvTerm _ (e1 :: Term a) (ec1@(ConTerm _ _) :: Term b))-  (NotTerm _ (EqvTerm _ (Dyn (e2 :: Term a)) (Dyn (ec2@(ConTerm _ _) :: Term b))))-    | e1 == e2 && ec1 /= ec2 = True-pevalImpliesTerm a b-  | a == b = True-  | otherwise = False-{-# INLINE pevalImpliesTerm #-}--orEqFirst :: Term Bool -> Term Bool -> Bool-orEqFirst _ (ConTerm _ False) = True-orEqFirst-  (NotTerm _ (EqvTerm _ (e1 :: Term a) (ec1@(ConTerm _ _) :: Term b)))-  (EqvTerm _ (Dyn (e2 :: Term a)) (Dyn (ec2@(ConTerm _ _) :: Term b)))-    | e1 == e2 && ec1 /= ec2 = True-orEqFirst x y-  | x == y = True-  | otherwise = False-{-# INLINE orEqFirst #-}--orEqTrue :: Term Bool -> Term Bool -> Bool-orEqTrue (ConTerm _ True) _ = True-orEqTrue _ (ConTerm _ True) = True--- orEqTrue (NotTerm _ e1) (NotTerm _ e2) = andEqFalse e1 e2-orEqTrue-  (NotTerm _ (EqvTerm _ (e1 :: Term a) (ec1@(ConTerm _ _) :: Term b)))-  (NotTerm _ (EqvTerm _ (Dyn (e2 :: Term a)) (Dyn (ec2@(ConTerm _ _) :: Term b))))-    | e1 == e2 && ec1 /= ec2 = True-orEqTrue (NotTerm _ l) r | l == r = True-orEqTrue l (NotTerm _ r) | l == r = True-orEqTrue _ _ = False-{-# INLINE orEqTrue #-}--andEqFirst :: Term Bool -> Term Bool -> Bool-andEqFirst _ (ConTerm _ True) = True--- andEqFirst x (NotTerm _ y) = andEqFalse x y-andEqFirst-  (EqvTerm _ (e1 :: Term a) (ec1@(ConTerm _ _) :: Term b))-  (NotTerm _ (EqvTerm _ (Dyn (e2 :: Term a)) (Dyn (ec2@(ConTerm _ _) :: Term b))))-    | e1 == e2 && ec1 /= ec2 = True-andEqFirst x y-  | x == y = True-  | otherwise = False-{-# INLINE andEqFirst #-}--andEqFalse :: Term Bool -> Term Bool -> Bool-andEqFalse (ConTerm _ False) _ = True-andEqFalse _ (ConTerm _ False) = True--- andEqFalse (NotTerm _ e1) (NotTerm _ e2) = orEqTrue e1 e2-andEqFalse-  (EqvTerm _ (e1 :: Term a) (ec1@(ConTerm _ _) :: Term b))-  (EqvTerm _ (Dyn (e2 :: Term a)) (Dyn (ec2@(ConTerm _ _) :: Term b)))-    | e1 == e2 && ec1 /= ec2 = True-andEqFalse (NotTerm _ x) y | x == y = True-andEqFalse x (NotTerm _ y) | x == y = True-andEqFalse _ _ = False-{-# INLINE andEqFalse #-}---- Or-pevalOrTerm :: Term Bool -> Term Bool -> Term Bool-pevalOrTerm l r-  | orEqTrue l r = trueTerm-  | orEqFirst l r = l-  | orEqFirst r l = r-pevalOrTerm l r@(OrTerm _ r1 r2)-  | orEqTrue l r1 = trueTerm-  | orEqTrue l r2 = trueTerm-  | orEqFirst r1 l = r-  | orEqFirst r2 l = r-  | orEqFirst l r1 = pevalOrTerm l r2-  | orEqFirst l r2 = pevalOrTerm l r1-pevalOrTerm l@(OrTerm _ l1 l2) r-  | orEqTrue l1 r = trueTerm-  | orEqTrue l2 r = trueTerm-  | orEqFirst l1 r = l-  | orEqFirst l2 r = l-  | orEqFirst r l1 = pevalOrTerm l2 r-  | orEqFirst r l2 = pevalOrTerm l1 r-pevalOrTerm l (AndTerm _ r1 r2)-  | orEqFirst l r1 = l-  | orEqFirst l r2 = l-  | orEqTrue l r1 = pevalOrTerm l r2-  | orEqTrue l r2 = pevalOrTerm l r1-pevalOrTerm (AndTerm _ l1 l2) r-  | orEqFirst r l1 = r-  | orEqFirst r l2 = r-  | orEqTrue l1 r = pevalOrTerm l2 r-  | orEqTrue l2 r = pevalOrTerm l1 r-pevalOrTerm (NotTerm _ nl) (NotTerm _ nr) = pevalNotTerm $ pevalAndTerm nl nr-pevalOrTerm l r = orTerm l r-{-# INLINEABLE pevalOrTerm #-}--pevalAndTerm :: Term Bool -> Term Bool -> Term Bool-pevalAndTerm l r-  | andEqFalse l r = falseTerm-  | andEqFirst l r = l-  | andEqFirst r l = r-pevalAndTerm l r@(AndTerm _ r1 r2)-  | andEqFalse l r1 = falseTerm-  | andEqFalse l r2 = falseTerm-  | andEqFirst r1 l = r-  | andEqFirst r2 l = r-  | andEqFirst l r1 = pevalAndTerm l r2-  | andEqFirst l r2 = pevalAndTerm l r1-pevalAndTerm l@(AndTerm _ l1 l2) r-  | andEqFalse l1 r = falseTerm-  | andEqFalse l2 r = falseTerm-  | andEqFirst l1 r = l-  | andEqFirst l2 r = l-  | andEqFirst r l1 = pevalAndTerm l2 r-  | andEqFirst r l2 = pevalAndTerm l1 r-pevalAndTerm l (OrTerm _ r1 r2)-  | andEqFirst l r1 = l-  | andEqFirst l r2 = l-  | andEqFalse l r1 = pevalAndTerm l r2-  | andEqFalse l r2 = pevalAndTerm l r1-pevalAndTerm (OrTerm _ l1 l2) r-  | andEqFirst r l1 = r-  | andEqFirst r l2 = r-  | andEqFalse l1 r = pevalAndTerm l2 r-  | andEqFalse l2 r = pevalAndTerm l1 r-pevalAndTerm (NotTerm _ nl) (NotTerm _ nr) = pevalNotTerm $ pevalOrTerm nl nr-pevalAndTerm l r = andTerm l r-{-# INLINEABLE pevalAndTerm #-}--pevalITEBoolLeftNot :: Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool)-pevalITEBoolLeftNot cond nIfTrue ifFalse-  | cond == nIfTrue = Just $ pevalAndTerm (pevalNotTerm cond) ifFalse -- need test-  | otherwise = case nIfTrue of-      AndTerm _ nt1 nt2 -> ra-        where-          ra-            | pevalImpliesTerm cond nt1 = Just $ pevalITETerm cond (pevalNotTerm nt2) ifFalse-            | pevalImpliesTerm cond nt2 = Just $ pevalITETerm cond (pevalNotTerm nt1) ifFalse-            | pevalImpliesTerm cond (pevalNotTerm nt1) || pevalImpliesTerm cond (pevalNotTerm nt2) =-                Just $ pevalOrTerm cond ifFalse-            | otherwise = Nothing-      OrTerm _ nt1 nt2 -> ra-        where-          ra-            | pevalImpliesTerm cond nt1 || pevalImpliesTerm cond nt2 = Just $ pevalAndTerm (pevalNotTerm cond) ifFalse-            | pevalImpliesTerm cond (pevalNotTerm nt1) = Just $ pevalITETerm cond (pevalNotTerm nt2) ifFalse-            | pevalImpliesTerm cond (pevalNotTerm nt2) = Just $ pevalITETerm cond (pevalNotTerm nt1) ifFalse-            | otherwise = Nothing-      _ -> Nothing--pevalITEBoolBothNot :: Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool)-pevalITEBoolBothNot cond nIfTrue nIfFalse = Just $ pevalNotTerm $ pevalITETerm cond nIfTrue nIfFalse--pevalITEBoolRightNot :: Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool)-pevalITEBoolRightNot cond ifTrue nIfFalse-  | cond == nIfFalse = Just $ pevalOrTerm (pevalNotTerm cond) ifTrue -- need test-  | otherwise = Nothing -- need work--pevalInferImplies :: Term Bool -> Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool)-pevalInferImplies cond (NotTerm _ nt1) trueRes falseRes-  | cond == nt1 = Just falseRes-  | otherwise = case (cond, nt1) of-      ( EqvTerm _ (e1 :: Term a) (ec1@(ConTerm _ _) :: Term b),-        EqvTerm _ (Dyn (e2 :: Term a)) (Dyn (ec2@(ConTerm _ _) :: Term b))-        )-          | e1 == e2 && ec1 /= ec2 -> Just trueRes-      _ -> Nothing-pevalInferImplies-  (EqvTerm _ (e1 :: Term a) (ec1@(ConTerm _ _) :: Term b))-  (EqvTerm _ (Dyn (e2 :: Term a)) (Dyn (ec2@(ConTerm _ _) :: Term b)))-  _-  falseRes-    | e1 == e2 && ec1 /= ec2 = Just falseRes-pevalInferImplies _ _ _ _ = Nothing--pevalITEBoolLeftAnd :: Term Bool -> Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool)-pevalITEBoolLeftAnd cond t1 t2 ifFalse-  | t1 == ifFalse = Just $ pevalAndTerm t1 $ pevalImplyTerm cond t2-  | t2 == ifFalse = Just $ pevalAndTerm t2 $ pevalImplyTerm cond t1-  | cond == t1 = Just $ pevalITETerm cond t2 ifFalse-  | cond == t2 = Just $ pevalITETerm cond t1 ifFalse-  | otherwise =-      msum-        [ pevalInferImplies cond t1 (pevalITETerm cond t2 ifFalse) (pevalAndTerm (pevalNotTerm cond) ifFalse),-          pevalInferImplies cond t2 (pevalITETerm cond t1 ifFalse) (pevalAndTerm (pevalNotTerm cond) ifFalse)-        ]--pevalITEBoolBothAnd :: Term Bool -> Term Bool -> Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool)-pevalITEBoolBothAnd cond t1 t2 f1 f2-  | t1 == f1 = Just $ pevalAndTerm t1 $ pevalITETerm cond t2 f2-  | t1 == f2 = Just $ pevalAndTerm t1 $ pevalITETerm cond t2 f1-  | t2 == f1 = Just $ pevalAndTerm t2 $ pevalITETerm cond t1 f2-  | t2 == f2 = Just $ pevalAndTerm t2 $ pevalITETerm cond t1 f1-  | otherwise = Nothing--pevalITEBoolRightAnd :: Term Bool -> Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool)-pevalITEBoolRightAnd cond ifTrue f1 f2-  | f1 == ifTrue = Just $ pevalAndTerm f1 $ pevalOrTerm cond f2-  | f2 == ifTrue = Just $ pevalAndTerm f2 $ pevalOrTerm cond f1-  | otherwise = Nothing--pevalITEBoolLeftOr :: Term Bool -> Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool)-pevalITEBoolLeftOr cond t1 t2 ifFalse-  | t1 == ifFalse = Just $ pevalOrTerm t1 $ pevalAndTerm cond t2-  | t2 == ifFalse = Just $ pevalOrTerm t2 $ pevalAndTerm cond t1-  | cond == t1 = Just $ pevalOrTerm cond ifFalse-  | cond == t2 = Just $ pevalOrTerm cond ifFalse-  | otherwise =-      msum-        [ pevalInferImplies cond t1 (pevalOrTerm cond ifFalse) (pevalITETerm cond t2 ifFalse),-          pevalInferImplies cond t2 (pevalOrTerm cond ifFalse) (pevalITETerm cond t1 ifFalse)-        ]--pevalITEBoolBothOr :: Term Bool -> Term Bool -> Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool)-pevalITEBoolBothOr cond t1 t2 f1 f2-  | t1 == f1 = Just $ pevalOrTerm t1 $ pevalITETerm cond t2 f2-  | t1 == f2 = Just $ pevalOrTerm t1 $ pevalITETerm cond t2 f1-  | t2 == f1 = Just $ pevalOrTerm t2 $ pevalITETerm cond t1 f2-  | t2 == f2 = Just $ pevalOrTerm t2 $ pevalITETerm cond t1 f1-  | otherwise = Nothing--pevalITEBoolRightOr :: Term Bool -> Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool)-pevalITEBoolRightOr cond ifTrue f1 f2-  | f1 == ifTrue = Just $ pevalOrTerm f1 $ pevalAndTerm (pevalNotTerm cond) f2-  | f2 == ifTrue = Just $ pevalOrTerm f2 $ pevalAndTerm (pevalNotTerm cond) f1-  | otherwise = Nothing--pevalITEBoolLeft :: Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool)-pevalITEBoolLeft cond (AndTerm _ t1 t2) ifFalse =-  msum-    [ pevalITEBoolLeftAnd cond t1 t2 ifFalse,-      case ifFalse of-        AndTerm _ f1 f2 -> pevalITEBoolBothAnd cond t1 t2 f1 f2-        _ -> Nothing-    ]-pevalITEBoolLeft cond (OrTerm _ t1 t2) ifFalse =-  msum-    [ pevalITEBoolLeftOr cond t1 t2 ifFalse,-      case ifFalse of-        OrTerm _ f1 f2 -> pevalITEBoolBothOr cond t1 t2 f1 f2-        _ -> Nothing-    ]-pevalITEBoolLeft cond (NotTerm _ nIfTrue) ifFalse =-  msum-    [ pevalITEBoolLeftNot cond nIfTrue ifFalse,-      case ifFalse of-        NotTerm _ nIfFalse ->-          pevalITEBoolBothNot cond nIfTrue nIfFalse-        _ -> Nothing-    ]-pevalITEBoolLeft _ _ _ = Nothing--pevalITEBoolNoLeft :: Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool)-pevalITEBoolNoLeft cond ifTrue (AndTerm _ f1 f2) = pevalITEBoolRightAnd cond ifTrue f1 f2-pevalITEBoolNoLeft cond ifTrue (OrTerm _ f1 f2) = pevalITEBoolRightOr cond ifTrue f1 f2-pevalITEBoolNoLeft cond ifTrue (NotTerm _ nIfFalse) = pevalITEBoolRightNot cond ifTrue nIfFalse-pevalITEBoolNoLeft _ _ _ = Nothing--pevalITEBasic :: (SupportedPrim a) => Term Bool -> Term a -> Term a -> Maybe (Term a)-pevalITEBasic (ConTerm _ True) ifTrue _ = Just ifTrue-pevalITEBasic (ConTerm _ False) _ ifFalse = Just ifFalse-pevalITEBasic (NotTerm _ ncond) ifTrue ifFalse = Just $ pevalITETerm ncond ifFalse ifTrue-pevalITEBasic _ ifTrue ifFalse | ifTrue == ifFalse = Just ifTrue-pevalITEBasic (ITETerm _ cc ct cf) (ITETerm _ tc tt tf) (ITETerm _ fc ft ff) -- later-  | cc == tc && cc == fc = Just $ pevalITETerm cc (pevalITETerm ct tt ft) (pevalITETerm cf tf ff)-pevalITEBasic cond (ITETerm _ tc tt tf) ifFalse -- later-  | cond == tc = Just $ pevalITETerm cond tt ifFalse-  | tt == ifFalse = Just $ pevalITETerm (pevalOrTerm (pevalNotTerm cond) tc) tt tf-  | tf == ifFalse = Just $ pevalITETerm (pevalAndTerm cond tc) tt tf-pevalITEBasic cond ifTrue (ITETerm _ fc ft ff) -- later-  | ifTrue == ft = Just $ pevalITETerm (pevalOrTerm cond fc) ifTrue ff-  | ifTrue == ff = Just $ pevalITETerm (pevalOrTerm cond (pevalNotTerm fc)) ifTrue ft-  | pevalImpliesTerm fc cond = Just $ pevalITETerm cond ifTrue ff-pevalITEBasic _ _ _ = Nothing--pevalITEBoolBasic :: Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool)-pevalITEBoolBasic cond ifTrue ifFalse-  | cond == ifTrue = Just $ pevalOrTerm cond ifFalse-  | cond == ifFalse = Just $ pevalAndTerm cond ifTrue-pevalITEBoolBasic cond (ConTerm _ v) ifFalse-  | v = Just $ pevalOrTerm cond ifFalse-  | otherwise = Just $ pevalAndTerm (pevalNotTerm cond) ifFalse-pevalITEBoolBasic cond ifTrue (ConTerm _ v)-  | v = Just $ pevalOrTerm (pevalNotTerm cond) ifTrue-  | otherwise = Just $ pevalAndTerm cond ifTrue-pevalITEBoolBasic _ _ _ = Nothing--pevalITEBool :: Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool)-pevalITEBool cond ifTrue ifFalse =-  msum-    [ pevalITEBasic cond ifTrue ifFalse,-      pevalITEBoolBasic cond ifTrue ifFalse,-      pevalITEBoolLeft cond ifTrue ifFalse,-      pevalITEBoolNoLeft cond ifTrue ifFalse-    ]--pevalITETerm :: forall a. (SupportedPrim a) => Term Bool -> Term a -> Term a -> Term a-pevalITETerm cond ifTrue ifFalse = fromMaybe (iteTerm cond ifTrue ifFalse) $-  case eqT @a @Bool of-    Nothing -> pevalITEBasic cond ifTrue ifFalse-    Just Refl -> pevalITEBool cond ifTrue ifFalse--pevalImplyTerm :: Term Bool -> Term Bool -> Term Bool-pevalImplyTerm l = pevalOrTerm (pevalNotTerm l)--pevalXorTerm :: Term Bool -> Term Bool -> Term Bool-pevalXorTerm l r = pevalOrTerm (pevalAndTerm (pevalNotTerm l) r) (pevalAndTerm l (pevalNotTerm r))
− src/Grisette/IR/SymPrim/Data/Prim/PartialEval/GeneralFun.hs 
@@ -1,42 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeOperators #-}---- |--- Module      :   Grisette.IR.SymPrim.Data.Prim.PartialEval.GeneralFun--- 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.IR.SymPrim.Data.Prim.PartialEval.GeneralFun-  ( pevalGeneralFunApplyTerm,-  )-where--import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors-  ( generalFunApplyTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term-  ( SupportedPrim,-    Term (ConTerm, ITETerm),-    type (-->) (GeneralFun),-  )-import {-# SOURCE #-} Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermSubstitution-  ( substTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool (pevalITETerm)-import Grisette.IR.SymPrim.Data.Prim.PartialEval.PartialEval-  ( totalize2,-  )--pevalGeneralFunApplyTerm :: (SupportedPrim a, SupportedPrim b) => Term (a --> b) -> Term a -> Term b-pevalGeneralFunApplyTerm = totalize2 doPevalGeneralFunApplyTerm generalFunApplyTerm--doPevalGeneralFunApplyTerm :: (SupportedPrim a, SupportedPrim b) => Term (a --> b) -> Term a -> Maybe (Term b)-doPevalGeneralFunApplyTerm (ConTerm _ (GeneralFun arg tm)) v = Just $ substTerm arg v tm-doPevalGeneralFunApplyTerm (ITETerm _ c l r) v =-  return $ pevalITETerm c (pevalGeneralFunApplyTerm l v) (pevalGeneralFunApplyTerm r v)-doPevalGeneralFunApplyTerm _ _ = Nothing
− src/Grisette/IR/SymPrim/Data/Prim/PartialEval/Integral.hs 
@@ -1,98 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}---- |--- Module      :   Grisette.IR.SymPrim.Data.Prim.PartialEval.Integral--- 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.IR.SymPrim.Data.Prim.PartialEval.Integral-  ( pevalDivIntegralTerm,-    pevalModIntegralTerm,-    pevalQuotIntegralTerm,-    pevalRemIntegralTerm,-    pevalDivBoundedIntegralTerm,-    pevalModBoundedIntegralTerm,-    pevalQuotBoundedIntegralTerm,-    pevalRemBoundedIntegralTerm,-  )-where--import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors-  ( conTerm,-    divBoundedIntegralTerm,-    divIntegralTerm,-    modIntegralTerm,-    quotBoundedIntegralTerm,-    quotIntegralTerm,-    remIntegralTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term-  ( SupportedPrim,-    Term (ConTerm),-  )-import Grisette.IR.SymPrim.Data.Prim.PartialEval.Unfold-  ( binaryUnfoldOnce,-  )---- div-pevalDivIntegralTerm :: (SupportedPrim a, Integral a) => Term a -> Term a -> Term a-pevalDivIntegralTerm = binaryUnfoldOnce doPevalDivIntegralTerm divIntegralTerm--doPevalDivIntegralTerm :: (SupportedPrim a, Integral a) => Term a -> Term a -> Maybe (Term a)-doPevalDivIntegralTerm (ConTerm _ a) (ConTerm _ b) | b /= 0 = Just $ conTerm $ a `div` b-doPevalDivIntegralTerm a (ConTerm _ 1) = Just a-doPevalDivIntegralTerm _ _ = Nothing--pevalDivBoundedIntegralTerm :: (SupportedPrim a, Bounded a, Integral a) => Term a -> Term a -> Term a-pevalDivBoundedIntegralTerm = binaryUnfoldOnce doPevalDivBoundedIntegralTerm divBoundedIntegralTerm--doPevalDivBoundedIntegralTerm :: (SupportedPrim a, Bounded a, Integral a) => Term a -> Term a -> Maybe (Term a)-doPevalDivBoundedIntegralTerm (ConTerm _ a) (ConTerm _ b) | b /= 0 && (b /= -1 || a /= minBound) = Just $ conTerm $ a `div` b-doPevalDivBoundedIntegralTerm a (ConTerm _ 1) = Just a-doPevalDivBoundedIntegralTerm _ _ = Nothing---- mod-pevalModIntegralTerm :: (SupportedPrim a, Integral a) => Term a -> Term a -> Term a-pevalModIntegralTerm = binaryUnfoldOnce doPevalModIntegralTerm modIntegralTerm--doPevalModIntegralTerm :: (SupportedPrim a, Integral a) => Term a -> Term a -> Maybe (Term a)-doPevalModIntegralTerm (ConTerm _ a) (ConTerm _ b) | b /= 0 = Just $ conTerm $ a `mod` b-doPevalModIntegralTerm _ (ConTerm _ 1) = Just $ conTerm 0-doPevalModIntegralTerm _ (ConTerm _ (-1)) = Just $ conTerm 0-doPevalModIntegralTerm _ _ = Nothing--pevalModBoundedIntegralTerm :: (SupportedPrim a, Integral a) => Term a -> Term a -> Term a-pevalModBoundedIntegralTerm = pevalModIntegralTerm---- quot-pevalQuotIntegralTerm :: (SupportedPrim a, Integral a) => Term a -> Term a -> Term a-pevalQuotIntegralTerm = binaryUnfoldOnce doPevalQuotIntegralTerm quotIntegralTerm--doPevalQuotIntegralTerm :: (SupportedPrim a, Integral a) => Term a -> Term a -> Maybe (Term a)-doPevalQuotIntegralTerm (ConTerm _ a) (ConTerm _ b) | b /= 0 = Just $ conTerm $ a `quot` b-doPevalQuotIntegralTerm a (ConTerm _ 1) = Just a-doPevalQuotIntegralTerm _ _ = Nothing--pevalQuotBoundedIntegralTerm :: (SupportedPrim a, Bounded a, Integral a) => Term a -> Term a -> Term a-pevalQuotBoundedIntegralTerm = binaryUnfoldOnce doPevalQuotBoundedIntegralTerm quotBoundedIntegralTerm--doPevalQuotBoundedIntegralTerm :: (SupportedPrim a, Bounded a, Integral a) => Term a -> Term a -> Maybe (Term a)-doPevalQuotBoundedIntegralTerm (ConTerm _ a) (ConTerm _ b) | b /= 0 && (b /= -1 || a /= minBound) = Just $ conTerm $ a `quot` b-doPevalQuotBoundedIntegralTerm a (ConTerm _ 1) = Just a-doPevalQuotBoundedIntegralTerm _ _ = Nothing---- rem-pevalRemIntegralTerm :: (SupportedPrim a, Integral a) => Term a -> Term a -> Term a-pevalRemIntegralTerm = binaryUnfoldOnce doPevalRemIntegralTerm remIntegralTerm--doPevalRemIntegralTerm :: (SupportedPrim a, Integral a) => Term a -> Term a -> Maybe (Term a)-doPevalRemIntegralTerm (ConTerm _ a) (ConTerm _ b) | b /= 0 = Just $ conTerm $ a `rem` b-doPevalRemIntegralTerm _ (ConTerm _ 1) = Just $ conTerm 0-doPevalRemIntegralTerm _ (ConTerm _ (-1)) = Just $ conTerm 0-doPevalRemIntegralTerm _ _ = Nothing--pevalRemBoundedIntegralTerm :: (SupportedPrim a, Bounded a, Integral a) => Term a -> Term a -> Term a-pevalRemBoundedIntegralTerm = pevalRemIntegralTerm
− src/Grisette/IR/SymPrim/Data/Prim/PartialEval/Num.hs 
@@ -1,235 +0,0 @@-{-# LANGUAGE ExplicitNamespaces #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE ViewPatterns #-}---- |--- Module      :   Grisette.IR.SymPrim.Data.Prim.PartialEval.Num--- 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.IR.SymPrim.Data.Prim.PartialEval.Num-  ( pattern NumConTerm,-    pattern NumOrdConTerm,-    pevalAddNumTerm,-    pevalMinusNumTerm,-    pevalTimesNumTerm,-    pevalUMinusNumTerm,-    pevalAbsNumTerm,-    pevalSignumNumTerm,-    pevalLtNumTerm,-    pevalLeNumTerm,-    pevalGtNumTerm,-    pevalGeNumTerm,-  )-where--import Data.Typeable (Typeable, cast, eqT, type (:~:) (Refl))-import Grisette.Core.Data.BV (WordN)-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors-  ( absNumTerm,-    addNumTerm,-    conTerm,-    leNumTerm,-    ltNumTerm,-    signumNumTerm,-    timesNumTerm,-    uminusNumTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term-  ( SupportedPrim,-    Term-      ( AbsNumTerm,-        AddNumTerm,-        ConTerm,-        TimesNumTerm,-        UMinusNumTerm-      ),-  )-import Grisette.IR.SymPrim.Data.Prim.PartialEval.Unfold-  ( binaryUnfoldOnce,-    unaryUnfoldOnce,-  )-import Grisette.IR.SymPrim.Data.Prim.Utils (pattern Dyn)-import qualified Type.Reflection as R-import Unsafe.Coerce (unsafeCoerce)--numConTermView :: (Num b, Typeable b) => Term a -> Maybe b-numConTermView (ConTerm _ b) = cast b-numConTermView _ = Nothing--pattern NumConTerm :: forall b a. (Num b, Typeable b) => b -> Term a-pattern NumConTerm b <- (numConTermView -> Just b)--numOrdConTermView :: (Num b, Ord b, Typeable b) => Term a -> Maybe b-numOrdConTermView (ConTerm _ b) = cast b-numOrdConTermView _ = Nothing--pattern NumOrdConTerm :: forall b a. (Num b, Ord b, Typeable b) => b -> Term a-pattern NumOrdConTerm b <- (numOrdConTermView -> Just b)---- add-pevalAddNumTerm :: forall a. (Num a, SupportedPrim a) => Term a -> Term a -> Term a-pevalAddNumTerm = binaryUnfoldOnce doPevalAddNumTerm (\a b -> normalizeAddNum $ addNumTerm a b)--doPevalAddNumTerm :: forall a. (Num a, SupportedPrim a) => Term a -> Term a -> Maybe (Term a)-doPevalAddNumTerm (ConTerm _ a) (ConTerm _ b) = Just $ conTerm $ a + b-doPevalAddNumTerm l@(ConTerm _ a) b = case (a, b) of-  (0, k) -> Just k-  (l1, AddNumTerm _ (ConTerm _ j) k) -> Just $ pevalAddNumTerm (conTerm $ l1 + j) k-  _ -> doPevalAddNumTermNoConc l b-doPevalAddNumTerm a r@(ConTerm _ _) = doPevalAddNumTerm r a-doPevalAddNumTerm l r = doPevalAddNumTermNoConc l r--doPevalAddNumTermNoConc :: forall a. (Num a, SupportedPrim a) => Term a -> Term a -> Maybe (Term a)-doPevalAddNumTermNoConc (AddNumTerm _ i@ConTerm {} j) k = Just $ pevalAddNumTerm i $ pevalAddNumTerm j k-doPevalAddNumTermNoConc i (AddNumTerm _ j@ConTerm {} k) = Just $ pevalAddNumTerm j $ pevalAddNumTerm i k-doPevalAddNumTermNoConc (UMinusNumTerm _ i) (UMinusNumTerm _ j) = Just $ pevalUMinusNumTerm $ pevalAddNumTerm i j-doPevalAddNumTermNoConc (TimesNumTerm _ (ConTerm _ i) j) (TimesNumTerm _ (ConTerm _ k) l)-  | j == l = Just $ pevalTimesNumTerm (conTerm $ i + k) j-doPevalAddNumTermNoConc (TimesNumTerm _ i@ConTerm {} j) (TimesNumTerm _ k@(ConTerm _ _) l)-  | i == k = Just $ pevalTimesNumTerm i (pevalAddNumTerm j l)-doPevalAddNumTermNoConc _ _ = Nothing--normalizeAddNum :: forall a. (Num a, Typeable a) => Term a -> Term a-normalizeAddNum (AddNumTerm _ l r@(ConTerm _ _)) = addNumTerm r l-normalizeAddNum v = v--pevalMinusNumTerm :: (Num a, SupportedPrim a) => Term a -> Term a -> Term a-pevalMinusNumTerm l r = pevalAddNumTerm l (pevalUMinusNumTerm r)---- uminus-pevalUMinusNumTerm :: (Num a, SupportedPrim a) => Term a -> Term a-pevalUMinusNumTerm = unaryUnfoldOnce doPevalUMinusNumTerm uminusNumTerm--doPevalUMinusNumTerm :: forall a. (Num a, SupportedPrim a) => Term a -> Maybe (Term a)-doPevalUMinusNumTerm (ConTerm _ a) = Just $ conTerm $ -a-doPevalUMinusNumTerm (UMinusNumTerm _ v) = Just v-doPevalUMinusNumTerm (AddNumTerm _ (NumConTerm l) r) = Just $ pevalMinusNumTerm (conTerm $ -l) r-doPevalUMinusNumTerm (AddNumTerm _ (UMinusNumTerm _ l) r) = Just $ pevalAddNumTerm l (pevalUMinusNumTerm r)-doPevalUMinusNumTerm (AddNumTerm _ l (UMinusNumTerm _ r)) = Just $ pevalAddNumTerm (pevalUMinusNumTerm l) r-doPevalUMinusNumTerm (TimesNumTerm _ (NumConTerm l) r) = Just $ pevalTimesNumTerm (conTerm $ -l) r-doPevalUMinusNumTerm (TimesNumTerm _ (UMinusNumTerm _ _ :: Term a) (_ :: Term a)) = error "Should not happen"-doPevalUMinusNumTerm (TimesNumTerm _ (_ :: Term a) (UMinusNumTerm _ (_ :: Term a))) = error "Should not happen"-doPevalUMinusNumTerm (AddNumTerm _ (_ :: Term a) ConTerm {}) = error "Should not happen"-doPevalUMinusNumTerm _ = Nothing---- times-pevalTimesNumTerm :: forall a. (Num a, SupportedPrim a) => Term a -> Term a -> Term a-pevalTimesNumTerm = binaryUnfoldOnce doPevalTimesNumTerm (\a b -> normalizeTimesNum $ timesNumTerm a b)--normalizeTimesNum :: forall a. (Num a, Typeable a) => Term a -> Term a-normalizeTimesNum (TimesNumTerm _ l r@(ConTerm _ _)) = timesNumTerm r l-normalizeTimesNum v = v--doPevalTimesNumTerm :: forall a. (Num a, SupportedPrim a) => Term a -> Term a -> Maybe (Term a)-doPevalTimesNumTerm (ConTerm _ a) (ConTerm _ b) = Just $ conTerm $ a * b-doPevalTimesNumTerm l@(ConTerm _ a) b = case (a, b) of-  (0, _) -> Just $ conTerm 0-  (1, k) -> Just k-  (-1, k) -> Just $ pevalUMinusNumTerm k-  (l1, TimesNumTerm _ (NumConTerm j) k) -> Just $ pevalTimesNumTerm (conTerm $ l1 * j) k-  (l1, AddNumTerm _ (NumConTerm j) k) -> Just $ pevalAddNumTerm (conTerm $ l1 * j) (pevalTimesNumTerm (conTerm l1) k)-  (l1, UMinusNumTerm _ j) -> Just (pevalTimesNumTerm (conTerm $ -l1) j)-  (_, TimesNumTerm _ (_ :: Term a) ConTerm {}) -> error "Should not happen"-  (_, AddNumTerm _ (_ :: Term a) ConTerm {}) -> error "Should not happen"-  _ -> doPevalTimesNumTermNoConc l b-doPevalTimesNumTerm a r@(ConTerm _ _) = doPevalTimesNumTerm r a-doPevalTimesNumTerm l r = doPevalTimesNumTermNoConc l r--doPevalTimesNumTermNoConc :: forall a. (Num a, SupportedPrim a) => Term a -> Term a -> Maybe (Term a)-doPevalTimesNumTermNoConc (TimesNumTerm _ i@ConTerm {} j) k = Just $ pevalTimesNumTerm i $ pevalTimesNumTerm j k-doPevalTimesNumTermNoConc i (TimesNumTerm _ j@ConTerm {} k) = Just $ pevalTimesNumTerm j $ pevalTimesNumTerm i k-doPevalTimesNumTermNoConc (UMinusNumTerm _ i) j = Just $ pevalUMinusNumTerm $ pevalTimesNumTerm i j-doPevalTimesNumTermNoConc i (UMinusNumTerm _ j) = Just $ pevalUMinusNumTerm $ pevalTimesNumTerm i j-doPevalTimesNumTermNoConc i j@ConTerm {} = Just $ pevalTimesNumTerm j i-doPevalTimesNumTermNoConc (TimesNumTerm _ (_ :: Term a) ConTerm {}) _ = error "Should not happen"-doPevalTimesNumTermNoConc _ (TimesNumTerm _ (_ :: Term a) ConTerm {}) = error "Should not happen"-doPevalTimesNumTermNoConc _ _ = Nothing---- abs-pevalAbsNumTerm :: (SupportedPrim a, Num a) => Term a -> Term a-pevalAbsNumTerm = unaryUnfoldOnce doPevalAbsNumTerm absNumTerm--isUnsignedBV :: R.TypeRep a -> Bool-isUnsignedBV (R.App s _) =-  case R.eqTypeRep s $ R.typeRep @WordN of-    Just R.HRefl -> True-    _ -> False-isUnsignedBV _ = False--doPevalAbsNumTerm :: forall a. (Num a, SupportedPrim a) => Term a -> Maybe (Term a)-doPevalAbsNumTerm x | isUnsignedBV (R.typeRep @a) = Just x-doPevalAbsNumTerm (ConTerm _ a) = Just $ conTerm $ abs a-doPevalAbsNumTerm (UMinusNumTerm _ v) = Just $ pevalAbsNumTerm v-doPevalAbsNumTerm t@(AbsNumTerm _ (_ :: Term a)) = Just t-doPevalAbsNumTerm (TimesNumTerm _ (Dyn (l :: Term Integer)) r) =-  Just $ pevalTimesNumTerm (pevalAbsNumTerm $ unsafeCoerce l :: Term a) $ pevalAbsNumTerm (unsafeCoerce r)-doPevalAbsNumTerm _ = Nothing---- signum-pevalSignumNumTerm :: (Num a, SupportedPrim a) => Term a -> Term a-pevalSignumNumTerm = unaryUnfoldOnce doPevalSignumNumTerm signumNumTerm--doPevalSignumNumTerm :: forall a. (Num a, SupportedPrim a) => Term a -> Maybe (Term a)-doPevalSignumNumTerm (ConTerm _ a) = Just $ conTerm $ signum a-doPevalSignumNumTerm (UMinusNumTerm _ (Dyn (v :: Term Integer))) = Just $ pevalUMinusNumTerm $ pevalSignumNumTerm $ unsafeCoerce v-doPevalSignumNumTerm (TimesNumTerm _ (Dyn (l :: Term Integer)) r) =-  Just $ pevalTimesNumTerm (pevalSignumNumTerm $ unsafeCoerce l :: Term a) $ pevalSignumNumTerm (unsafeCoerce r)-doPevalSignumNumTerm _ = Nothing---- lt-pevalLtNumTerm :: (Num a, Ord a, SupportedPrim a) => Term a -> Term a -> Term Bool-pevalLtNumTerm = binaryUnfoldOnce doPevalLtNumTerm ltNumTerm--doPevalLtNumTerm :: forall a. (Num a, Ord a, SupportedPrim a) => Term a -> Term a -> Maybe (Term Bool)-doPevalLtNumTerm (ConTerm _ a) (ConTerm _ b) = Just $ conTerm $ a < b-doPevalLtNumTerm (ConTerm _ l) (AddNumTerm _ (ConTerm _ (Dyn (j :: Integer))) k) =-  Just $ pevalLtNumTerm (conTerm $ unsafeCoerce l - j) (unsafeCoerce k)-doPevalLtNumTerm (AddNumTerm _ (ConTerm _ (Dyn (i :: Integer))) j) (ConTerm _ k) =-  Just $ pevalLtNumTerm (unsafeCoerce j) (conTerm $ unsafeCoerce k - i)-doPevalLtNumTerm (AddNumTerm _ (ConTerm _ (Dyn (j :: Integer))) k) l =-  Just $ pevalLtNumTerm (conTerm j) (pevalMinusNumTerm (unsafeCoerce l) (unsafeCoerce k))-doPevalLtNumTerm j (AddNumTerm _ (ConTerm _ (Dyn (k :: Integer))) l) =-  Just $ pevalLtNumTerm (conTerm $ -k) (pevalMinusNumTerm (unsafeCoerce l) (unsafeCoerce j))-doPevalLtNumTerm l (ConTerm _ r) =-  case eqT @a @Integer of-    Just Refl ->-      Just $ pevalLtNumTerm (conTerm $ -r) (pevalUMinusNumTerm l)-    _ -> Nothing-doPevalLtNumTerm _ _ = Nothing---- le-pevalLeNumTerm :: (Num a, Ord a, SupportedPrim a) => Term a -> Term a -> Term Bool-pevalLeNumTerm = binaryUnfoldOnce doPevalLeNumTerm leNumTerm--doPevalLeNumTerm :: forall a. (Num a, Ord a, SupportedPrim a) => Term a -> Term a -> Maybe (Term Bool)-doPevalLeNumTerm (ConTerm _ a) (ConTerm _ b) = Just $ conTerm $ a <= b-doPevalLeNumTerm (ConTerm _ l) (AddNumTerm _ (ConTerm _ (Dyn (j :: Integer))) k) =-  Just $ pevalLeNumTerm (conTerm $ unsafeCoerce l - j) (unsafeCoerce k)-doPevalLeNumTerm (AddNumTerm _ (ConTerm _ (Dyn (i :: Integer))) j) (ConTerm _ k) =-  Just $ pevalLeNumTerm (unsafeCoerce j) (conTerm $ unsafeCoerce k - i)-doPevalLeNumTerm (AddNumTerm _ (ConTerm _ (Dyn (j :: Integer))) k) l =-  Just $ pevalLeNumTerm (conTerm j) (pevalMinusNumTerm (unsafeCoerce l) (unsafeCoerce k))-doPevalLeNumTerm j (AddNumTerm _ (ConTerm _ (Dyn (k :: Integer))) l) =-  Just $ pevalLeNumTerm (conTerm $ -k) (pevalMinusNumTerm (unsafeCoerce l) (unsafeCoerce j))-doPevalLeNumTerm l (ConTerm _ r) =-  case eqT @a @Integer of-    Just Refl ->-      Just $ pevalLeNumTerm (conTerm $ -r) (pevalUMinusNumTerm l)-    _ -> Nothing-doPevalLeNumTerm _ _ = Nothing--pevalGtNumTerm :: (Num a, Ord a, SupportedPrim a) => Term a -> Term a -> Term Bool-pevalGtNumTerm = flip pevalLtNumTerm--pevalGeNumTerm :: (Num a, Ord a, SupportedPrim a) => Term a -> Term a -> Term Bool-pevalGeNumTerm = flip pevalLeNumTerm
− src/Grisette/IR/SymPrim/Data/Prim/PartialEval/PartialEval.hs 
@@ -1,94 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeOperators #-}---- |--- Module      :   Grisette.IR.SymPrim.Data.Prim.PartialEval.PartialEval--- 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.IR.SymPrim.Data.Prim.PartialEval.PartialEval-  ( PartialFun,-    PartialRuleUnary,-    TotalRuleUnary,-    PartialRuleBinary,-    TotalRuleBinary,-    totalize,-    totalize2,-    UnaryPartialStrategy (..),-    unaryPartial,-    BinaryCommPartialStrategy (..),-    BinaryPartialStrategy (..),-    binaryPartial,-  )-where--import Control.Monad.Except (MonadError (catchError))-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term (Term)--type PartialFun a b = a -> Maybe b--type PartialRuleUnary a b = PartialFun (Term a) (Term b)--type TotalRuleUnary a b = Term a -> Term b--type PartialRuleBinary a b c = Term a -> PartialFun (Term b) (Term c)--type TotalRuleBinary a b c = Term a -> Term b -> Term c--totalize :: PartialFun a b -> (a -> b) -> a -> b-totalize partial fallback a =-  case partial a of-    Just b -> b-    Nothing -> fallback a--totalize2 :: (a -> PartialFun b c) -> (a -> b -> c) -> a -> b -> c-totalize2 partial fallback a b =-  case partial a b of-    Just c -> c-    Nothing -> fallback a b--class UnaryPartialStrategy tag a b | tag a -> b where-  extractor :: tag -> Term a -> Maybe a-  constantHandler :: tag -> a -> Maybe (Term b)-  nonConstantHandler :: tag -> Term a -> Maybe (Term b)--unaryPartial :: forall tag a b. (UnaryPartialStrategy tag a b) => tag -> PartialRuleUnary a b-unaryPartial tag a = case extractor tag a of-  Nothing -> nonConstantHandler tag a-  Just a' -> constantHandler tag a'--class BinaryCommPartialStrategy tag a c | tag a -> c where-  singleConstantHandler :: tag -> a -> Term a -> Maybe (Term c)--class BinaryPartialStrategy tag a b c | tag a b -> c where-  extractora :: tag -> Term a -> Maybe a-  extractorb :: tag -> Term b -> Maybe b-  allConstantHandler :: tag -> a -> b -> Maybe (Term c)-  leftConstantHandler :: tag -> a -> Term b -> Maybe (Term c)-  default leftConstantHandler :: (a ~ b, BinaryCommPartialStrategy tag a c) => tag -> a -> Term b -> Maybe (Term c)-  leftConstantHandler = singleConstantHandler @tag @a-  rightConstantHandler :: tag -> Term a -> b -> Maybe (Term c)-  default rightConstantHandler :: (a ~ b, BinaryCommPartialStrategy tag a c) => tag -> Term a -> b -> Maybe (Term c)-  rightConstantHandler tag = flip $ singleConstantHandler @tag @a tag-  nonBinaryConstantHandler :: tag -> Term a -> Term b -> Maybe (Term c)--binaryPartial :: forall tag a b c. (BinaryPartialStrategy tag a b c) => tag -> PartialRuleBinary a b c-binaryPartial tag a b = case (extractora @tag @a @b @c tag a, extractorb @tag @a @b @c tag b) of-  (Nothing, Nothing) -> nonBinaryConstantHandler @tag @a @b @c tag a b-  (Just a', Nothing) ->-    leftConstantHandler @tag @a @b @c tag a' b-      `catchError` \_ -> nonBinaryConstantHandler @tag @a @b @c tag a b-  (Nothing, Just b') ->-    rightConstantHandler @tag @a @b @c tag a b'-      `catchError` \_ -> nonBinaryConstantHandler @tag @a @b @c tag a b-  (Just a', Just b') ->-    allConstantHandler @tag @a @b @c tag a' b'
− src/Grisette/IR/SymPrim/Data/Prim/PartialEval/TabularFun.hs 
@@ -1,48 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeOperators #-}---- |--- Module      :   Grisette.IR.SymPrim.Data.Prim.PartialEval.TabularFun--- 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.IR.SymPrim.Data.Prim.PartialEval.TabularFun-  ( pevalTabularFunApplyTerm,-  )-where--import Grisette.Core.Data.Class.Function (Function ((#)))-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors-  ( conTerm,-    tabularFunApplyTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term-  ( SupportedPrim,-    Term (ConTerm),-  )-import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool-  ( pevalEqvTerm,-    pevalITETerm,-  )-import Grisette.IR.SymPrim.Data.Prim.PartialEval.PartialEval-  ( totalize2,-  )-import Grisette.IR.SymPrim.Data.TabularFun-  ( type (=->) (TabularFun),-  )--pevalTabularFunApplyTerm :: (SupportedPrim a, SupportedPrim b) => Term (a =-> b) -> Term a -> Term b-pevalTabularFunApplyTerm = totalize2 doPevalTabularFunApplyTerm tabularFunApplyTerm--doPevalTabularFunApplyTerm :: (SupportedPrim a, SupportedPrim b) => Term (a =-> b) -> Term a -> Maybe (Term b)-doPevalTabularFunApplyTerm (ConTerm _ f) (ConTerm _ a) = Just $ conTerm $ f # a-doPevalTabularFunApplyTerm (ConTerm _ (TabularFun f d)) a = Just $ go f-  where-    go [] = conTerm d-    go ((x, y) : xs) = pevalITETerm (pevalEqvTerm a (conTerm x)) (conTerm y) (go xs)-doPevalTabularFunApplyTerm _ _ = Nothing
− src/Grisette/IR/SymPrim/Data/Prim/PartialEval/Unfold.hs 
@@ -1,118 +0,0 @@-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}---- |--- Module      :   Grisette.IR.SymPrim.Data.Prim.PartialEval.Unfold--- 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.IR.SymPrim.Data.Prim.PartialEval.Unfold-  ( unaryUnfoldOnce,-    binaryUnfoldOnce,-  )-where--import Control.Monad.Except (MonadError (catchError))-import Data.Typeable (Typeable)-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term-  ( SupportedPrim,-    Term (ITETerm),-  )-import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool-  ( pevalITETerm,-  )-import Grisette.IR.SymPrim.Data.Prim.PartialEval.PartialEval-  ( PartialRuleBinary,-    PartialRuleUnary,-    TotalRuleBinary,-    TotalRuleUnary,-    totalize,-    totalize2,-  )--unaryPartialUnfoldOnce ::-  forall a b.-  (Typeable a, SupportedPrim b) =>-  PartialRuleUnary a b ->-  TotalRuleUnary a b ->-  PartialRuleUnary a b-unaryPartialUnfoldOnce partial fallback = ret-  where-    oneLevel :: TotalRuleUnary a b -> PartialRuleUnary a b-    oneLevel fallback' x = case (x, partial x) of-      (ITETerm _ cond vt vf, pr) ->-        let pt = partial vt-            pf = partial vf-         in case (pt, pf) of-              (Nothing, Nothing) -> pr-              (mt, mf) ->-                pevalITETerm cond-                  <$> catchError mt (\_ -> Just $ totalize (oneLevel fallback') fallback' vt)-                  <*> catchError mf (\_ -> Just $ totalize (oneLevel fallback') fallback vf)-      (_, pr) -> pr-    ret :: PartialRuleUnary a b-    ret = oneLevel (totalize @(Term a) @(Term b) partial fallback)--unaryUnfoldOnce ::-  forall a b.-  (Typeable a, SupportedPrim b) =>-  PartialRuleUnary a b ->-  TotalRuleUnary a b ->-  TotalRuleUnary a b-unaryUnfoldOnce partial fallback = totalize (unaryPartialUnfoldOnce partial fallback) fallback--binaryPartialUnfoldOnce ::-  forall a b c.-  (Typeable a, Typeable b, SupportedPrim c) =>-  PartialRuleBinary a b c ->-  TotalRuleBinary a b c ->-  PartialRuleBinary a b c-binaryPartialUnfoldOnce partial fallback = ret-  where-    oneLevel :: (Typeable x, Typeable y) => PartialRuleBinary x y c -> TotalRuleBinary x y c -> PartialRuleBinary x y c-    oneLevel partial' fallback' x y =-      catchError-        (partial' x y)-        ( \_ ->-            catchError-              ( case x of-                  ITETerm _ cond vt vf -> left cond vt vf y partial' fallback'-                  _ -> Nothing-              )-              ( \_ -> case y of-                  ITETerm _ cond vt vf -> left cond vt vf x (flip partial') (flip fallback')-                  _ -> Nothing-              )-        )-    left ::-      (Typeable x, Typeable y) =>-      Term Bool ->-      Term x ->-      Term x ->-      Term y ->-      PartialRuleBinary x y c ->-      TotalRuleBinary x y c ->-      Maybe (Term c)-    left cond vt vf y partial' fallback' =-      let pt = partial' vt y-          pf = partial' vf y-       in case (pt, pf) of-            (Nothing, Nothing) -> Nothing-            (mt, mf) ->-              pevalITETerm cond-                <$> catchError mt (\_ -> Just $ totalize2 (oneLevel partial' fallback') fallback' vt y)-                <*> catchError mf (\_ -> Just $ totalize2 (oneLevel partial' fallback') fallback' vf y)-    ret :: PartialRuleBinary a b c-    ret = oneLevel partial (totalize2 @(Term a) @(Term b) @(Term c) partial fallback)--binaryUnfoldOnce ::-  forall a b c.-  (Typeable a, Typeable b, SupportedPrim c) =>-  PartialRuleBinary a b c ->-  TotalRuleBinary a b c ->-  TotalRuleBinary a b c-binaryUnfoldOnce partial fallback = totalize2 (binaryPartialUnfoldOnce partial fallback) fallback
− src/Grisette/IR/SymPrim/Data/Prim/Utils.hs 
@@ -1,62 +0,0 @@-{-# LANGUAGE ExplicitNamespaces #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE ViewPatterns #-}---- |--- Module      :   Grisette.IR.SymPrim.Data.Prim.Utils--- 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.IR.SymPrim.Data.Prim.Utils-  ( pattern Dyn,-    cmpHetero,-    eqHetero,-    cmpHeteroRep,-    eqHeteroRep,-    eqTypeRepBool,-  )-where--import Data.Typeable (cast)-import Type.Reflection-  ( TypeRep,-    Typeable,-    eqTypeRep,-    typeRep,-    type (:~~:) (HRefl),-  )--pattern Dyn :: (Typeable a, Typeable b) => a -> b-pattern Dyn x <- (cast -> Just x)--cmpHeteroRep :: forall a b. TypeRep a -> TypeRep b -> (a -> a -> Bool) -> a -> b -> Bool-cmpHeteroRep ta tb f a b = case eqTypeRep ta tb of-  Just HRefl -> f a b-  _ -> False-{-# INLINE cmpHeteroRep #-}--cmpHetero :: forall a b. (Typeable a, Typeable b) => (a -> a -> Bool) -> a -> b -> Bool-cmpHetero = cmpHeteroRep (typeRep @a) (typeRep @b)-{-# INLINE cmpHetero #-}--eqHetero :: forall a b. (Typeable a, Typeable b, Eq a) => a -> b -> Bool-eqHetero = cmpHetero (==)-{-# INLINE eqHetero #-}--eqHeteroRep :: forall a b. (Eq a) => TypeRep a -> TypeRep b -> a -> b -> Bool-eqHeteroRep ta tb = cmpHeteroRep ta tb (==)-{-# INLINE eqHeteroRep #-}--eqTypeRepBool :: forall ka kb (a :: ka) (b :: kb). TypeRep a -> TypeRep b -> Bool-eqTypeRepBool a b = case eqTypeRep a b of-  Just HRefl -> True-  _ -> False-{-# INLINE eqTypeRepBool #-}
− src/Grisette/IR/SymPrim/Data/SymPrim.hs 
@@ -1,1349 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveLift #-}-{-# LANGUAGE DerivingVia #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}---- |--- Module      :   Grisette.IR.SymPrim.Data.SymPrim--- 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.IR.SymPrim.Data.SymPrim-  ( SymBool (..),-    SymInteger (..),-    SymWordN (..),-    SymIntN (..),-    SomeSymWordN (..),-    SomeSymIntN (..),-    type (=~>) (..),-    type (-~>) (..),-    (-->),-    ModelSymPair (..),-    symSize,-    symsSize,-    SomeSym (..),-    AllSyms (..),-    allSymsSize,-    unarySomeSymIntN,-    unarySomeSymIntNR1,-    binSomeSymIntN,-    binSomeSymIntNR1,-    binSomeSymIntNR2,-    unarySomeSymWordN,-    unarySomeSymWordNR1,-    binSomeSymWordN,-    binSomeSymWordNR1,-    binSomeSymWordNR2,-  )-where--import Control.DeepSeq (NFData (rnf))-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.Bits-  ( Bits-      ( bit,-        bitSize,-        bitSizeMaybe,-        clearBit,-        complement,-        complementBit,-        isSigned,-        popCount,-        rotate,-        rotateL,-        rotateR,-        setBit,-        shift,-        shiftL,-        shiftR,-        testBit,-        unsafeShiftL,-        unsafeShiftR,-        xor,-        zeroBits,-        (.&.),-        (.|.)-      ),-    FiniteBits (finiteBitSize),-  )-import qualified Data.ByteString as B-import Data.Functor.Sum (Sum)-import Data.Hashable (Hashable (hashWithSalt))-import Data.Int (Int16, Int32, Int64, Int8)-import Data.Proxy (Proxy (Proxy))-import Data.String (IsString (fromString))-import qualified Data.Text as T-import Data.Typeable (typeRep, type (:~:) (Refl))-import Data.Word (Word16, Word32, Word64, Word8)-import GHC.Generics-  ( Generic (Rep, from),-    K1 (K1),-    M1 (M1),-    U1,-    type (:*:) ((:*:)),-    type (:+:) (L1, R1),-  )-import GHC.TypeNats-  ( KnownNat,-    Nat,-    natVal,-    sameNat,-    type (+),-    type (<=),-  )-import Generics.Deriving (Default (Default, unDefault))-import Grisette.Core.Control.Exception-  ( AssertionError,-    VerificationConditions,-  )-import Grisette.Core.Data.BV-  ( IntN,-    WordN,-  )-import Grisette.Core.Data.Class.BitVector-  ( BV (bvConcat, bvExt, bvSelect, bvSext, bvZext),-    SizedBV (sizedBVConcat, sizedBVExt, sizedBVSelect, sizedBVSext, sizedBVZext),-  )-import Grisette.Core.Data.Class.Function (Apply (FunType, apply), Function (Arg, Ret, (#)))-import Grisette.Core.Data.Class.ModelOps-  ( ModelOps (emptyModel, insertValue),-    ModelRep (buildModel),-  )-import Grisette.Core.Data.Class.SignConversion (SignConversion (toSigned, toUnsigned))-import Grisette.Core.Data.Class.Solvable-  ( Solvable (con, conView, iinfosym, isym, sinfosym, ssym),-    pattern Con,-  )-import Grisette.Core.Data.Class.SymRotate (SymRotate (symRotate))-import Grisette.Core.Data.Class.SymShift (SymShift (symShift))-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors (conTerm, iinfosymTerm, isymTerm, sinfosymTerm, ssymTerm, symTerm)-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.SomeTerm-  ( SomeTerm (SomeTerm),-  )-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term-  ( ConRep (ConType),-    LinkedRep (underlyingTerm, wrapTerm),-    SupportedPrim,-    SymRep (SymType),-    Term (ConTerm, SymTerm),-    TypedSymbol (WithInfo),-    type (-->) (GeneralFun),-  )-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermSubstitution-  ( substTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermUtils-  ( pformat,-    someTermsSize,-    termSize,-    termsSize,-  )-import Grisette.IR.SymPrim.Data.Prim.Model-  ( Model,-  )-import Grisette.IR.SymPrim.Data.Prim.PartialEval.BV-  ( pevalBVConcatTerm,-    pevalBVExtendTerm,-    pevalBVSelectTerm,-    pevalToSignedTerm,-    pevalToUnsignedTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bits-  ( pevalAndBitsTerm,-    pevalComplementBitsTerm,-    pevalOrBitsTerm,-    pevalRotateLeftTerm,-    pevalRotateRightTerm,-    pevalShiftLeftTerm,-    pevalShiftRightTerm,-    pevalXorBitsTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool-  ( pevalEqvTerm,-    pevalITETerm,-    pevalOrTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.PartialEval.GeneralFun-  ( pevalGeneralFunApplyTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.PartialEval.Integral (pevalModBoundedIntegralTerm)-import Grisette.IR.SymPrim.Data.Prim.PartialEval.Num-  ( pevalAbsNumTerm,-    pevalAddNumTerm,-    pevalGeNumTerm,-    pevalLeNumTerm,-    pevalMinusNumTerm,-    pevalSignumNumTerm,-    pevalTimesNumTerm,-    pevalUMinusNumTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.PartialEval.TabularFun-  ( pevalTabularFunApplyTerm,-  )-import Grisette.IR.SymPrim.Data.TabularFun (type (=->))-import Grisette.Utils.Parameterized-  ( KnownProof (KnownProof),-    LeqProof (LeqProof),-    knownAdd,-    leqAddPos,-    leqTrans,-    unsafeKnownProof,-    unsafeLeqProof,-  )-import Language.Haskell.TH.Syntax (Lift)---- $setup--- >>> import Grisette.Core--- >>> import Grisette.IR.SymPrim--- >>> import Grisette.Backend.SBV--- >>> import Data.Proxy---- | Symbolic Boolean type.------ >>> :set -XOverloadedStrings--- >>> "a" :: SymBool--- a--- >>> "a" .&& "b" :: SymBool--- (&& a b)------ More symbolic operations are available. Please refer to the documentation--- for the type class instances.-newtype SymBool = SymBool {underlyingBoolTerm :: Term Bool}-  deriving (Lift, NFData, Generic)---- | Symbolic (unbounded, mathematical) integer type.------ >>> "a" + 1 :: SymInteger--- (+ 1 a)------ More symbolic operations are available. Please refer to the documentation--- for the type class instances.-newtype SymInteger = SymInteger {underlyingIntegerTerm :: Term Integer}-  deriving (Lift, NFData, Generic)--#define QUOTE() '-#define QID(a) a-#define QRIGHT(a) QID(a)'---- | Symbolic signed bit vector type. Indexed with the bit width.--- Signedness affects the semantics of the operations, including--- comparison/extension, etc.------ >>> :set -XOverloadedStrings -XDataKinds -XBinaryLiterals--- >>> "a" + 5 :: SymIntN 5--- (+ 0b00101 a)--- >>> sizedBVConcat (con 0b101 :: SymIntN 3) (con 0b110 :: SymIntN 3)--- 0b101110--- >>> sizedBVExt (Proxy @6) (con 0b101 :: SymIntN 3)--- 0b111101--- >>> (8 :: SymIntN 4) .< (7 :: SymIntN 4)--- true------ More symbolic operations are available. Please refer to the documentation--- for the type class instances.-newtype SymIntN (n :: Nat) = SymIntN {underlyingIntNTerm :: Term (IntN n)}-  deriving (Lift, NFData, Generic)---- | Symbolic signed bit vector type. Not indexed, but the bit width is--- fixed at the creation time.------ A 'SomeSymIntN' must be created by wrapping a 'SymIntN' with the--- 'SomeSymIntN' constructor to fix the bit width:------ >>> (SomeSymIntN ("a" :: SymIntN 5))--- a------ >>> :set -XOverloadedStrings -XDataKinds -XBinaryLiterals--- >>> (SomeSymIntN ("a" :: SymIntN 5)) + (SomeSymIntN (5 :: SymIntN 5))--- (+ 0b00101 a)--- >>> bvConcat (SomeSymIntN (con 0b101 :: SymIntN 3)) (SomeSymIntN (con 0b110 :: SymIntN 3))--- 0b101110------ More symbolic operations are available. Please refer to the documentation--- for the type class instances.-data SomeSymIntN where-  SomeSymIntN :: (KnownNat n, 1 <= n) => SymIntN n -> SomeSymIntN--unarySomeSymIntN :: (forall n. (KnownNat n, 1 <= n) => SymIntN n -> r) -> String -> SomeSymIntN -> r-unarySomeSymIntN op _ (SomeSymIntN (w :: SymIntN w)) = op w-{-# INLINE unarySomeSymIntN #-}--unarySomeSymIntNR1 :: (forall n. (KnownNat n, 1 <= n) => SymIntN n -> SymIntN n) -> String -> SomeSymIntN -> SomeSymIntN-unarySomeSymIntNR1 op _ (SomeSymIntN (w :: SymIntN w)) = SomeSymIntN $ op w-{-# INLINE unarySomeSymIntNR1 #-}--binSomeSymIntN :: (forall n. (KnownNat n, 1 <= n) => SymIntN n -> SymIntN n -> r) -> String -> SomeSymIntN -> SomeSymIntN -> r-binSomeSymIntN op str (SomeSymIntN (l :: SymIntN l)) (SomeSymIntN (r :: SymIntN r)) =-  case sameNat (Proxy @l) (Proxy @r) of-    Just Refl -> op l r-    Nothing -> error $ "Operation " ++ str ++ " on SymIntN with different bitwidth"-{-# INLINE binSomeSymIntN #-}--binSomeSymIntNR1 :: (forall n. (KnownNat n, 1 <= n) => SymIntN n -> SymIntN n -> SymIntN n) -> String -> SomeSymIntN -> SomeSymIntN -> SomeSymIntN-binSomeSymIntNR1 op str (SomeSymIntN (l :: SymIntN l)) (SomeSymIntN (r :: SymIntN r)) =-  case sameNat (Proxy @l) (Proxy @r) of-    Just Refl -> SomeSymIntN $ op l r-    Nothing -> error $ "Operation " ++ str ++ " on SymIntN with different bitwidth"-{-# INLINE binSomeSymIntNR1 #-}--binSomeSymIntNR2 :: (forall n. (KnownNat n, 1 <= n) => SymIntN n -> SymIntN n -> (SymIntN n, SymIntN n)) -> String -> SomeSymIntN -> SomeSymIntN -> (SomeSymIntN, SomeSymIntN)-binSomeSymIntNR2 op str (SomeSymIntN (l :: SymIntN l)) (SomeSymIntN (r :: SymIntN r)) =-  case sameNat (Proxy @l) (Proxy @r) of-    Just Refl ->-      case op l r of-        (a, b) -> (SomeSymIntN a, SomeSymIntN b)-    Nothing -> error $ "Operation " ++ str ++ " on SymIntN with different bitwidth"-{-# INLINE binSomeSymIntNR2 #-}---- | Symbolic unsigned bit vector type. Indexed with the bit width.--- Signedness affects the semantics of the operations, including--- comparison/extension, etc.------ >>> :set -XOverloadedStrings -XDataKinds -XBinaryLiterals--- >>> "a" + 5 :: SymWordN 5--- (+ 0b00101 a)--- >>> sizedBVConcat (con 0b101 :: SymWordN 3) (con 0b110 :: SymWordN 3)--- 0b101110--- >>> sizedBVExt (Proxy @6) (con 0b101 :: SymWordN 3)--- 0b000101--- >>> (8 :: SymWordN 4) .< (7 :: SymWordN 4)--- false------ More symbolic operations are available. Please refer to the documentation--- for the type class instances.-newtype SymWordN (n :: Nat) = SymWordN {underlyingWordNTerm :: Term (WordN n)}-  deriving (Lift, NFData, Generic)---- | Symbolic unsigned bit vector type. Not indexed, but the bit width is--- fixed at the creation time.------ A 'SomeSymWordN' must be created by wrapping a 'SymWordN' with the--- 'SomeSymWordN' constructor to fix the bit width:------ >>> (SomeSymWordN ("a" :: SymWordN 5))--- a------ >>> :set -XOverloadedStrings -XDataKinds -XBinaryLiterals--- >>> (SomeSymWordN ("a" :: SymWordN 5)) + (SomeSymWordN (5 :: SymWordN 5))--- (+ 0b00101 a)--- >>> bvConcat (SomeSymWordN (con 0b101 :: SymWordN 3)) (SomeSymWordN (con 0b110 :: SymWordN 3))--- 0b101110------ More symbolic operations are available. Please refer to the documentation--- for the type class instances.-data SomeSymWordN where-  SomeSymWordN :: (KnownNat n, 1 <= n) => SymWordN n -> SomeSymWordN--unarySomeSymWordN :: (forall n. (KnownNat n, 1 <= n) => SymWordN n -> r) -> String -> SomeSymWordN -> r-unarySomeSymWordN op _ (SomeSymWordN (w :: SymWordN w)) = op w-{-# INLINE unarySomeSymWordN #-}--unarySomeSymWordNR1 :: (forall n. (KnownNat n, 1 <= n) => SymWordN n -> SymWordN n) -> String -> SomeSymWordN -> SomeSymWordN-unarySomeSymWordNR1 op _ (SomeSymWordN (w :: SymWordN w)) = SomeSymWordN $ op w-{-# INLINE unarySomeSymWordNR1 #-}--binSomeSymWordN :: (forall n. (KnownNat n, 1 <= n) => SymWordN n -> SymWordN n -> r) -> String -> SomeSymWordN -> SomeSymWordN -> r-binSomeSymWordN op str (SomeSymWordN (l :: SymWordN l)) (SomeSymWordN (r :: SymWordN r)) =-  case sameNat (Proxy @l) (Proxy @r) of-    Just Refl -> op l r-    Nothing -> error $ "Operation " ++ str ++ " on SymWordN with different bitwidth"-{-# INLINE binSomeSymWordN #-}--binSomeSymWordNR1 :: (forall n. (KnownNat n, 1 <= n) => SymWordN n -> SymWordN n -> SymWordN n) -> String -> SomeSymWordN -> SomeSymWordN -> SomeSymWordN-binSomeSymWordNR1 op str (SomeSymWordN (l :: SymWordN l)) (SomeSymWordN (r :: SymWordN r)) =-  case sameNat (Proxy @l) (Proxy @r) of-    Just Refl -> SomeSymWordN $ op l r-    Nothing -> error $ "Operation " ++ str ++ " on SymWordN with different bitwidth"-{-# INLINE binSomeSymWordNR1 #-}--binSomeSymWordNR2 :: (forall n. (KnownNat n, 1 <= n) => SymWordN n -> SymWordN n -> (SymWordN n, SymWordN n)) -> String -> SomeSymWordN -> SomeSymWordN -> (SomeSymWordN, SomeSymWordN)-binSomeSymWordNR2 op str (SomeSymWordN (l :: SymWordN l)) (SomeSymWordN (r :: SymWordN r)) =-  case sameNat (Proxy @l) (Proxy @r) of-    Just Refl ->-      case op l r of-        (a, b) -> (SomeSymWordN a, SomeSymWordN b)-    Nothing -> error $ "Operation " ++ str ++ " on SymWordN with different bitwidth"-{-# INLINE binSomeSymWordNR2 #-}--instance ConRep SymBool where-  type ConType SymBool = Bool--instance SymRep Bool where-  type SymType Bool = SymBool--instance LinkedRep Bool SymBool where-  underlyingTerm (SymBool a) = a-  wrapTerm = SymBool--instance ConRep SymInteger where-  type ConType SymInteger = Integer--instance SymRep Integer where-  type SymType Integer = SymInteger--instance LinkedRep Integer SymInteger where-  underlyingTerm (SymInteger a) = a-  wrapTerm = SymInteger--instance (KnownNat n, 1 <= n) => ConRep (SymIntN n) where-  type ConType (SymIntN n) = IntN n--instance (KnownNat n, 1 <= n) => SymRep (IntN n) where-  type SymType (IntN n) = SymIntN n--instance (KnownNat n, 1 <= n) => LinkedRep (IntN n) (SymIntN n) where-  underlyingTerm (SymIntN a) = a-  wrapTerm = SymIntN--instance (KnownNat n, 1 <= n) => ConRep (SymWordN n) where-  type ConType (SymWordN n) = WordN n--instance (KnownNat n, 1 <= n) => SymRep (WordN n) where-  type SymType (WordN n) = SymWordN n--instance (KnownNat n, 1 <= n) => LinkedRep (WordN n) (SymWordN n) where-  underlyingTerm (SymWordN a) = a-  wrapTerm = SymWordN---- | Symbolic tabular function type.------ >>> :set -XTypeOperators -XOverloadedStrings--- >>> f' = "f" :: SymInteger =~> SymInteger--- >>> f = (f' #)--- >>> f 1--- (apply f 1)------ >>> f' = con (TabularFun [(1, 2), (2, 3)] 4) :: SymInteger =~> SymInteger--- >>> f = (f' #)--- >>> f 1--- 2--- >>> f 2--- 3--- >>> f 3--- 4--- >>> f "b"--- (ite (= b 1) 2 (ite (= b 2) 3 4))-data sa =~> sb where-  SymTabularFun :: (LinkedRep ca sa, LinkedRep cb sb) => Term (ca =-> cb) -> sa =~> sb--infixr 0 =~>--instance (ConRep a, ConRep b) => ConRep (a =~> b) where-  type ConType (a =~> b) = ConType a =-> ConType b--instance (SymRep a, SymRep b) => SymRep (a =-> b) where-  type SymType (a =-> b) = SymType a =~> SymType b--instance (LinkedRep ca sa, LinkedRep cb sb) => LinkedRep (ca =-> cb) (sa =~> sb) where-  underlyingTerm (SymTabularFun a) = a-  wrapTerm = SymTabularFun--instance (SupportedPrim ca, SupportedPrim cb, LinkedRep ca sa, LinkedRep cb sb) => Function (sa =~> sb) where-  type Arg (sa =~> sb) = sa-  type Ret (sa =~> sb) = sb-  (SymTabularFun f) # t = wrapTerm $ pevalTabularFunApplyTerm f (underlyingTerm t)--instance (LinkedRep ca sa, LinkedRep ct st, Apply st) => Apply (sa =~> st) where-  type FunType (sa =~> st) = sa -> FunType st-  apply uf a = apply (uf # a)---- |--- Symbolic general function type.------ >>> :set -XTypeOperators -XOverloadedStrings--- >>> f' = "f" :: SymInteger -~> SymInteger--- >>> f = (f' #)--- >>> f 1--- (apply f 1)------ >>> f' = con ("a" --> "a" + 1) :: SymInteger -~> SymInteger--- >>> f'--- \(a:ARG :: Integer) -> (+ 1 a:ARG)--- >>> f = (f' #)--- >>> f 1--- 2--- >>> f 2--- 3--- >>> f 3--- 4--- >>> f "b"--- (+ 1 b)-data sa -~> sb where-  SymGeneralFun :: (LinkedRep ca sa, LinkedRep cb sb) => Term (ca --> cb) -> sa -~> sb--infixr 0 -~>--instance (ConRep a, ConRep b) => ConRep (a -~> b) where-  type ConType (a -~> b) = ConType a --> ConType b--instance (SymRep ca, SymRep cb) => SymRep (ca --> cb) where-  type SymType (ca --> cb) = SymType ca -~> SymType cb--instance (LinkedRep ca sa, LinkedRep cb sb) => LinkedRep (ca --> cb) (sa -~> sb) where-  underlyingTerm (SymGeneralFun a) = a-  wrapTerm = SymGeneralFun--instance (SupportedPrim ca, SupportedPrim cb, LinkedRep ca sa, LinkedRep cb sb) => Function (sa -~> sb) where-  type Arg (sa -~> sb) = sa-  type Ret (sa -~> sb) = sb-  (SymGeneralFun f) # t = wrapTerm $ pevalGeneralFunApplyTerm f (underlyingTerm t)--instance (LinkedRep ca sa, LinkedRep ct st, Apply st) => Apply (sa -~> st) where-  type FunType (sa -~> st) = sa -> FunType st-  apply uf a = apply (uf # a)---- | Construction of general symbolic functions.------ >>> f = "a" --> "a" + 1 :: Integer --> Integer--- >>> f--- \(a:ARG :: Integer) -> (+ 1 a:ARG)------ This general symbolic function needs to be applied to symbolic values:--- >>> f # ("a" :: SymInteger)--- (+ 1 a)-(-->) :: (SupportedPrim ca, SupportedPrim cb, LinkedRep cb sb) => TypedSymbol ca -> sb -> ca --> cb-(-->) arg v = GeneralFun newarg (substTerm arg (symTerm newarg) (underlyingTerm v))-  where-    newarg = WithInfo arg ARG--infixr 0 -->--data ARG = ARG-  deriving (Eq, Ord, Lift, Show, Generic)--instance NFData ARG where-  rnf ARG = ()--instance Hashable ARG where-  hashWithSalt s ARG = s `hashWithSalt` (0 :: Int)---- Aggregate instances--instance Apply SymBool where-  type FunType SymBool = SymBool-  apply = id--instance Apply SymInteger where-  type FunType SymInteger = SymInteger-  apply = id--instance (KnownNat n, 1 <= n) => Apply (SymIntN n) where-  type FunType (SymIntN n) = SymIntN n-  apply = id--instance (KnownNat n, 1 <= n) => Apply (SymWordN n) where-  type FunType (SymWordN n) = SymWordN n-  apply = id--#define SOLVABLE_SIMPLE(contype, symtype) \-instance Solvable contype symtype where \-  con = symtype . conTerm; \-  ssym = symtype . ssymTerm; \-  isym str i = symtype $ isymTerm str i; \-  sinfosym str info = symtype $ sinfosymTerm str info; \-  iinfosym str i info = symtype $ iinfosymTerm str i info; \-  conView (symtype (ConTerm _ t)) = Just t; \-  conView _ = Nothing--#define SOLVABLE_BV(contype, symtype) \-instance (KnownNat n, 1 <= n) => Solvable (contype n) (symtype n) where \-  con = symtype . conTerm; \-  ssym = symtype . ssymTerm; \-  isym str i = symtype $ isymTerm str i; \-  sinfosym str info = symtype $ sinfosymTerm str info; \-  iinfosym str i info = symtype $ iinfosymTerm str i info; \-  conView (symtype (ConTerm _ t)) = Just t; \-  conView _ = Nothing--#define SOLVABLE_FUN(symop, conop, symcons) \-instance \-  (SupportedPrim ca, SupportedPrim cb, LinkedRep ca sa, LinkedRep cb sb) => \-  Solvable (conop ca cb) (symop sa sb) where \-  con = symcons . conTerm; \-  ssym = symcons . ssymTerm; \-  isym str i = symcons $ isymTerm str i; \-  sinfosym str info = symcons $ sinfosymTerm str info; \-  iinfosym str i info = symcons $ iinfosymTerm str i info; \-  conView (symcons (ConTerm _ t)) = Just t; \-  conView _ = Nothing--#if 1-SOLVABLE_SIMPLE(Bool, SymBool)-SOLVABLE_SIMPLE(Integer, SymInteger)-SOLVABLE_BV(IntN, SymIntN)-SOLVABLE_BV(WordN, SymWordN)-SOLVABLE_FUN((=~>), (=->), SymTabularFun)-SOLVABLE_FUN((-~>), (-->), SymGeneralFun)-#endif---- Num--#define NUM_BV(symtype) \-instance (KnownNat n, 1 <= n) => Num (symtype n) where \-  (symtype l) + (symtype r) = symtype $ pevalAddNumTerm l r; \-  (symtype l) - (symtype r) = symtype $ pevalMinusNumTerm l r; \-  (symtype l) * (symtype r) = symtype $ pevalTimesNumTerm l r; \-  negate (symtype v) = symtype $ pevalUMinusNumTerm v; \-  abs (symtype v) = symtype $ pevalAbsNumTerm v; \-  signum (symtype v) = symtype $ pevalSignumNumTerm v; \-  fromInteger i = con $ fromInteger i--#define NUM_SOME_BV(somety, br1, ur1) \-instance Num somety where \-  (+) = br1 (+) "+"; \-  {-# INLINE (+) #-}; \-  (-) = br1 (-) "-"; \-  {-# INLINE (-) #-}; \-  (*) = br1 (*) "*"; \-  {-# INLINE (*) #-}; \-  negate = ur1 negate "negate"; \-  {-# INLINE negate #-}; \-  abs = ur1 abs "abs"; \-  {-# INLINE abs #-}; \-  signum = ur1 signum "signum"; \-  {-# INLINE signum #-}; \-  fromInteger = error "fromInteger is not defined for SomeSymWordN as no bitwidth is known"; \-  {-# INLINE fromInteger #-}--#if 1-NUM_BV(SymIntN)-NUM_BV(SymWordN)-NUM_SOME_BV(SomeSymWordN, binSomeSymWordNR1, unarySomeSymWordNR1)-NUM_SOME_BV(SomeSymIntN, binSomeSymIntNR1, unarySomeSymIntNR1)-#endif--instance Num SymInteger where-  (SymInteger l) + (SymInteger r) = SymInteger $ pevalAddNumTerm l r-  (SymInteger l) - (SymInteger r) = SymInteger $ pevalMinusNumTerm l r-  (SymInteger l) * (SymInteger r) = SymInteger $ pevalTimesNumTerm l r-  negate (SymInteger v) = SymInteger $ pevalUMinusNumTerm v-  abs (SymInteger v) = SymInteger $ pevalAbsNumTerm v-  signum (SymInteger v) = SymInteger $ pevalSignumNumTerm v-  fromInteger = con---- Bits--#define BITS_BV(symtype, signed) \-instance (KnownNat n, 1 <= n) => Bits (symtype n) where \-  symtype l .&. symtype r = symtype $ pevalAndBitsTerm l r; \-  {-# INLINE (.&.) #-}; \-  symtype l .|. symtype r = symtype $ pevalOrBitsTerm l r; \-  {-# INLINE (.|.) #-}; \-  symtype l `xor` symtype r = symtype $ pevalXorBitsTerm l r; \-  {-# INLINE xor #-}; \-  complement (symtype n) = symtype $ pevalComplementBitsTerm n; \-  {-# INLINE complement #-}; \-  shift (symtype n) i | i > 0 = symtype $ pevalShiftLeftTerm n (conTerm $ fromIntegral i); \-  shift (symtype n) i | i < 0 = symtype $ pevalShiftRightTerm n (conTerm $ fromIntegral (-i)); \-  shift (symtype n) _ = symtype n; \-  {-# INLINE shift #-}; \-  rotate (symtype n) i | i > 0 = symtype $ pevalRotateLeftTerm n (conTerm $ fromIntegral i); \-  rotate (symtype n) i | i < 0 = symtype $ pevalRotateRightTerm n (conTerm $ fromIntegral (-i)); \-  rotate (symtype n) _ = symtype n; \-  {-# INLINE rotate #-}; \-  bitSize = finiteBitSize; \-  {-# INLINE bitSize #-}; \-  bitSizeMaybe = Just . finiteBitSize; \-  {-# INLINE bitSizeMaybe #-}; \-  isSigned _ = signed; \-  {-# INLINE isSigned #-}; \-  testBit (Con n) =  testBit n; \-  testBit _ = error "You cannot call testBit on symbolic variables"; \-  {-# INLINE testBit #-}; \-  bit = con . bit; \-  {-# INLINE bit #-}; \-  popCount (Con n) = popCount n; \-  popCount _ = error "You cannot call popCount on symbolic variables"; \-  {-# INLINE popCount #-}--#define BITS_BV_SOME(somety, origty, br1, uf, ur1) \-instance Bits somety where \-  (.&.) = br1 (.&.) ".&."; \-  {-# INLINE (.&.) #-}; \-  (.|.) = br1 (.|.) ".|."; \-  {-# INLINE (.|.) #-}; \-  xor = br1 xor "xor"; \-  {-# INLINE xor #-}; \-  complement = ur1 complement "complement"; \-  {-# INLINE complement #-}; \-  shift s i = ur1 (`shift` i) "shift" s; \-  {-# INLINE shift #-}; \-  rotate s i = ur1 (`rotate` i) "rotate" s; \-  {-# INLINE rotate #-}; \-  zeroBits = error ("zeroBits is not defined for " ++ show (typeRep (Proxy @somety)) ++ " as no bitwidth is known"); \-  {-# INLINE zeroBits #-}; \-  bit = error ("bit is not defined for " ++ show (typeRep (Proxy @somety)) ++ " as no bitwidth is known"); \-  {-# INLINE bit #-}; \-  setBit s i = ur1 (`setBit` i) "setBit" s; \-  {-# INLINE setBit #-}; \-  clearBit s i = ur1 (`clearBit` i) "clearBit" s; \-  {-# INLINE clearBit #-}; \-  complementBit s i = ur1 (`complementBit` i) "complementBit" s; \-  {-# INLINE complementBit #-}; \-  testBit s i = uf (`testBit` i) "testBit" s; \-  {-# INLINE testBit #-}; \-  bitSizeMaybe = Just . finiteBitSize; \-  {-# INLINE bitSizeMaybe #-}; \-  bitSize = finiteBitSize; \-  {-# INLINE bitSize #-}; \-  isSigned _ = False; \-  {-# INLINE isSigned #-}; \-  shiftL s i = ur1 (`shiftL` i) "shiftL" s; \-  {-# INLINE shiftL #-}; \-  unsafeShiftL s i = ur1 (`unsafeShiftL` i) "unsafeShiftL" s; \-  {-# INLINE unsafeShiftL #-}; \-  shiftR s i = ur1 (`shiftR` i) "shiftR" s; \-  {-# INLINE shiftR #-}; \-  unsafeShiftR s i = ur1 (`unsafeShiftR` i) "unsafeShiftR" s; \-  {-# INLINE unsafeShiftR #-}; \-  rotateL s i = ur1 (`rotateL` i) "rotateL" s; \-  {-# INLINE rotateL #-}; \-  rotateR s i = ur1 (`rotateR` i) "rotateR" s; \-  {-# INLINE rotateR #-}; \-  popCount = uf popCount "popCount"; \-  {-# INLINE popCount #-}--#if 1-BITS_BV(SymIntN, True)-BITS_BV(SymWordN, False)-BITS_BV_SOME(SomeSymIntN, SymIntN, binSomeSymIntNR1, unarySomeSymIntN, unarySomeSymIntNR1)-BITS_BV_SOME(SomeSymWordN, SymWordN, binSomeSymWordNR1, unarySomeSymWordN, unarySomeSymWordNR1)-#endif---- FiniteBits--#define FINITE_BITS_BV(symtype) \-instance (KnownNat n, 1 <= n) => FiniteBits (symtype n) where \-  finiteBitSize _ = fromIntegral $ natVal (Proxy @n); \-  {-# INLINE finiteBitSize #-}; \--#define FINITE_BITS_BV_SOME(somety, origty) \-instance FiniteBits somety where \-  finiteBitSize (somety (n :: origty n)) = fromIntegral $ natVal n; \-  {-# INLINE finiteBitSize #-}--#if 1-FINITE_BITS_BV(SymIntN)-FINITE_BITS_BV(SymWordN)-FINITE_BITS_BV_SOME(SomeSymIntN, SymIntN)-FINITE_BITS_BV_SOME(SomeSymWordN, SymWordN)-#endif---- Show--#define SHOW_SIMPLE(symtype) \-instance Show symtype where \-  show (symtype t) = pformat t--#define SHOW_BV(symtype) \-instance (KnownNat n, 1 <= n) => Show (symtype n) where \-  show (symtype t) = pformat t--#define SHOW_FUN(op, cons) \-instance (SupportedPrim ca, SupportedPrim cb, LinkedRep ca sa, LinkedRep cb sb) => Show (sa op sb) where \-  show (cons t) = pformat t--#define SHOW_BV_SOME(somety) \-instance Show somety where \-  show (somety t) = show t--#if 1-SHOW_SIMPLE(SymBool)-SHOW_SIMPLE(SymInteger)-SHOW_BV(SymIntN)-SHOW_BV(SymWordN)-SHOW_FUN(=~>, SymTabularFun)-SHOW_FUN(-~>, SymGeneralFun)-SHOW_BV_SOME(SomeSymIntN)-SHOW_BV_SOME(SomeSymWordN)-#endif---- Hashable--#define HASHABLE_SIMPLE(symtype) \-instance Hashable symtype where \-  hashWithSalt s (symtype v) = s `hashWithSalt` v--#define HASHABLE_BV(symtype) \-instance (KnownNat n, 1 <= n) => Hashable (symtype n) where \-  hashWithSalt s (symtype v) = s `hashWithSalt` v--#define HASHABLE_FUN(op, cons) \-instance (SupportedPrim ca, SupportedPrim cb, LinkedRep ca sa, LinkedRep cb sb) => Hashable (sa op sb) where \-  hashWithSalt s (cons v) = s `hashWithSalt` v--#define HASHABLE_BV_SOME(somety, origty) \-instance Hashable somety where \-  s `hashWithSalt` (somety (w :: origty n)) = s `hashWithSalt` natVal (Proxy @n) `hashWithSalt` w--#if 1-HASHABLE_SIMPLE(SymBool)-HASHABLE_SIMPLE(SymInteger)-HASHABLE_BV(SymIntN)-HASHABLE_BV(SymWordN)-HASHABLE_FUN(=~>, SymTabularFun)-HASHABLE_FUN(-~>, SymGeneralFun)-HASHABLE_BV_SOME(SomeSymIntN, SymIntN)-HASHABLE_BV_SOME(SomeSymWordN, SymWordN)-#endif---- Eq--#define EQ_SIMPLE(symtype) \-instance Eq symtype where \-  (symtype l) == (symtype r) = l == r--#define EQ_BV(symtype) \-instance (KnownNat n, 1 <= n) => Eq (symtype n) where \-  (symtype l) == (symtype r) = l == r--#define EQ_BV_SOME(symtype, bf) \-instance Eq symtype where; \-  (==) = bf (==) "=="; \-  {-# INLINE (==) #-}; \-  (/=) = bf (/=) "/="; \-  {-# INLINE (/=) #-}--#define EQ_FUN(op, cons) \-instance (SupportedPrim ca, SupportedPrim cb, LinkedRep ca sa, LinkedRep cb sb) => Eq (sa op sb) where \-  (cons l) == (cons r) = l == r--#if 1-EQ_SIMPLE(SymBool)-EQ_SIMPLE(SymInteger)-EQ_BV(SymIntN)-EQ_BV(SymWordN)-EQ_FUN(=~>, SymTabularFun)-EQ_FUN(-~>, SymGeneralFun)-EQ_BV_SOME(SomeSymIntN, binSomeSymIntN)-EQ_BV_SOME(SomeSymWordN, binSomeSymWordN)-#endif---- IsString--#define IS_STRING_SIMPLE(symtype) \-instance IsString symtype where \-  fromString = ssym . fromString--#define IS_STRING_BV(symtype) \-instance (KnownNat n, 1 <= n) => IsString (symtype n) where \-  fromString = ssym . fromString--#define IS_STRING_FUN(op, cons) \-instance (SupportedPrim ca, SupportedPrim cb, LinkedRep ca sa, LinkedRep cb sb) => IsString (sa op sb) where \-  fromString = ssym . fromString--#if 1-IS_STRING_SIMPLE(SymBool)-IS_STRING_SIMPLE(SymInteger)-IS_STRING_BV(SymIntN)-IS_STRING_BV(SymWordN)-IS_STRING_FUN(=~>, SymTabularFunc)-IS_STRING_FUN(-~>, SymGeneralFun)-#endif---- SizedBV--#define BVCONCAT_SIZED(symtype) \-sizedBVConcat :: forall l r. (KnownNat l, KnownNat r, 1 <= l, 1 <= r) => symtype l -> symtype r -> symtype (l + r); \-sizedBVConcat (symtype l) (symtype r) = \-  case (leqAddPos pl pr, knownAdd (KnownProof @l) (KnownProof @r)) of \-    (LeqProof, KnownProof) -> \-      symtype (pevalBVConcatTerm l r); \-  where; \-    pl = Proxy :: Proxy l; \-    pr = Proxy :: Proxy r--#define BVZEXT_SIZED(symtype) \-sizedBVZext :: forall l r proxy. (KnownNat l, KnownNat r, 1 <= l, KnownNat r, l <= r) => proxy r -> symtype l -> symtype r; \-sizedBVZext _ (symtype v) = \-  case leqTrans (LeqProof @1 @l) (LeqProof @l @r) of \-    LeqProof -> symtype $ pevalBVExtendTerm False (Proxy @r) v--#define BVSEXT_SIZED(symtype) \-sizedBVSext :: forall l r proxy. (KnownNat l, KnownNat r, 1 <= l, KnownNat r, l <= r) => proxy r -> symtype l -> symtype r; \-sizedBVSext _ (symtype v) = \-  case leqTrans (LeqProof @1 @l) (LeqProof @l @r) of \-    LeqProof -> symtype $ pevalBVExtendTerm True (Proxy @r) v--#define BVSELECT_SIZED(symtype) \-sizedBVSelect :: forall n ix w p q. (KnownNat n, KnownNat ix, KnownNat w, 1 <= n, 1 <= w, ix + w <= n) => \-  p ix -> q w -> symtype n -> symtype w; \-sizedBVSelect pix pw (symtype v) = symtype $ pevalBVSelectTerm pix pw v--#if 1-instance SizedBV SymIntN where-  BVCONCAT_SIZED(SymIntN)-  BVZEXT_SIZED(SymIntN)-  BVSEXT_SIZED(SymIntN)-  sizedBVExt = sizedBVSext-  BVSELECT_SIZED(SymIntN)--instance SizedBV SymWordN where-  BVCONCAT_SIZED(SymWordN)-  BVZEXT_SIZED(SymWordN)-  BVSEXT_SIZED(SymWordN)-  sizedBVExt = sizedBVZext-  BVSELECT_SIZED(SymWordN)-#endif---- BV--#define BVCONCAT(somety, origty) \-bvConcat (somety (a :: origty l)) (somety (b :: origty r)) = \-  case (leqAddPos (Proxy @l) (Proxy @r), knownAdd @l @r KnownProof KnownProof) of \-    (LeqProof, KnownProof) -> \-      somety $ sizedBVConcat a b--#define BVZEXT(somety, origty) \-bvZext l (somety (a :: origty n)) \-  | l < n = error "bvZext: trying to zero extend a value to a smaller size" \-  | otherwise = res (Proxy @n) \-  where \-    n = fromIntegral $ natVal (Proxy @n); \-    res :: forall (l :: Nat). Proxy l -> somety; \-    res p = \-      case (unsafeKnownProof @l (fromIntegral l), unsafeLeqProof @1 @l, unsafeLeqProof @n @l) of \-        (KnownProof, LeqProof, LeqProof) -> somety $ sizedBVZext p a--#define BVSEXT(somety, origty) \-bvSext l (somety (a :: origty n)) \-  | l < n = error "bvZext: trying to zero extend a value to a smaller size" \-  | otherwise = res (Proxy @n) \-  where \-    n = fromIntegral $ natVal (Proxy @n); \-    res :: forall (l :: Nat). Proxy l -> somety; \-    res p = \-      case (unsafeKnownProof @l (fromIntegral l), unsafeLeqProof @1 @l, unsafeLeqProof @n @l) of \-        (KnownProof, LeqProof, LeqProof) -> somety $ sizedBVSext p a--#define BVSELECT(somety, origty) \-bvSelect ix w (somety (a :: origty n)) \-    | ix + w > n = error "bvSelect: trying to select a bitvector outside the bounds of the input" \-    | w == 0 = error "bvSelect: trying to select a bitvector of size 0" \-    | otherwise = res (Proxy @n) (Proxy @n) \-    where \-      n = fromIntegral $ natVal (Proxy @n); \-      res :: forall (w :: Nat) (ix :: Nat). Proxy w -> Proxy ix -> somety; \-      res _ _ = \-        case ( unsafeKnownProof @ix (fromIntegral ix), \-               unsafeKnownProof @w (fromIntegral w), \-               unsafeLeqProof @1 @w, \-               unsafeLeqProof @(ix + w) @n \-             ) of \-          (KnownProof, KnownProof, LeqProof, LeqProof) -> \-            somety $ sizedBVSelect (Proxy @ix) (Proxy @w) a--#if 1-instance BV SomeSymIntN where-  BVCONCAT(SomeSymIntN, SymIntN)-  {-# INLINE bvConcat #-}-  BVZEXT(SomeSymIntN, SymIntN)-  {-# INLINE bvZext #-}-  BVSEXT(SomeSymIntN, SymIntN)-  {-# INLINE bvSext #-}-  bvExt = bvSext-  {-# INLINE bvExt #-}-  BVSELECT(SomeSymIntN, SymIntN)-  {-# INLINE bvSelect #-}--instance BV SomeSymWordN where-  BVCONCAT(SomeSymWordN, SymWordN)-  {-# INLINE bvConcat #-}-  BVZEXT(SomeSymWordN, SymWordN)-  {-# INLINE bvZext #-}-  BVSEXT(SomeSymWordN, SymWordN)-  {-# INLINE bvSext #-}-  bvExt = bvZext-  {-# INLINE bvExt #-}-  BVSELECT(SomeSymWordN, SymWordN)-  {-# INLINE bvSelect #-}-#endif---- BVSignConversion--instance (KnownNat n, 1 <= n) => SignConversion (SymWordN n) (SymIntN n) where-  toSigned (SymWordN n) = SymIntN $ pevalToSignedTerm n-  toUnsigned (SymIntN n) = SymWordN $ pevalToUnsignedTerm n--instance SignConversion SomeSymWordN SomeSymIntN where-  toSigned (SomeSymWordN n) = SomeSymIntN $ toSigned n-  toUnsigned (SomeSymIntN n) = SomeSymWordN $ toUnsigned n---- SymShift-instance (KnownNat n, 1 <= n) => SymShift (SymWordN n) where-  symShift (SymWordN a) (SymWordN s) = SymWordN $ pevalShiftLeftTerm a s--instance (KnownNat n, 1 <= n) => SymShift (SymIntN n) where-  symShift a _ | finiteBitSize a == 1 = a-  symShift as@(SymIntN a) (SymIntN s)-    | finiteBitSize as == 2 =-        SymIntN $-          pevalITETerm-            (pevalGeNumTerm s (conTerm 0))-            (pevalShiftLeftTerm a s)-            ( pevalITETerm-                (pevalEqvTerm s (conTerm (-2)))-                ( pevalITETerm-                    (pevalGeNumTerm a (conTerm 0))-                    (conTerm 0)-                    (conTerm (-1))-                )-                (pevalShiftRightTerm a (pevalUMinusNumTerm s))-            )-  symShift (SymIntN a) (SymIntN s) =-    SymIntN $-      pevalITETerm-        (pevalGeNumTerm s (conTerm 0))-        (pevalShiftLeftTerm a s)-        ( pevalITETerm-            (pevalLeNumTerm s (conTerm (-bs)))-            (pevalShiftRightTerm a (conTerm bs))-            (pevalShiftRightTerm a (pevalUMinusNumTerm s))-        )-    where-      bs = fromIntegral (finiteBitSize (0 :: IntN n)) :: IntN n---- SymRotate-instance (KnownNat n, 1 <= n) => SymRotate (SymWordN n) where-  symRotate (SymWordN a) (SymWordN s) = SymWordN (pevalRotateLeftTerm a s)--instance (KnownNat n, 1 <= n) => SymRotate (SymIntN n) where-  symRotate a _ | finiteBitSize a == 1 = a-  symRotate as@(SymIntN a) (SymIntN s)-    | finiteBitSize as == 2 =-        SymIntN $-          pevalITETerm-            ( pevalOrTerm-                (pevalEqvTerm s (conTerm 0))-                (pevalEqvTerm s (conTerm (-2)))-            )-            a-            (pevalRotateLeftTerm a (conTerm 1))-  symRotate as@(SymIntN a) (SymIntN s) =-    SymIntN $-      pevalRotateLeftTerm-        a-        ( pevalModBoundedIntegralTerm-            s-            (conTerm (fromIntegral $ finiteBitSize as))-        )---- ModelRep---- | A pair of a symbolic constant and its value.--- This is used to build a model from a list of symbolic constants and their values.------ >>> buildModel ("a" := (1 :: Integer), "b" := True) :: Model--- Model {a -> 1 :: Integer, b -> True :: Bool}-data ModelSymPair ct st where-  (:=) :: (LinkedRep ct st) => st -> ct -> ModelSymPair ct st--instance ModelRep (ModelSymPair ct st) Model where-  buildModel (sym := val) =-    case underlyingTerm sym of-      SymTerm _ symbol -> insertValue symbol val emptyModel-      _ -> error "buildModel: should only use symbolic constants"---- | Get the sum of the sizes of a list of symbolic terms.--- Duplicate sub-terms are counted for only once.------ >>> symsSize [1, "a" :: SymInteger, "a" + 1 :: SymInteger]--- 3-symsSize :: forall con sym. (LinkedRep con sym) => [sym] -> Int-symsSize = termsSize . fmap (underlyingTerm @con)-{-# INLINE symsSize #-}---- | Get the size of a symbolic term.--- Duplicate sub-terms are counted for only once.------ >>> symSize (1 :: SymInteger)--- 1--- >>> symSize ("a" :: SymInteger)--- 1--- >>> symSize ("a" + 1 :: SymInteger)--- 3--- >>> symSize (("a" + 1) * ("a" + 1) :: SymInteger)--- 4-symSize :: forall con sym. (LinkedRep con sym) => sym -> Int-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--someSymsSize :: [SomeSym] -> Int-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-allSymsSize :: (AllSyms a) => a -> Int-allSymsSize = someSymsSize . allSyms--class AllSyms' a where-  allSymsS' :: a c -> [SomeSym] -> [SomeSym]--instance (Generic a, AllSyms' (Rep a)) => AllSyms (Default a) where-  allSymsS = allSymsS' . from . unDefault--instance AllSyms' U1 where-  allSymsS' _ = id--instance (AllSyms c) => AllSyms' (K1 i c) where-  allSymsS' (K1 v) = allSymsS v--instance (AllSyms' a) => AllSyms' (M1 i c a) where-  allSymsS' (M1 v) = allSymsS' v--instance (AllSyms' a, AllSyms' b) => AllSyms' (a :+: b) where-  allSymsS' (L1 l) = allSymsS' l-  allSymsS' (R1 r) = allSymsS' r--instance (AllSyms' a, AllSyms' b) => AllSyms' (a :*: b) where-  allSymsS' (a :*: b) = allSymsS' a . allSymsS' b--#define CONCRETE_ALLSYMS(type) \-instance AllSyms type where \-  allSymsS _ = id--#define ALLSYMS_SIMPLE(t) \-instance AllSyms t where \-  allSymsS v = (SomeSym v :)--#define ALLSYMS_BV(t) \-instance (KnownNat n, 1 <= n) => AllSyms (t n) where \-  allSymsS v = (SomeSym v :)--#define ALLSYMS_SOME_BV(t) \-instance AllSyms t where \-  allSymsS (t v) = (SomeSym v :)--#define ALLSYMS_FUN(op) \-instance (SupportedPrim ca, SupportedPrim cb, LinkedRep ca sa, LinkedRep cb sb) => AllSyms (sa op sb) where \-  allSymsS v = (SomeSym v :)--#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)-ALLSYMS_SIMPLE(SymBool)-ALLSYMS_SIMPLE(SymInteger)-ALLSYMS_BV(SymIntN)-ALLSYMS_BV(SymWordN)-ALLSYMS_SOME_BV(SomeSymIntN)-ALLSYMS_SOME_BV(SomeSymWordN)-ALLSYMS_FUN(=~>)-ALLSYMS_FUN(-~>)-#endif--instance AllSyms () where-  allSymsS _ = id---- Either-deriving via-  (Default (Either a b))-  instance-    ( AllSyms a,-      AllSyms b-    ) =>-    AllSyms (Either a b)---- Maybe-deriving via (Default (Maybe a)) instance (AllSyms a) => AllSyms (Maybe a)---- List-deriving via (Default [a]) instance (AllSyms a) => AllSyms [a]---- (,)-deriving via-  (Default (a, b))-  instance-    (AllSyms a, AllSyms b) =>-    AllSyms (a, b)---- (,,)-deriving via-  (Default (a, b, c))-  instance-    ( AllSyms a,-      AllSyms b,-      AllSyms c-    ) =>-    AllSyms (a, b, c)---- (,,,)-deriving via-  (Default (a, b, c, d))-  instance-    ( AllSyms a,-      AllSyms b,-      AllSyms c,-      AllSyms d-    ) =>-    AllSyms (a, b, c, d)---- (,,,,)-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)---- (,,,,,)-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)---- (,,,,,,)-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)---- (,,,,,,,)-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)---- MaybeT-instance-  (AllSyms (m (Maybe a))) =>-  AllSyms (MaybeT m a)-  where-  allSymsS (MaybeT v) = allSymsS v---- ExceptT-instance-  (AllSyms (m (Either e a))) =>-  AllSyms (ExceptT e m a)-  where-  allSymsS (ExceptT v) = allSymsS v---- Sum-deriving via-  (Default (Sum f g a))-  instance-    (AllSyms (f a), AllSyms (g a)) =>-    AllSyms (Sum f g a)---- WriterT-instance-  (AllSyms (m (a, s))) =>-  AllSyms (WriterLazy.WriterT s m a)-  where-  allSymsS (WriterLazy.WriterT v) = allSymsS v--instance-  (AllSyms (m (a, s))) =>-  AllSyms (WriterStrict.WriterT s m a)-  where-  allSymsS (WriterStrict.WriterT v) = allSymsS v---- Identity-instance (AllSyms a) => AllSyms (Identity a) where-  allSymsS (Identity a) = allSymsS a---- IdentityT-instance (AllSyms (m a)) => AllSyms (IdentityT m a) where-  allSymsS (IdentityT a) = allSymsS a---- VerificationConditions-deriving via (Default VerificationConditions) instance AllSyms VerificationConditions---- AssertionError-deriving via (Default AssertionError) instance AllSyms AssertionError
− src/Grisette/IR/SymPrim/Data/TabularFun.hs 
@@ -1,57 +0,0 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveLift #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}---- |--- Module      :   Grisette.IR.SymPrim.Data.TabularFun--- 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.IR.SymPrim.Data.TabularFun-  ( type (=->) (..),-  )-where--import Control.DeepSeq (NFData, NFData1)-import Data.Hashable (Hashable)-import GHC.Generics (Generic, Generic1)-import Grisette.Core.Data.Class.Function (Function (Arg, Ret, (#)))-import Language.Haskell.TH.Syntax (Lift)---- $setup--- >>> import Grisette.Core--- >>> import Grisette.IR.SymPrim---- |--- Functions as a table. Use the `#` operator to apply the function.------ >>> :set -XTypeOperators--- >>> let f = TabularFun [(1, 2), (3, 4)] 0 :: Int =-> Int--- >>> f # 1--- 2--- >>> f # 2--- 0--- >>> f # 3--- 4-data (=->) a b = TabularFun {funcTable :: [(a, b)], defaultFuncValue :: b}-  deriving (Show, Eq, Generic, Generic1, Lift, NFData, NFData1)--infixr 0 =->--instance (Eq a) => Function (a =-> b) where-  type Arg (a =-> b) = a-  type Ret (a =-> b) = b-  (TabularFun table d) # a = go table-    where-      go [] = d-      go ((av, bv) : s)-        | a == av = bv-        | otherwise = go s--instance (Hashable a, Hashable b) => Hashable (a =-> b)
+ src/Grisette/Internal/Backend/QuantifiedStack.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Strict #-}++-- |+-- Module      :   Grisette.Internal.Backend.QuantifiedStack+-- 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.Backend.QuantifiedStack+  ( QuantifiedSymbols (..),+    QuantifiedStack,+    addQuantified,+    lookupQuantified,+    emptyQuantifiedSymbols,+    addQuantifiedSymbol,+    isQuantifiedSymbol,+    emptyQuantifiedStack,+  )+where++import Data.Dynamic (Dynamic)+import qualified Data.HashMap.Strict as M+import qualified Data.HashSet as S+import Data.Hashable (Hashable (hashWithSalt))+import GHC.Stack (HasCallStack)+import Grisette.Internal.SymPrim.Prim.Internal.Term+  ( IsSymbolKind,+    SomeTypedConstantSymbol,+    SomeTypedSymbol,+    SupportedPrim (castTypedSymbol),+    TypedConstantSymbol,+    TypedSymbol,+    castSomeTypedSymbol,+    someTypedSymbol,+  )++-- | A set of quantified symbols.+newtype QuantifiedSymbols = QuantifiedSymbols+  { _symbols :: S.HashSet SomeTypedConstantSymbol+  }+  deriving (Show)++-- | An empty set of quantified symbols.+emptyQuantifiedSymbols :: QuantifiedSymbols+emptyQuantifiedSymbols = QuantifiedSymbols S.empty++-- | Add a quantified symbol to the set.+addQuantifiedSymbol ::+  TypedConstantSymbol a -> QuantifiedSymbols -> QuantifiedSymbols+addQuantifiedSymbol s (QuantifiedSymbols t) =+  QuantifiedSymbols (S.insert (someTypedSymbol s) t)++-- | Check if a symbol is quantified.+isQuantifiedSymbol ::+  (SupportedPrim a, IsSymbolKind knd) =>+  TypedSymbol knd a ->+  QuantifiedSymbols ->+  Bool+isQuantifiedSymbol s (QuantifiedSymbols t) =+  case castTypedSymbol s of+    Just s' -> S.member (someTypedSymbol s') t+    _ -> False++-- | A stack of quantified symbols.+newtype QuantifiedStack = QuantifiedStack+  {_stack :: M.HashMap SomeTypedConstantSymbol Dynamic}++instance Eq QuantifiedStack where+  QuantifiedStack s1 == QuantifiedStack s2 = M.keysSet s1 == M.keysSet s2++instance Hashable QuantifiedStack where+  hashWithSalt s (QuantifiedStack t) = hashWithSalt s (M.keys t)++-- | An empty stack of quantified symbols.+emptyQuantifiedStack :: QuantifiedStack+emptyQuantifiedStack = QuantifiedStack M.empty++-- | Add a quantified symbol to the stack.+addQuantified ::+  TypedConstantSymbol a -> Dynamic -> QuantifiedStack -> QuantifiedStack+addQuantified s d (QuantifiedStack t) =+  QuantifiedStack (M.insert (someTypedSymbol s) d t)++-- | Look up a quantified symbol in the stack.+lookupQuantified ::+  (HasCallStack, IsSymbolKind knd) =>+  SomeTypedSymbol knd ->+  QuantifiedStack ->+  Maybe Dynamic+lookupQuantified s (QuantifiedStack t) =+  (`M.lookup` t) =<< castSomeTypedSymbol s
− src/Grisette/Internal/Backend/SBV.hs 
@@ -1,20 +0,0 @@--- |--- Module      :   Grisette.Internal.Backend.SBV--- 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.Backend.SBV-  ( lowerSinglePrim,-    parseModel,-    TermTy,-  )-where--import Grisette.Backend.SBV.Data.SMT.Lowering-  ( lowerSinglePrim,-    parseModel,-  )-import Grisette.Backend.SBV.Data.SMT.Solving (TermTy)
+ src/Grisette/Internal/Backend/Solving.hs view
@@ -0,0 +1,867 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Strict #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.Backend.Solving+-- 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.Backend.Solving+  ( -- * SBV backend configuration+    GrisetteSMTConfig (..),+    boolector,+    bitwuzla,+    cvc4,+    cvc5,+    yices,+    dReal,+    z3,+    mathSAT,+    abc,++    -- * Changing the extra configurations+    ExtraConfig (..),+    withTimeout,+    clearTimeout,++    -- * SBV monadic solver interface+    SBVIncrementalT,+    SBVIncremental,+    runSBVIncrementalT,+    runSBVIncremental,++    -- * SBV solver handle+    SBVSolverHandle,++    -- * Internal lowering functions+    lowerSinglePrimCached,+    lowerSinglePrim,+    parseModel,+  )+where++import Control.Concurrent.Async (Async (asyncThreadId), async, wait)+import Control.Concurrent.STM+  ( TMVar,+    atomically,+    newTMVarIO,+    putTMVar,+    takeTMVar,+    tryReadTMVar,+    tryTakeTMVar,+  )+import Control.Concurrent.STM.TChan (TChan, newTChan, readTChan, writeTChan)+import Control.Exception+  ( Exception (displayException),+    SomeException,+    handle,+    throwTo,+  )+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Reader+  ( MonadReader (ask),+    MonadTrans (lift),+    ReaderT (runReaderT),+    ask,+  )+import Control.Monad.STM (STM)+import Control.Monad.State.Strict+  ( MonadState (get, put),+    StateT,+    evalStateT,+  )+import Data.Dynamic (fromDyn, toDyn)+import qualified Data.HashSet as HS+import Data.IORef (modifyIORef', newIORef, readIORef, writeIORef)+import Data.List.NonEmpty (NonEmpty)+import Data.Proxy (Proxy (Proxy))+import qualified Data.SBV as SBV+import qualified Data.SBV.Control as SBVC+import qualified Data.SBV.Dynamic as SBVD+import qualified Data.SBV.Internals as SBVI+import qualified Data.SBV.Trans as SBVT+import qualified Data.SBV.Trans.Control as SBVTC+import qualified Data.Text as T+import GHC.IO.Exception (ExitCode (ExitSuccess))+import GHC.Stack (HasCallStack)+import Grisette.Internal.Backend.QuantifiedStack+  ( QuantifiedStack,+    QuantifiedSymbols,+    addQuantified,+    addQuantifiedSymbol,+    emptyQuantifiedStack,+    emptyQuantifiedSymbols,+    isQuantifiedSymbol,+    lookupQuantified,+  )+import Grisette.Internal.Backend.SymBiMap+  ( SymBiMap,+    addBiMap,+    addBiMapIntermediate,+    attachNextQuantifiedSymbolInfo,+    emptySymBiMap,+    findStringToSymbol,+    lookupTerm,+    sizeBiMap,+  )+import Grisette.Internal.Core.Data.Class.ModelOps+  ( ModelOps (emptyModel, insertValue),+  )+import Grisette.Internal.Core.Data.Class.Solver+  ( ConfigurableSolver (newSolver),+    MonadicSolver+      ( monadicSolverAssert,+        monadicSolverCheckSat,+        monadicSolverPop,+        monadicSolverPush,+        monadicSolverResetAssertions+      ),+    Solver+      ( solverCheckSat,+        solverForceTerminate,+        solverRunCommand,+        solverTerminate+      ),+    SolverCommand+      ( SolverAssert,+        SolverCheckSat,+        SolverPop,+        SolverPush,+        SolverResetAssertions,+        SolverTerminate+      ),+    SolvingFailure (SolvingError, Terminated, Unk, Unsat),+  )+import Grisette.Internal.Core.Data.MemoUtils (htmemo)+import Grisette.Internal.SymPrim.GeneralFun (substTerm)+import Grisette.Internal.SymPrim.Prim.Model as PM+  ( Model,+  )+import Grisette.Internal.SymPrim.Prim.SomeTerm (SomeTerm (SomeTerm))+import Grisette.Internal.SymPrim.Prim.Term+  ( PEvalApplyTerm (sbvApplyTerm),+    PEvalBVTerm (sbvBVConcatTerm, sbvBVExtendTerm, sbvBVSelectTerm),+    PEvalBitCastOrTerm (sbvBitCastOr),+    PEvalBitCastTerm (sbvBitCast),+    PEvalBitwiseTerm+      ( sbvAndBitsTerm,+        sbvComplementBitsTerm,+        sbvOrBitsTerm,+        sbvXorBitsTerm+      ),+    PEvalDivModIntegralTerm+      ( sbvDivIntegralTerm,+        sbvModIntegralTerm,+        sbvQuotIntegralTerm,+        sbvRemIntegralTerm+      ),+    PEvalFPTerm+      ( sbvFPBinaryTerm,+        sbvFPFMATerm,+        sbvFPRoundingBinaryTerm,+        sbvFPRoundingUnaryTerm,+        sbvFPTraitTerm,+        sbvFPUnaryTerm+      ),+    PEvalFloatingTerm (sbvFloatingUnaryTerm, sbvPowerTerm),+    PEvalFractionalTerm (sbvFdivTerm, sbvRecipTerm),+    PEvalFromIntegralTerm (sbvFromIntegralTerm),+    PEvalIEEEFPConvertibleTerm (sbvFromFPOrTerm, sbvToFPTerm),+    PEvalNumTerm+      ( sbvAbsNumTerm,+        sbvAddNumTerm,+        sbvMulNumTerm,+        sbvNegNumTerm,+        sbvSignumNumTerm+      ),+    PEvalOrdTerm (sbvLeOrdTerm, sbvLtOrdTerm),+    PEvalRotateTerm (sbvRotateLeftTerm, sbvRotateRightTerm),+    PEvalShiftTerm (sbvShiftLeftTerm, sbvShiftRightTerm),+    SBVFreshMonad,+    SBVRep (SBVType),+    SomeTypedSymbol (SomeTypedSymbol),+    SupportedNonFuncPrim (withNonFuncPrim),+    SupportedPrim+      ( conSBVTerm,+        funcDummyConstraint,+        parseSMTModelResult,+        sbvDistinct,+        sbvEq,+        sbvIte,+        symSBVName,+        symSBVTerm,+        withPrim+      ),+    SymbolKind (AnyKind),+    Term,+    TypedConstantSymbol,+    TypedSymbol (TypedSymbol),+    someTypedSymbol,+    symTerm,+    pattern AbsNumTerm,+    pattern AddNumTerm,+    pattern AndBitsTerm,+    pattern AndTerm,+    pattern ApplyTerm,+    pattern BVConcatTerm,+    pattern BVExtendTerm,+    pattern BVSelectTerm,+    pattern BitCastOrTerm,+    pattern BitCastTerm,+    pattern ComplementBitsTerm,+    pattern ConTerm,+    pattern DistinctTerm,+    pattern DivIntegralTerm,+    pattern EqTerm,+    pattern ExistsTerm,+    pattern FPBinaryTerm,+    pattern FPFMATerm,+    pattern FPRoundingBinaryTerm,+    pattern FPRoundingUnaryTerm,+    pattern FPTraitTerm,+    pattern FPUnaryTerm,+    pattern FdivTerm,+    pattern FloatingUnaryTerm,+    pattern ForallTerm,+    pattern FromFPOrTerm,+    pattern FromIntegralTerm,+    pattern ITETerm,+    pattern LeOrdTerm,+    pattern LtOrdTerm,+    pattern ModIntegralTerm,+    pattern MulNumTerm,+    pattern NegNumTerm,+    pattern NotTerm,+    pattern OrBitsTerm,+    pattern OrTerm,+    pattern PowerTerm,+    pattern QuotIntegralTerm,+    pattern RecipTerm,+    pattern RemIntegralTerm,+    pattern RotateLeftTerm,+    pattern RotateRightTerm,+    pattern ShiftLeftTerm,+    pattern ShiftRightTerm,+    pattern SignumNumTerm,+    pattern SupportedTerm,+    pattern SymTerm,+    pattern ToFPTerm,+    pattern XorBitsTerm,+  )+import Grisette.Internal.SymPrim.SymBool (SymBool (SymBool))++-- $setup+-- >>> import Grisette.Core+-- >>> import Grisette.SymPrim+-- >>> import Grisette.Backend+-- >>> import Data.Proxy++-- | Grisette specific extra configurations for the SBV backend.+newtype ExtraConfig = ExtraConfig+  { -- | Timeout in microseconds for each solver call. CEGIS may call the+    -- solver multiple times and each call has its own timeout.+    timeout :: Maybe Int+  }++-- | 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 = GrisetteSMTConfig+  { sbvConfig :: SBV.SMTConfig,+    extraConfig :: ExtraConfig+  }++preciseExtraConfig :: ExtraConfig+preciseExtraConfig = ExtraConfig {timeout = Nothing}++-- | Solver configuration for Boolector. <https://boolector.github.io/>+boolector :: GrisetteSMTConfig+boolector = GrisetteSMTConfig SBV.boolector preciseExtraConfig++-- | Solver configuration for Bitwuzla. <https://bitwuzla.github.io/>+bitwuzla :: GrisetteSMTConfig+bitwuzla = GrisetteSMTConfig SBV.bitwuzla preciseExtraConfig++-- | Solver configuration for CVC4. <https://cvc4.github.io/>+cvc4 :: GrisetteSMTConfig+cvc4 = GrisetteSMTConfig SBV.cvc4 preciseExtraConfig++-- | Solver configuration for CVC5. <https://cvc5.github.io/>+cvc5 :: GrisetteSMTConfig+cvc5 = GrisetteSMTConfig SBV.cvc5 preciseExtraConfig++-- | Solver configuration for Yices. <https://yices.csl.sri.com/>+yices :: GrisetteSMTConfig+yices = GrisetteSMTConfig SBV.yices preciseExtraConfig++-- | Solver configuration for DReal. <http://dreal.github.io/>+dReal :: GrisetteSMTConfig+dReal = GrisetteSMTConfig SBV.dReal preciseExtraConfig++-- | Solver configuration for Z3. <https://github.com/Z3Prover/z3/>+z3 :: GrisetteSMTConfig+z3 = GrisetteSMTConfig SBV.z3 preciseExtraConfig++-- | Solver configuration for MathSAT. <http://mathsat.fbk.eu/>+mathSAT :: GrisetteSMTConfig+mathSAT = GrisetteSMTConfig SBV.mathSAT preciseExtraConfig++-- | Solver configuration for ABC. <http://www.eecs.berkeley.edu/~alanmi/abc/>+abc :: GrisetteSMTConfig+abc = GrisetteSMTConfig SBV.abc preciseExtraConfig++-- | Set the timeout for the solver configuration.+--+-- The timeout is in microseconds (1e-6 seconds). The timeout is applied to each+-- individual solver query.+withTimeout :: Int -> GrisetteSMTConfig -> GrisetteSMTConfig+withTimeout t config =+  config {extraConfig = (extraConfig config) {timeout = Just t}}++-- | Clear the timeout for the solver configuration.+clearTimeout :: GrisetteSMTConfig -> GrisetteSMTConfig+clearTimeout config =+  config {extraConfig = (extraConfig config) {timeout = Nothing}}++sbvCheckSatResult :: SBVC.CheckSatResult -> SolvingFailure+sbvCheckSatResult SBVC.Sat = error "Should not happen"+sbvCheckSatResult (SBVC.DSat _) = error "DSat is currently not supported"+sbvCheckSatResult SBVC.Unsat = Unsat+sbvCheckSatResult SBVC.Unk = Unk++-- | Apply the timeout to the configuration.+applyTimeout ::+  (MonadIO m, SBVTC.MonadQuery m) => GrisetteSMTConfig -> m a -> m a+applyTimeout config q = case timeout (extraConfig config) of+  Nothing -> q+  Just t -> SBVTC.timeout t q++-- | Incremental solver monad transformer with the SBV backend.+type SBVIncrementalT m =+  ReaderT GrisetteSMTConfig (StateT SymBiMap (SBVTC.QueryT m))++-- | Incremental solver monad with the SBV backend.+type SBVIncremental = SBVIncrementalT IO++-- | Run the incremental solver monad with a given configuration.+runSBVIncremental :: GrisetteSMTConfig -> SBVIncremental a -> IO a+runSBVIncremental = runSBVIncrementalT++-- | Run the incremental solver monad transformer with a given configuration.+runSBVIncrementalT ::+  (SBVTC.ExtractIO m) =>+  GrisetteSMTConfig ->+  SBVIncrementalT m a ->+  m a+runSBVIncrementalT config sbvIncrementalT =+  SBVT.runSMTWith (sbvConfig config) $+    SBVTC.query $+      applyTimeout config $+        flip evalStateT emptySymBiMap $+          runReaderT sbvIncrementalT config++instance (MonadIO m) => MonadicSolver (SBVIncrementalT m) where+  monadicSolverAssert (SymBool formula) = do+    symBiMap <- get+    (newSymBiMap, lowered, dummyConstraint) <-+      lowerSinglePrimCached formula symBiMap+    lift $ lift $ SBV.constrain dummyConstraint+    lift $ lift $ SBV.constrain (lowered emptyQuantifiedStack)+    put newSymBiMap+  monadicSolverCheckSat = do+    checkSatResult <- SBVTC.checkSat+    config <- ask+    symBiMap <- get+    case checkSatResult of+      SBVC.Sat -> do+        sbvModel <- SBVTC.getModel+        let model = parseModel config sbvModel symBiMap+        return $ Right model+      r -> return $ Left $ sbvCheckSatResult r+  monadicSolverResetAssertions = SBVTC.resetAssertions+  monadicSolverPush = SBVTC.push+  monadicSolverPop = SBVTC.pop++data SBVSolverStatus = SBVSolverNormal | SBVSolverTerminated++-- | The handle type for the SBV solver.+--+-- See 'ConfigurableSolver' and 'Solver' for the interfaces.+data SBVSolverHandle = SBVSolverHandle+  { sbvSolverHandleMonad :: Async (),+    sbvSolverHandleStatus :: TMVar SBVSolverStatus,+    sbvSolverHandleInChan :: TChan SolverCommand,+    sbvSolverHandleOutChan :: TChan (Either SolvingFailure Model)+  }++setTerminated :: TMVar SBVSolverStatus -> STM ()+setTerminated status = do+  _ <- tryTakeTMVar status+  putTMVar status SBVSolverTerminated++instance ConfigurableSolver GrisetteSMTConfig SBVSolverHandle where+  newSolver config = do+    sbvSolverHandleInChan <- atomically newTChan+    sbvSolverHandleOutChan <- atomically newTChan+    sbvSolverHandleStatus <- newTMVarIO SBVSolverNormal+    sbvSolverHandleMonad <- async $ do+      let handler (e :: SomeException) =+            liftIO $+              atomically $ do+                setTerminated sbvSolverHandleStatus+                writeTChan+                  sbvSolverHandleOutChan+                  (Left (SolvingError $ T.pack $ displayException e))+      handle handler $ runSBVIncremental config $ do+        let loop = do+              nextFormula <-+                liftIO $ atomically $ readTChan sbvSolverHandleInChan+              case nextFormula of+                SolverPush n -> monadicSolverPush n >> loop+                SolverPop n -> monadicSolverPop n >> loop+                SolverTerminate -> return ()+                SolverResetAssertions -> monadicSolverResetAssertions >> loop+                SolverAssert formula -> do+                  monadicSolverAssert formula+                  loop+                SolverCheckSat -> do+                  r <- monadicSolverCheckSat+                  liftIO $ atomically $ writeTChan sbvSolverHandleOutChan r+                  loop+        loop+        liftIO $ atomically $ do+          setTerminated sbvSolverHandleStatus+          writeTChan sbvSolverHandleOutChan $ Left Terminated+    return $ SBVSolverHandle {..}++instance Solver SBVSolverHandle where+  solverRunCommand f handle@(SBVSolverHandle _ status inChan _) !command = do+    st <- liftIO $ atomically $ takeTMVar status+    case st of+      SBVSolverNormal -> do+        liftIO $ atomically $ writeTChan inChan command+        r <- f handle+        liftIO $ atomically $ do+          currStatus <- tryReadTMVar status+          case currStatus of+            Nothing -> putTMVar status SBVSolverNormal+            Just _ -> return ()+        return r+      SBVSolverTerminated -> do+        liftIO $ atomically $ setTerminated status+        return $ Left Terminated+  solverCheckSat handle =+    solverRunCommand+      ( \(SBVSolverHandle _ _ _ outChan) ->+          liftIO $ atomically $ readTChan outChan+      )+      handle+      SolverCheckSat+  solverTerminate (SBVSolverHandle thread status inChan _) = do+    liftIO $ atomically $ do+      setTerminated status+      writeTChan inChan SolverTerminate+    wait thread+  solverForceTerminate (SBVSolverHandle thread status _ outChan) = do+    liftIO $ atomically $ do+      setTerminated status+      writeTChan outChan (Left Terminated)+    throwTo (asyncThreadId thread) ExitSuccess+    wait thread++sbvForall,+  sbvExists ::+    forall t.+    (SupportedNonFuncPrim t) =>+    TypedConstantSymbol t ->+    (QuantifiedStack -> SBV.SBool) ->+    QuantifiedStack ->+    SBV.SBool+#if MIN_VERSION_sbv(10,1,0)+sbvForall sb r qst = withNonFuncPrim @t $+  SBV.quantifiedBool $+    \(SBV.Forall (a :: SBVType t)) ->+      r $ addQuantified sb (toDyn a) qst+sbvExists sb r qst = withNonFuncPrim @t $+  SBV.quantifiedBool $+    \(SBV.Exists (a :: SBVType t)) ->+      r $ addQuantified sb (toDyn a) qst+#else+sbvForall =+  error "Quantifiers are only available when you build with SBV 10.1.0 or later"+sbvExists =+  error "Quantifiers are only available when you build with SBV 10.1.0 or later"+#endif++-- | Lower a single primitive term to SBV. With an explicitly provided+-- 'SymBiMap' cache.+lowerSinglePrimCached ::+  forall t m.+  (HasCallStack, SBVFreshMonad m) =>+  Term t ->+  SymBiMap ->+  m (SymBiMap, QuantifiedStack -> SBVType t, SBV.SBool)+lowerSinglePrimCached t' m' = do+  mapState <- liftIO $ newIORef m'+  accumulatedDummyConstraints <- liftIO $ newIORef SBV.sTrue+  -- quantifiedSymbols <- liftIO $ newIORef emptyQuantifiedSymbols+  let goCached ::+        forall x.+        QuantifiedSymbols ->+        Term x ->+        m (QuantifiedStack -> SBVType x)+      goCached qs t@SupportedTerm = do+        mp <- liftIO $ readIORef mapState+        case lookupTerm (SomeTerm t) mp of+          Just x -> return (\qst -> withPrim @x $ fromDyn (x qst) undefined)+          Nothing -> goCachedImpl qs t+      goCachedImpl ::+        forall a.+        (SupportedPrim a) =>+        QuantifiedSymbols ->+        Term a ->+        m (QuantifiedStack -> SBVType a)+      goCachedImpl _ (ConTerm v) =+        return $ const $ conSBVTerm v+      goCachedImpl qs t@(SymTerm ts) = do+        if isQuantifiedSymbol ts qs+          then withPrim @a $ do+            let retDyn qst =+                  case lookupQuantified (someTypedSymbol ts) qst of+                    Just v -> v+                    Nothing ->+                      error "BUG: Symbol not found in the quantified stack"+            liftIO $+              modifyIORef' mapState $+                \m -> addBiMapIntermediate (SomeTerm t) retDyn m+            return $+              \x ->+                fromDyn+                  (retDyn x)+                  (error "BUG: Symbol not found in the quantified stack")+          else withPrim @a $ do+            m <- liftIO $ readIORef mapState+            let name = symSBVName ts (sizeBiMap m)+            g <- symSBVTerm @a name+            liftIO $+              modifyIORef' accumulatedDummyConstraints $+                \c -> c SBV..&& funcDummyConstraint @a g+            liftIO $+              modifyIORef' mapState $+                addBiMap (SomeTerm t) (toDyn g) name (someTypedSymbol ts)+            return $ const g+      goCachedImpl qs t@(ForallTerm (ts :: TypedConstantSymbol t1) v) =+        withNonFuncPrim @t1 $ do+          do+            m <- liftIO $ readIORef mapState+            let (newm, sb) =+                  attachNextQuantifiedSymbolInfo m ts+            liftIO $ writeIORef mapState newm+            let substedTerm = substTerm ts (symTerm sb) HS.empty v+            r <- goCached (addQuantifiedSymbol sb qs) substedTerm+            let ret = sbvForall sb r+            liftIO $+              modifyIORef' mapState $+                addBiMapIntermediate (SomeTerm t) (toDyn . ret)+            return ret+      goCachedImpl qs t@(ExistsTerm (ts :: TypedConstantSymbol t1) v) =+        withNonFuncPrim @t1 $ do+          do+            m <- liftIO $ readIORef mapState+            let (newm, sb) =+                  attachNextQuantifiedSymbolInfo m ts+            liftIO $ writeIORef mapState newm+            let substedTerm = substTerm ts (symTerm sb) HS.empty v+            r <- goCached (addQuantifiedSymbol sb qs) substedTerm+            let ret = sbvExists sb r+            liftIO $+              modifyIORef' mapState $+                addBiMapIntermediate (SomeTerm t) (toDyn . ret)+            return ret+      goCachedImpl qs t =+        withPrim @a $ do+          r <- goCachedIntermediate qs t+          let memoed = htmemo r+              {-# NOINLINE memoed #-}+          liftIO $+            modifyIORef' mapState $+              addBiMapIntermediate (SomeTerm t) (toDyn . memoed)+          return memoed+      goCachedIntermediate ::+        forall a.+        (SupportedPrim a) =>+        QuantifiedSymbols ->+        Term a ->+        m (QuantifiedStack -> SBVType a)+      goCachedIntermediate qs (NotTerm t) = do+        r <- goCached qs t+        return $ \qst -> SBV.sNot (r qst)+      goCachedIntermediate qs (OrTerm a b) = do+        a' <- goCached qs a+        b' <- goCached qs b+        return $ \qst -> a' qst SBV..|| b' qst+      goCachedIntermediate qs (AndTerm a b) = do+        a' <- goCached qs a+        b' <- goCached qs b+        return $ \qst -> a' qst SBV..&& b' qst+      goCachedIntermediate qs (EqTerm (a :: Term v) b) = do+        a' <- goCached qs a+        b' <- goCached qs b+        return $+          \qst -> sbvEq @v (a' qst) (b' qst)+      goCachedIntermediate+        qs+        (DistinctTerm (args :: NonEmpty (Term t0))) = do+          args' <- traverse (goCached qs) args+          return $ \qst -> sbvDistinct @t0 (fmap ($ qst) args')+      goCachedIntermediate qs (ITETerm c a b) = do+        c' <- goCached qs c+        a' <- goCached qs a+        b' <- goCached qs b+        return $ \qst -> sbvIte @a (c' qst) (a' qst) (b' qst)+      goCachedIntermediate qs (AddNumTerm a b) = do+        a' <- goCached qs a+        b' <- goCached qs b+        return $ \qst -> sbvAddNumTerm @a (a' qst) (b' qst)+      goCachedIntermediate qs (NegNumTerm a) = do+        a' <- goCached qs a+        return $ sbvNegNumTerm @a . a'+      goCachedIntermediate qs (MulNumTerm a b) = do+        a' <- goCached qs a+        b' <- goCached qs b+        return $ \qst -> sbvMulNumTerm @a (a' qst) (b' qst)+      goCachedIntermediate qs (AbsNumTerm a) = do+        a' <- goCached qs a+        return $ sbvAbsNumTerm @a . a'+      goCachedIntermediate qs (SignumNumTerm a) = do+        a' <- goCached qs a+        return $ sbvSignumNumTerm @a . a'+      goCachedIntermediate qs (LtOrdTerm (a :: Term v) b) = do+        a' <- goCached qs a+        b' <- goCached qs b+        return $ \qst -> sbvLtOrdTerm @v (a' qst) (b' qst)+      goCachedIntermediate qs (LeOrdTerm (a :: Term v) b) = do+        a' <- goCached qs a+        b' <- goCached qs b+        return $ \qst -> sbvLeOrdTerm @v (a' qst) (b' qst)+      goCachedIntermediate qs (AndBitsTerm a b) = do+        a' <- goCached qs a+        b' <- goCached qs b+        return $ \qst -> sbvAndBitsTerm @a (a' qst) (b' qst)+      goCachedIntermediate qs (OrBitsTerm a b) = do+        a' <- goCached qs a+        b' <- goCached qs b+        return $ \qst -> sbvOrBitsTerm @a (a' qst) (b' qst)+      goCachedIntermediate qs (XorBitsTerm a b) = do+        a' <- goCached qs a+        b' <- goCached qs b+        return $ \qst -> sbvXorBitsTerm @a (a' qst) (b' qst)+      goCachedIntermediate qs (ComplementBitsTerm a) = do+        a' <- goCached qs a+        return $ sbvComplementBitsTerm @a . a'+      goCachedIntermediate qs (ShiftLeftTerm a b) = do+        a' <- goCached qs a+        b' <- goCached qs b+        return $ \qst -> sbvShiftLeftTerm @a (a' qst) (b' qst)+      goCachedIntermediate qs (ShiftRightTerm a b) = do+        a' <- goCached qs a+        b' <- goCached qs b+        return $ \qst -> sbvShiftRightTerm @a (a' qst) (b' qst)+      goCachedIntermediate qs (RotateLeftTerm a b) = do+        a' <- goCached qs a+        b' <- goCached qs b+        return $ \qst -> sbvRotateLeftTerm @a (a' qst) (b' qst)+      goCachedIntermediate qs (RotateRightTerm a b) = do+        a' <- goCached qs a+        b' <- goCached qs b+        return $ \qst -> sbvRotateRightTerm @a (a' qst) (b' qst)+      goCachedIntermediate qs (ApplyTerm (f :: Term f) a) = do+        l1 <- goCached qs f+        l2 <- goCached qs a+        return $ \qst -> sbvApplyTerm @f (l1 qst) (l2 qst)+      goCachedIntermediate qs (BitCastTerm (a :: Term x)) = do+        a' <- goCached qs a+        return $ sbvBitCast @x @a . a'+      goCachedIntermediate+        qs+        (BitCastOrTerm (d :: Term a) (a :: Term x)) = do+          d' <- goCached qs d+          a' <- goCached qs a+          return $ \qst -> sbvBitCastOr @x @a (d' qst) (a' qst)+      goCachedIntermediate+        qs+        (BVConcatTerm (a :: Term (bv l)) (b :: Term (bv r))) =+          do+            a' <- goCached qs a+            b' <- goCached qs b+            return $+              \qst ->+                sbvBVConcatTerm @bv (Proxy @l) (Proxy @r) (a' qst) (b' qst)+      goCachedIntermediate+        qs+        (BVExtendTerm signed (pr :: p r) (a :: Term (bv l))) =+          do+            a' <- goCached qs a+            return $ sbvBVExtendTerm @bv (Proxy @l) pr signed . a'+      goCachedIntermediate+        qs+        (BVSelectTerm (pix :: p ix) (pw :: q w) (a :: Term (bv n))) =+          do+            a' <- goCached qs a+            return $ sbvBVSelectTerm @bv pix pw (Proxy @n) . a'+      goCachedIntermediate qs (DivIntegralTerm a b) = do+        a' <- goCached qs a+        b' <- goCached qs b+        return $ \qst -> sbvDivIntegralTerm @a (a' qst) (b' qst)+      goCachedIntermediate qs (ModIntegralTerm a b) = do+        a' <- goCached qs a+        b' <- goCached qs b+        return $ \qst -> sbvModIntegralTerm @a (a' qst) (b' qst)+      goCachedIntermediate qs (QuotIntegralTerm a b) = do+        a' <- goCached qs a+        b' <- goCached qs b+        return $ \qst -> sbvQuotIntegralTerm @a (a' qst) (b' qst)+      goCachedIntermediate qs (RemIntegralTerm a b) = do+        a' <- goCached qs a+        b' <- goCached qs b+        return $ \qst -> sbvRemIntegralTerm @a (a' qst) (b' qst)+      goCachedIntermediate qs (FPTraitTerm trait (a :: Term (fp eb sb))) = do+        a' <- goCached qs a+        return $ sbvFPTraitTerm @fp @eb @sb trait . a'+      goCachedIntermediate qs (FdivTerm a b) = do+        a <- goCached qs a+        b <- goCached qs b+        return $ \qst -> sbvFdivTerm @a (a qst) (b qst)+      goCachedIntermediate qs (RecipTerm a) = do+        a <- goCached qs a+        return $ sbvRecipTerm @a . a+      goCachedIntermediate qs (FloatingUnaryTerm op a) = do+        a <- goCached qs a+        return $ sbvFloatingUnaryTerm @a op . a+      goCachedIntermediate qs (PowerTerm a b) = do+        a <- goCached qs a+        b <- goCached qs b+        return $ \qst -> sbvPowerTerm @a (a qst) (b qst)+      goCachedIntermediate qs (FPUnaryTerm op (a :: Term (fp eb sb))) = do+        a <- goCached qs a+        return $ sbvFPUnaryTerm @fp @eb @sb op . a+      goCachedIntermediate qs (FPBinaryTerm op (a :: Term (fp eb sb)) b) = do+        a <- goCached qs a+        b <- goCached qs b+        return $ \qst -> sbvFPBinaryTerm @fp @eb @sb op (a qst) (b qst)+      goCachedIntermediate qs (FPRoundingUnaryTerm op round (a :: Term (fp eb sb))) = do+        round <- goCached qs round+        a <- goCached qs a+        return $ \qst -> sbvFPRoundingUnaryTerm @fp @eb @sb op (round qst) (a qst)+      goCachedIntermediate qs (FPRoundingBinaryTerm op round (a :: Term (fp eb sb)) b) = do+        round <- goCached qs round+        a <- goCached qs a+        b <- goCached qs b+        return $ \qst -> sbvFPRoundingBinaryTerm @fp @eb @sb op (round qst) (a qst) (b qst)+      goCachedIntermediate qs (FPFMATerm round (a :: Term (fp eb sb)) b c) = do+        round <- goCached qs round+        a <- goCached qs a+        b <- goCached qs b+        c <- goCached qs c+        return $ \qst -> sbvFPFMATerm @fp @eb @sb (round qst) (a qst) (b qst) (c qst)+      goCachedIntermediate qs (FromIntegralTerm (b :: Term b)) = do+        b <- goCached qs b+        return $ sbvFromIntegralTerm @b @a . b+      goCachedIntermediate qs (FromFPOrTerm d mode arg) = do+        d <- goCached qs d+        mode <- goCached qs mode+        arg <- goCached qs arg+        return $ \qst -> sbvFromFPOrTerm @a (d qst) (mode qst) (arg qst)+      goCachedIntermediate qs (ToFPTerm mode (arg :: Term b) _ _) = do+        mode <- goCached qs mode+        arg <- goCached qs arg+        return $ \qst -> sbvToFPTerm @b (mode qst) (arg qst)+      goCachedIntermediate _ ConTerm {} = error "Should not happen"+      goCachedIntermediate _ SymTerm {} = error "Should not happen"+      goCachedIntermediate _ ForallTerm {} = error "Should not happen"+      goCachedIntermediate _ ExistsTerm {} = error "Should not happen"+  r <- goCached emptyQuantifiedSymbols t'+  m <- liftIO $ readIORef mapState+  constraint <- liftIO $ readIORef accumulatedDummyConstraints+  return (m, r, constraint)++-- | Lower a single primitive term to SBV.+lowerSinglePrim ::+  forall a m.+  (HasCallStack, SBVFreshMonad m) =>+  Term a ->+  m (SymBiMap, QuantifiedStack -> SBVType a, SBV.SBool)+lowerSinglePrim t =+  lowerSinglePrimCached t emptySymBiMap++#if MIN_VERSION_sbv(10,3,0)+preprocessUIFuncs ::+  [(String, (Bool, ty, Either String ([([SBVD.CV], SBVD.CV)], SBVD.CV)))] ->+  Maybe [(String, ([([SBVD.CV], SBVD.CV)], SBVD.CV))]+preprocessUIFuncs =+  traverse+    (\v -> case v of+      (a, (_, _, Right c)) -> Just (a, c)+      _ -> Nothing)+#elif MIN_VERSION_sbv(10,0,0)+preprocessUIFuncs ::+  [(String, (ty, Either String ([([SBVD.CV], SBVD.CV)], SBVD.CV)))] ->+  Maybe [(String, ([([SBVD.CV], SBVD.CV)], SBVD.CV))]+preprocessUIFuncs =+  traverse+    (\v -> case v of+      (a, (_, Right c)) -> Just (a, c)+      _ -> Nothing)+#else+preprocessUIFuncs ::+  [(String, (ty, ([([SBVD.CV], SBVD.CV)], SBVD.CV)))] ->+  Maybe [(String, ([([SBVD.CV], SBVD.CV)], SBVD.CV))]+preprocessUIFuncs = Just . fmap (\(a, (_, c)) -> (a, c))+#endif++-- | Parse an SBV model to a Grisette model.+parseModel ::+  GrisetteSMTConfig ->+  SBVI.SMTModel ->+  SymBiMap ->+  PM.Model+parseModel _ model@(SBVI.SMTModel _ _ assoc origFuncs) mp =+  case preprocessUIFuncs origFuncs of+    Just funcs -> foldr goSingle emptyModel $ funcs ++ assocFuncs+    _ -> error "SBV Failed to parse model"+  where+    assocFuncs = (\(s, v) -> (s, ([], v))) <$> assoc+    goSingle :: (String, ([([SBVD.CV], SBVD.CV)], SBVD.CV)) -> PM.Model -> PM.Model+    goSingle (name, cv) m = case findStringToSymbol name mp of+      Just (SomeTypedSymbol (s@TypedSymbol {} :: TypedSymbol 'AnyKind r)) ->+        insertValue+          s+          (parseSMTModelResult 0 cv :: r)+          m+      Nothing ->+        error $+          "BUG: Please send a bug report. The model is not consistent with the "+            <> "list of symbols that have been defined. The map is "+            <> show mp+            <> ". The model is "+            <> show model
+ src/Grisette/Internal/Backend/SymBiMap.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Strict #-}++-- |+-- Module      :   Grisette.Internal.Backend.SymBiMap+-- 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.Backend.SymBiMap+  ( SymBiMap (..),+    emptySymBiMap,+    sizeBiMap,+    addBiMap,+    addBiMapIntermediate,+    findStringToSymbol,+    lookupTerm,+    attachNextQuantifiedSymbolInfo,+  )+where++import Data.Dynamic (Dynamic)+import qualified Data.HashMap.Strict as M+import GHC.Stack (HasCallStack)+import Grisette.Internal.Backend.QuantifiedStack (QuantifiedStack)+import Grisette.Internal.Core.Data.SExpr (SExpr (Atom, List, NumberAtom))+import Grisette.Internal.Core.Data.Symbol+  ( mapIdentifier,+    mapMetadata,+  )+import Grisette.Internal.SymPrim.Prim.SomeTerm+  ( SomeTerm,+  )+import Grisette.Internal.SymPrim.Prim.Term+  ( IsSymbolKind,+    SomeTypedAnySymbol,+    SomeTypedSymbol,+    TypedConstantSymbol,+    TypedSymbol (unTypedSymbol),+    castSomeTypedSymbol,+    typedConstantSymbol,+    pattern SupportedConstantTypedSymbol,+  )++-- | A bidirectional map between symbolic Grisette terms and sbv terms.+data SymBiMap = SymBiMap+  { biMapToSBV :: M.HashMap SomeTerm (QuantifiedStack -> Dynamic),+    biMapSize :: Int,+    biMapFromSBV :: M.HashMap String SomeTypedAnySymbol,+    quantifiedSymbolNum :: Int+  }++instance Show SymBiMap where+  show (SymBiMap t s f _) =+    "SymBiMap { size: "+      ++ show s+      ++ ", toSBV: "+      ++ show (M.keys t)+      ++ ", fromSBV: "+      ++ show (M.toList f)+      ++ " }"++-- | Information about a quantified symbol.+-- newtype QuantifiedSymbolInfo = QuantifiedSymbolInfo Int+--   deriving (Generic, Ord, Eq, Show, Hashable, Lift, NFData)+nextQuantifiedSymbolInfo :: SymBiMap -> (SymBiMap, SExpr -> SExpr)+nextQuantifiedSymbolInfo (SymBiMap t s f num) =+  ( SymBiMap t s f (num + 1),+    \meta ->+      List+        [ Atom "grisette-quantified",+          NumberAtom $ fromIntegral num,+          meta+        ]+  )++attachQuantifiedSymbolInfo ::+  (SExpr -> SExpr) -> TypedConstantSymbol a -> TypedConstantSymbol a+attachQuantifiedSymbolInfo info tsym@SupportedConstantTypedSymbol =+  typedConstantSymbol $+    mapIdentifier (mapMetadata info) $+      unTypedSymbol tsym+attachQuantifiedSymbolInfo _ _ = error "Should not happen"++-- | Attach the next quantified symbol info to a symbol.+attachNextQuantifiedSymbolInfo ::+  SymBiMap -> TypedConstantSymbol a -> (SymBiMap, TypedConstantSymbol a)+attachNextQuantifiedSymbolInfo m s =+  let (m', info) = nextQuantifiedSymbolInfo m+   in (m', attachQuantifiedSymbolInfo info s)++-- | An empty bidirectional map.+emptySymBiMap :: SymBiMap+emptySymBiMap = SymBiMap M.empty 0 M.empty 0++-- | The size of the bidirectional map.+sizeBiMap :: SymBiMap -> Int+sizeBiMap = biMapSize++-- | Add a new entry to the bidirectional map.+addBiMap ::+  (HasCallStack) =>+  SomeTerm ->+  Dynamic ->+  String ->+  SomeTypedSymbol knd ->+  SymBiMap ->+  SymBiMap+addBiMap s d n sb (SymBiMap t sz f num) =+  case castSomeTypedSymbol sb of+    Just sb' -> SymBiMap (M.insert s (const d) t) (sz + 1) (M.insert n sb' f) num+    _ -> error "Casting to AnySymbol, should not fail"++-- | Add a new entry to the bidirectional map for intermediate values.+addBiMapIntermediate ::+  (HasCallStack) => SomeTerm -> (QuantifiedStack -> Dynamic) -> SymBiMap -> SymBiMap+addBiMapIntermediate s d (SymBiMap t sz f num) =+  SymBiMap (M.insert s d t) (sz + 1) f num++-- | Find a symbolic Grisette term from a string.+findStringToSymbol :: (IsSymbolKind knd) => String -> SymBiMap -> Maybe (SomeTypedSymbol knd)+findStringToSymbol s (SymBiMap _ _ f _) = do+  r <- M.lookup s f+  castSomeTypedSymbol r++-- | Look up an sbv value with a symbolic Grisette term in the bidirectional+-- map.+lookupTerm :: (HasCallStack) => SomeTerm -> SymBiMap -> Maybe (QuantifiedStack -> Dynamic)+lookupTerm t m = M.lookup t (biMapToSBV m)
− src/Grisette/Internal/Core.hs 
@@ -1,37 +0,0 @@-{-# LANGUAGE Trustworthy #-}--- Disable this warning because we are re-exporting things.-{-# OPTIONS_GHC -Wno-missing-import-lists #-}---- |--- Module      :   Grisette.Internal.Core--- 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-  ( -- * The UnionBase type-    Union (..),-    ifWithLeftMost,-    ifWithStrategy,-    fullReconstruct,--    -- * The UnionMBase type-    UnionM (..),-    underlyingUnion,-    isMerged,-  )-where--import Grisette.Core.Control.Monad.UnionM-  ( UnionM (..),-    isMerged,-    underlyingUnion,-  )-import Grisette.Core.Data.Union-  ( Union (..),-    fullReconstruct,-    ifWithLeftMost,-    ifWithStrategy,-  )
+ src/Grisette/Internal/Core/Control/Exception.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE Trustworthy #-}++-- |+-- Module      :   Grisette.Internal.Core.Control.Exception+-- 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.Control.Exception+  ( -- * Predefined exceptions+    AssertionError (..),+    VerificationConditions (..),+  )+where++import Control.DeepSeq (NFData)+import GHC.Generics (Generic)++-- $setup+-- >>> import Grisette.Core+-- >>> import Grisette.Lib.Base+-- >>> import Grisette.SymPrim+-- >>> import Control.Monad.Trans.Except++-- | Assertion error.+data AssertionError = AssertionError+  deriving (Show, Eq, Ord, Generic, NFData)++-- | Verification conditions.+-- A crashed program path can terminate with either assertion violation errors or assumption violation errors.+data VerificationConditions+  = AssertionViolation+  | AssumptionViolation+  deriving (Show, Eq, Ord, Generic, NFData)
+ src/Grisette/Internal/Core/Control/Monad/CBMCExcept.hs view
@@ -0,0 +1,481 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.Core.Control.Monad.CBMCExcept+-- 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.Control.Monad.CBMCExcept+  ( -- * CBMC-like error handling+    CBMCEither (..),+    CBMCExceptT (..),+    cbmcExcept,+    mapCBMCExceptT,+    withCBMCExceptT,+    OrigExcept.MonadError (..),+  )+where++#if MIN_VERSION_base(4,18,0)+import Control.Applicative+  ( Alternative (empty, (<|>)),+  )+#else+import Control.Applicative+  ( Alternative (empty, (<|>)),+    Applicative (liftA2),+  )+#endif+import Control.DeepSeq (NFData)+import Control.Monad (MonadPlus (mplus, mzero))+import qualified Control.Monad.Except as OrigExcept+import qualified Control.Monad.Fail as Fail+import Control.Monad.Fix (MonadFix (mfix))+import Control.Monad.Trans (MonadIO (liftIO), MonadTrans (lift))+import Control.Monad.Zip (MonadZip (mzipWith))+import Data.Functor.Classes+  ( Eq1 (liftEq),+    Ord1 (liftCompare),+    Read1 (liftReadList, liftReadsPrec),+    Show1 (liftShowList, liftShowsPrec),+    compare1,+    eq1,+    readsData,+    readsPrec1,+    readsUnaryWith,+    showsPrec1,+    showsUnaryWith,+  )+import Data.Functor.Contravariant (Contravariant (contramap))+import Data.Hashable (Hashable)+import GHC.Generics (Generic, Generic1)+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 (extractSymMaybe),+  )+import Grisette.Internal.Core.Data.Class.GenSym+  ( GenSym (fresh),+    GenSymSimple (simpleFresh),+    derivedNoSpecFresh,+    derivedSameShapeSimpleFresh,+  )+import Grisette.Internal.Core.Data.Class.Mergeable+  ( Mergeable (rootStrategy),+    Mergeable1 (liftRootStrategy),+    MergingStrategy (NoStrategy, SimpleStrategy, SortedStrategy),+    rootStrategy1,+    wrapStrategy,+  )+import Grisette.Internal.Core.Data.Class.SimpleMergeable+  ( SimpleMergeable (mrgIte),+    SimpleMergeable1 (liftMrgIte),+    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), ToCon1)+import Grisette.Internal.Core.Data.Class.ToSym (ToSym (toSym), ToSym1)+import Grisette.Internal.Core.Data.Class.TryMerge+  ( TryMerge (tryMergeWithStrategy),+    tryMerge,+  )+import Language.Haskell.TH.Syntax (Lift)+import Unsafe.Coerce (unsafeCoerce)++-- | A wrapper type for 'Either'. Uses different merging strategies.+newtype CBMCEither a b = CBMCEither {runCBMCEither :: Either a b}+  deriving newtype (Eq, Eq1, Ord, Ord1, Read, Read1, Show, Show1, Functor, Applicative, Monad, Hashable, NFData)+  deriving stock (Generic, Lift)++deriving newtype instance (SymEq e, SymEq a) => SymEq (CBMCEither e a)++deriving newtype instance (EvalSym a, EvalSym b) => EvalSym (CBMCEither a b)++deriving newtype instance+  (ExtractSym a, ExtractSym b) =>+  ExtractSym (CBMCEither a b)++instance+  ( GenSymSimple a a,+    Mergeable a,+    GenSymSimple b b,+    Mergeable b+  ) =>+  GenSym (CBMCEither a b) (CBMCEither a b)++instance+  ( GenSymSimple a a,+    GenSymSimple b b+  ) =>+  GenSymSimple (CBMCEither a b) (CBMCEither a b)+  where+  simpleFresh = derivedSameShapeSimpleFresh++instance+  (GenSym () a, Mergeable a, GenSym () b, Mergeable b) =>+  GenSym () (CBMCEither a b)+  where+  fresh = derivedNoSpecFresh++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)++instance (ToCon e1 e2, ToCon a1 a2) => ToCon (CBMCEither e1 a1) (CBMCEither e2 a2) where+  toCon (CBMCEither a) = CBMCEither <$> toCon a++instance (ToCon e1 e2, ToCon a1 a2) => ToCon (CBMCEither e1 a1) (Either e2 a2) where+  toCon (CBMCEither a) = toCon a++deriving newtype instance (ToSym e1 e2, ToSym a1 a2) => ToSym (Either e1 a1) (CBMCEither e2 a2)++instance (ToSym e1 e2, ToSym a1 a2) => ToSym (CBMCEither e1 a1) (CBMCEither e2 a2) where+  toSym (CBMCEither a) = CBMCEither $ toSym a++instance (ToSym e1 e2, ToSym a1 a2) => ToSym (CBMCEither e1 a1) (Either e2 a2) where+  toSym (CBMCEither a) = toSym a++data EitherIdx idx = L idx | R deriving (Eq, Ord, Show)++instance (Mergeable e, Mergeable a) => Mergeable (CBMCEither e a) where+  rootStrategy = rootStrategy1++instance (Mergeable e) => Mergeable1 (CBMCEither e) where+  liftRootStrategy ms = case rootStrategy of+    SimpleStrategy m ->+      SortedStrategy+        ( \(CBMCEither e) -> case e of+            Left _ -> False+            Right _ -> True+        )+        ( \case+            False -> SimpleStrategy $+              \cond (CBMCEither le) (CBMCEither re) -> case (le, re) of+                (Left l, Left r) -> CBMCEither $ Left $ m cond l r+                _ -> error "impossible"+            True -> wrapStrategy ms (CBMCEither . Right) (\case (CBMCEither (Right x)) -> x; _ -> error "impossible")+        )+    NoStrategy ->+      SortedStrategy+        ( \(CBMCEither e) -> case e of+            Left _ -> False+            Right _ -> True+        )+        ( \case+            False -> NoStrategy+            True -> wrapStrategy ms (CBMCEither . Right) (\case (CBMCEither (Right x)) -> x; _ -> error "impossible")+        )+    SortedStrategy idx sub ->+      SortedStrategy+        ( \(CBMCEither e) -> case e of+            Left v -> L $ idx v+            Right _ -> R+        )+        ( \case+            L i -> wrapStrategy (sub i) (CBMCEither . Left) (\case (CBMCEither (Left x)) -> x; _ -> error "impossible")+            R -> wrapStrategy ms (CBMCEither . Right) (\case (CBMCEither (Right x)) -> x; _ -> error "impossible")+        )++cbmcEither :: forall a c b. (a -> c) -> (b -> c) -> CBMCEither a b -> c+cbmcEither l r v = either l r (unsafeCoerce v)++-- | Wrap an 'Either' value in t'CBMCExceptT'+cbmcExcept :: (Monad m) => Either e a -> CBMCExceptT e m a+cbmcExcept m = CBMCExceptT (return $ CBMCEither m)++-- | Map the error and values in a t'CBMCExceptT'+mapCBMCExceptT :: (m (Either e a) -> n (Either e' b)) -> CBMCExceptT e m a -> CBMCExceptT e' n b+mapCBMCExceptT f m = CBMCExceptT $ (unsafeCoerce . f . unsafeCoerce) (runCBMCExceptT m)++-- | Map the error in a t'CBMCExceptT'+withCBMCExceptT :: (Functor m) => (e -> e') -> CBMCExceptT e m a -> CBMCExceptT e' m a+withCBMCExceptT f = mapCBMCExceptT $ fmap $ either (Left . f) Right++-- | 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+  liftEq eq (CBMCExceptT x) (CBMCExceptT y) = liftEq (liftEq eq) x y+  {-# INLINE liftEq #-}++instance (Ord e, Ord1 m) => Ord1 (CBMCExceptT e m) where+  liftCompare comp (CBMCExceptT x) (CBMCExceptT y) =+    liftCompare (liftCompare comp) x y+  {-# INLINE liftCompare #-}++instance (Read e, Read1 m) => Read1 (CBMCExceptT e m) where+  liftReadsPrec rp rl =+    readsData $+      readsUnaryWith (liftReadsPrec rp' rl') "CBMCExceptT" CBMCExceptT+    where+      rp' = liftReadsPrec rp rl+      rl' = liftReadList rp rl++instance (Show e, Show1 m) => Show1 (CBMCExceptT e m) where+  liftShowsPrec sp sl d (CBMCExceptT m) =+    showsUnaryWith (liftShowsPrec sp' sl') "CBMCExceptT" d m+    where+      sp' = liftShowsPrec sp sl+      sl' = liftShowList sp sl++instance (Eq e, Eq1 m, Eq a) => Eq (CBMCExceptT e m a) where+  (==) = eq1++instance (Ord e, Ord1 m, Ord a) => Ord (CBMCExceptT e m a) where+  compare = compare1++instance (Read e, Read1 m, Read a) => Read (CBMCExceptT e m a) where+  readsPrec = readsPrec1++instance (Show e, Show1 m, Show a) => Show (CBMCExceptT e m a) where+  showsPrec = showsPrec1++instance (Functor m) => Functor (CBMCExceptT e m) where+  fmap f = CBMCExceptT . fmap (fmap f) . runCBMCExceptT+  {-# INLINE fmap #-}++instance (Foldable f) => Foldable (CBMCExceptT e f) where+  foldMap f (CBMCExceptT a) = foldMap (cbmcEither (const mempty) f) a+  {-# INLINE foldMap #-}++instance (Traversable f) => Traversable (CBMCExceptT e f) where+  traverse f (CBMCExceptT a) =+    CBMCExceptT <$> traverse (cbmcEither (pure . CBMCEither . Left) (fmap (CBMCEither . Right) . f)) a+  {-# INLINE traverse #-}++instance (Functor m, Monad m) => Applicative (CBMCExceptT e m) where+  pure a = CBMCExceptT $ return (CBMCEither . Right $ a)+  {-# INLINE pure #-}+  CBMCExceptT f <*> CBMCExceptT v = CBMCExceptT $ do+    mf <- f+    case mf of+      CBMCEither (Left e) -> return (CBMCEither . Left $ e)+      CBMCEither (Right k) -> do+        mv <- v+        case mv of+          CBMCEither (Left e) -> return (CBMCEither . Left $ e)+          CBMCEither (Right x) -> return (CBMCEither . Right $ k x)+  {-# INLINEABLE (<*>) #-}+  m *> k = m >> k+  {-# INLINE (*>) #-}++instance (Functor m, Monad m, Monoid e) => Alternative (CBMCExceptT e m) where+  empty = CBMCExceptT $ return (CBMCEither . Left $ mempty)+  {-# INLINE empty #-}+  CBMCExceptT mx <|> CBMCExceptT my = CBMCExceptT $ do+    ex <- mx+    case ex of+      CBMCEither (Left e) -> fmap (cbmcEither (CBMCEither . Left . mappend e) (CBMCEither . Right)) my+      CBMCEither (Right x) -> return (CBMCEither . Right $ x)+  {-# INLINEABLE (<|>) #-}++instance (Monad m) => Monad (CBMCExceptT e m) where+  m >>= k = CBMCExceptT $ do+    a <- runCBMCExceptT m+    case a of+      CBMCEither (Left e) -> return (CBMCEither $ Left e)+      CBMCEither (Right x) -> runCBMCExceptT (k x)+  {-# INLINE (>>=) #-}++instance (Fail.MonadFail m) => Fail.MonadFail (CBMCExceptT e m) where+  fail = CBMCExceptT . Fail.fail+  {-# INLINE fail #-}++instance (Monad m, Monoid e) => MonadPlus (CBMCExceptT e m) where+  mzero = CBMCExceptT $ return (CBMCEither $ Left mempty)+  {-# INLINE mzero #-}+  CBMCExceptT mx `mplus` CBMCExceptT my = CBMCExceptT $ do+    ex <- mx+    case ex of+      CBMCEither (Left e) -> fmap (cbmcEither (CBMCEither . Left . mappend e) (CBMCEither . Right)) my+      CBMCEither (Right x) -> return (CBMCEither $ Right x)+  {-# INLINEABLE mplus #-}++instance (MonadFix m) => MonadFix (CBMCExceptT e m) where+  mfix f = CBMCExceptT (mfix (runCBMCExceptT . f . cbmcEither (const bomb) id))+    where+      bomb = error "mfix (CBMCExceptT): inner computation returned Left value"+  {-# INLINE mfix #-}++instance MonadTrans (CBMCExceptT e) where+  lift = CBMCExceptT . fmap (CBMCEither . Right)+  {-# INLINE lift #-}++instance (MonadIO m) => MonadIO (CBMCExceptT e m) where+  liftIO = lift . liftIO+  {-# INLINE liftIO #-}++instance (MonadZip m) => MonadZip (CBMCExceptT e m) where+  mzipWith f (CBMCExceptT a) (CBMCExceptT b) = CBMCExceptT $ mzipWith (liftA2 f) a b+  {-# INLINE mzipWith #-}++instance (Contravariant m) => Contravariant (CBMCExceptT e m) where+  contramap f = CBMCExceptT . contramap (fmap f) . runCBMCExceptT+  {-# INLINE contramap #-}++throwE :: (Monad m) => e -> CBMCExceptT e m a+throwE = CBMCExceptT . return . CBMCEither . Left+{-# INLINE throwE #-}++catchE ::+  (Monad m) =>+  CBMCExceptT e m a ->+  (e -> CBMCExceptT e' m a) ->+  CBMCExceptT e' m a+m `catchE` h = CBMCExceptT $ do+  a <- runCBMCExceptT m+  case a of+    CBMCEither (Left l) -> runCBMCExceptT (h l)+    CBMCEither (Right r) -> return (CBMCEither . Right $ r)+{-# INLINE catchE #-}++instance (Monad m) => OrigExcept.MonadError e (CBMCExceptT e m) where+  throwError = throwE+  {-# INLINE throwError #-}+  catchError = catchE+  {-# INLINE catchError #-}++instance (SymEq (m (CBMCEither e a))) => SymEq (CBMCExceptT e m a) where+  (CBMCExceptT a) .== (CBMCExceptT b) = a .== b+  {-# INLINE (.==) #-}++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+  (ExtractSym (m (CBMCEither e a))) =>+  ExtractSym (CBMCExceptT e m a)+  where+  extractSymMaybe (CBMCExceptT v) = extractSymMaybe v++instance+  (Mergeable1 m, Mergeable e, Mergeable a) =>+  Mergeable (CBMCExceptT e m a)+  where+  rootStrategy = wrapStrategy rootStrategy1 CBMCExceptT runCBMCExceptT+  {-# INLINE rootStrategy #-}++instance (Mergeable1 m, Mergeable e) => Mergeable1 (CBMCExceptT e m) where+  liftRootStrategy m = wrapStrategy (liftRootStrategy (liftRootStrategy m)) CBMCExceptT runCBMCExceptT+  {-# INLINE liftRootStrategy #-}++instance+  {-# OVERLAPPABLE #-}+  ( GenSym spec (m (CBMCEither a b)),+    Mergeable1 m,+    Mergeable a,+    Mergeable b+  ) =>+  GenSym spec (CBMCExceptT a m b)+  where+  fresh v = do+    x <- fresh v+    return $ tryMerge . fmap CBMCExceptT $ x++instance+  {-# OVERLAPPABLE #-}+  (GenSymSimple spec (m (CBMCEither a b))) =>+  GenSymSimple spec (CBMCExceptT a m b)+  where+  simpleFresh v = CBMCExceptT <$> simpleFresh v++instance+  {-# OVERLAPPING #-}+  (GenSymSimple (m (CBMCEither e a)) (m (CBMCEither e a))) =>+  GenSymSimple (CBMCExceptT e m a) (CBMCExceptT e m a)+  where+  simpleFresh (CBMCExceptT v) = CBMCExceptT <$> simpleFresh v++instance+  {-# OVERLAPPING #-}+  ( GenSymSimple (m (CBMCEither e a)) (m (CBMCEither e a)),+    Mergeable1 m,+    Mergeable e,+    Mergeable a+  ) =>+  GenSym (CBMCExceptT e m a) (CBMCExceptT e m a)++instance+  (SymBranching m, Mergeable e, Mergeable a) =>+  SimpleMergeable (CBMCExceptT e m a)+  where+  mrgIte = mrgIf+  {-# INLINE mrgIte #-}++instance+  (SymBranching m, Mergeable e) =>+  SimpleMergeable1 (CBMCExceptT e m)+  where+  liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m)+  {-# INLINE liftMrgIte #-}++instance+  (TryMerge m, Mergeable e) =>+  TryMerge (CBMCExceptT e m)+  where+  tryMergeWithStrategy s (CBMCExceptT v) = CBMCExceptT $ tryMergeWithStrategy (liftRootStrategy s) v+  {-# INLINE tryMergeWithStrategy #-}++instance+  (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 (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+  (CBMCExceptT l) .> (CBMCExceptT r) = l .> r+  symCompare (CBMCExceptT l) (CBMCExceptT r) = symCompare l r++instance+  (ToCon1 m1 m2, ToCon e1 e2, ToCon a b) =>+  ToCon (CBMCExceptT e1 m1 a) (CBMCExceptT e2 m2 b)+  where+  toCon (CBMCExceptT v) = CBMCExceptT <$> toCon v++instance+  (ToCon (m1 (CBMCEither e1 a)) (Either e2 b)) =>+  ToCon (CBMCExceptT e1 m1 a) (Either e2 b)+  where+  toCon (CBMCExceptT v) = toCon v++instance+  (ToSym e1 e2, ToSym a b, ToSym1 m1 m2) =>+  ToSym (CBMCExceptT e1 m1 a) (CBMCExceptT e2 m2 b)+  where+  toSym (CBMCExceptT v) = CBMCExceptT $ toSym v++instance+  (Monad u, TryMerge u, Mergeable e, Mergeable v) =>+  UnionWithExcept (CBMCExceptT e u v) u e v+  where+  extractUnionExcept = tryMerge . fmap runCBMCEither . runCBMCExceptT++instance UnionWithExcept (Union (CBMCEither e v)) Union e v where+  extractUnionExcept = fmap runCBMCEither
+ src/Grisette/Internal/Core/Control/Monad/Class/Union.hs view
@@ -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)
+ src/Grisette/Internal/Core/Control/Monad/Union.hs view
@@ -0,0 +1,23 @@+{-# OPTIONS_GHC -Wno-missing-import-lists #-}++-- |+-- Module      :   Grisette.Internal.Core.Control.Monad.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.Union+  ( -- * Union and helpers+    Union (..),+    UnionKey,+    unionUnaryOp,+    unionBinOp,+    isMerged,+    unionSize,+  )+where++import Grisette.Internal.Internal.Decl.Core.Control.Monad.Union+import Grisette.Internal.Internal.Impl.Core.Control.Monad.Union
+ src/Grisette/Internal/Core/Data/Class/AsKey.hs view
@@ -0,0 +1,441 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Grisette.Internal.Core.Data.Class.AsKey+  ( KeyEq (..),+    KeyOrd (..),+    KeyHashable (..),+    KeyEq1 (..),+    KeyOrd1 (..),+    KeyHashable1 (..),+    AsKey (..),+    AsKey1 (..),+    shouldUseAsKeyError,+    shouldUseAsKeyHasSymbolicVersionError,+    shouldUseSymbolicVersionError,+  )+where++import Control.DeepSeq (NFData, NFData1)+import Control.Monad.Identity (Identity)+import qualified Data.Binary as Binary+import Data.Bits (Bits, FiniteBits)+import qualified Data.Bytes.Serial as Serial+import Data.Functor.Classes+  ( Eq1 (liftEq),+    Ord1 (liftCompare),+    Show1,+    compare1,+    eq1,+  )+import Data.Hashable (Hashable (hashWithSalt))+import Data.Hashable.Lifted (Hashable1 (liftHashWithSalt), hashWithSalt1)+import Data.Proxy (Proxy (Proxy))+import qualified Data.Serialize as Cereal+import Data.String (IsString)+import GHC.Stack (HasCallStack)+import GHC.TypeLits (KnownNat, type (<=))+import Grisette.Internal.Core.Data.Class.BitCast+  ( BitCast (bitCast),+    BitCastCanonical (bitCastCanonicalValue),+  )+import Grisette.Internal.Core.Data.Class.BitVector+  ( BV (bv, bvConcat, bvExt, bvSelect, bvSext, bvZext),+  )+import Grisette.Internal.Core.Data.Class.Concrete (Concrete)+import Grisette.Internal.Core.Data.Class.Function+  ( Apply (FunType, apply),+    Function ((#)),+  )+import Grisette.Internal.Core.Data.Class.IEEEFP+  ( IEEEFPConstants+      ( fpMaxNormalized,+        fpMaxSubnormal,+        fpMinNormalized,+        fpMinSubnormal,+        fpNaN,+        fpNegativeInfinite,+        fpNegativeZero,+        fpPositiveInfinite,+        fpPositiveZero+      ),+    IEEEFPConvertible (fromFPOr, toFP),+    IEEEFPOp+      ( fpAbs,+        fpMaximum,+        fpMaximumNumber,+        fpMinimum,+        fpMinimumNumber,+        fpNeg,+        fpRem+      ),+    IEEEFPRoundingMode (rna, rne, rtn, rtp, rtz),+    IEEEFPRoundingOp+      ( fpAdd,+        fpDiv,+        fpFMA,+        fpMul,+        fpRoundToIntegral,+        fpSqrt,+        fpSub+      ),+    IEEEFPToAlgReal (fpToAlgReal),+  )+import Grisette.Internal.Core.Data.Class.SignConversion+  ( SignConversion (toSigned, toUnsigned),+  )+import Grisette.Internal.SymPrim.AlgReal (AlgReal)+import Grisette.Internal.SymPrim.BV (IntN, WordN)+import Grisette.Internal.SymPrim.FP (FP, ValidFP)+import Grisette.Internal.SymPrim.Prim.Internal.Term (ConRep (ConType))+import Language.Haskell.TH.Syntax (Lift)++-- | Type class for identity equality for terms.+class KeyEq a where+  keyEq :: a -> a -> Bool++infix 4 `keyEq`++instance (KnownNat n, 1 <= n) => KeyEq (WordN n) where+  keyEq = (==)++instance (KnownNat n, 1 <= n) => KeyEq (IntN n) where+  keyEq = (==)++instance KeyEq Integer where+  keyEq = (==)++instance KeyEq Bool where+  keyEq = (==)++instance KeyEq AlgReal where+  keyEq = (==)++instance (ValidFP a b) => KeyEq (FP a b) where+  keyEq = (==)++instance (Eq a) => KeyEq (Identity a) where+  keyEq = (==)++-- | Type class for comparing terms based on their identity.+class (KeyEq a) => KeyOrd a where+  keyCompare :: a -> a -> Ordering++infix 4 `keyCompare`++-- | Type class for hashing terms based on their identity.+class (KeyEq a) => KeyHashable a where+  keyHashWithSalt :: Int -> a -> Int++instance (KnownNat n, 1 <= n) => KeyHashable (WordN n) where+  keyHashWithSalt = hashWithSalt++instance (KnownNat n, 1 <= n) => KeyHashable (IntN n) where+  keyHashWithSalt = hashWithSalt++instance KeyHashable Integer where+  keyHashWithSalt = hashWithSalt++instance KeyHashable Bool where+  keyHashWithSalt = hashWithSalt++instance KeyHashable AlgReal where+  keyHashWithSalt = hashWithSalt++instance (ValidFP a b) => KeyHashable (FP a b) where+  keyHashWithSalt = hashWithSalt++instance (Eq a, Hashable a) => KeyHashable (Identity a) where+  keyHashWithSalt = hashWithSalt++class KeyEq1 f where+  liftKeyEq :: (a -> b -> Bool) -> f a -> f b -> Bool++class (KeyEq1 f) => KeyOrd1 f where+  liftKeyCompare :: (a -> b -> Ordering) -> f a -> f b -> Ordering++class (KeyEq1 f) => KeyHashable1 f where+  liftKeyHashWithSalt :: (Int -> a -> Int) -> Int -> f a -> Int++infixl 0 `keyHashWithSalt`++-- | Use a term as a key with identity equality.+--+-- For example, @t'AsKey' t'Grisette.SymPrim.SymBool'@ uses the term identity+-- for t'Grisette.SymPrim.SymBool'.+newtype AsKey a = AsKey {getAsKey :: a}+  deriving newtype+    ( Binary.Binary,+      Cereal.Serialize,+      NFData,+      IsString,+      Show,+      Num,+      Bits,+      FiniteBits,+      Enum,+      Bounded,+      Fractional,+      Floating+    )+  deriving stock (Functor, Lift)++-- | Use a union as a key with identity equality.+--+-- For example, @t'AsKey1' t'Grisette.Core.Union'@ uses the term identity+-- for t'Grisette.Core.Union'.+newtype AsKey1 f a = AsKey1 {getAsKey1 :: f a}+  deriving newtype+    ( Binary.Binary,+      Cereal.Serialize,+      IsString,+      Show,+      Show1,+      Functor,+      NFData,+      NFData1,+      Applicative,+      Monad,+      Num+    )+  deriving stock (Lift)++instance (Serial.Serial a) => Serial.Serial (AsKey a) where+  serialize = Serial.serialize . getAsKey+  deserialize = AsKey <$> Serial.deserialize++instance (Serial.Serial a, Serial.Serial1 f) => Serial.Serial (AsKey1 f a) where+  serialize = Serial.serialize1 . getAsKey1+  deserialize = AsKey1 <$> Serial.deserialize1++instance (KeyEq a) => Eq (AsKey a) where+  (AsKey a) == (AsKey b) = keyEq a b++instance (KeyEq1 f, Eq a) => Eq (AsKey1 f a) where+  (==) = eq1++instance (KeyEq1 f) => Eq1 (AsKey1 f) where+  liftEq f (AsKey1 a) (AsKey1 b) = liftKeyEq f a b++instance (KeyOrd a) => Ord (AsKey a) where+  compare (AsKey a) (AsKey b) = keyCompare a b++instance (KeyHashable a) => Hashable (AsKey a) where+  hashWithSalt salt = keyHashWithSalt salt . getAsKey++instance (KeyOrd1 f, Ord a) => Ord (AsKey1 f a) where+  compare = compare1++instance (KeyOrd1 f) => Ord1 (AsKey1 f) where+  liftCompare f (AsKey1 a) (AsKey1 b) = liftKeyCompare f a b++instance (KeyHashable1 f, Hashable a) => Hashable (AsKey1 f a) where+  hashWithSalt = hashWithSalt1++instance (KeyHashable1 f) => Hashable1 (AsKey1 f) where+  liftHashWithSalt f salt (AsKey1 a) = liftKeyHashWithSalt f salt a++shouldUseAsKeyError :: (HasCallStack) => String -> String -> a+shouldUseAsKeyError typ op =+  error $+    "As "+      <> typ+      <> " is a symbolic type, "+      <> op+      <> " is likely not going to work as expected.\n"+      <> "You should use AsKey if you do want term identity based "+      <> op+      <> " on "+      <> typ+      <> "."++shouldUseAsKeyHasSymbolicVersionError ::+  (HasCallStack) => String -> String -> String -> a+shouldUseAsKeyHasSymbolicVersionError typ op symop =+  error $+    "As "+      <> typ+      <> " is a symbolic type, "+      <> op+      <> " is likely not going to work as expected.\n"+      <> "You should use AsKey if you do want term identity based "+      <> op+      <> " on "+      <> typ+      <> ",\n or use "+      <> symop+      <> " instead if you want symbolic version of "+      <> op+      <> "."++shouldUseSymbolicVersionError ::+  (HasCallStack) => String -> String -> String -> a+shouldUseSymbolicVersionError typ op symop =+  error $+    "As "+      <> typ+      <> " is a symbolic type, "+      <> op+      <> " is likely not going to work as expected.\n"+      <> "You should use "+      <> symop+      <> " instead if you want symbolic version of "+      <> op+      <> "."++instance (Function a arg res) => Function (AsKey a) arg res where+  (AsKey a) # b = a # b++instance+  (Function (f a) arg (f res)) =>+  Function (AsKey1 f a) arg (AsKey1 f res)+  where+  (AsKey1 f) # b = AsKey1 $ f # b++instance (Apply a) => Apply (AsKey a) where+  type FunType (AsKey a) = FunType a+  apply (AsKey a) = apply a++instance (ConRep a) => ConRep (AsKey a) where+  type ConType (AsKey a) = ConType a++instance {-# INCOHERENT #-} (BitCast a b) => BitCast (AsKey a) (AsKey b) where+  bitCast (AsKey a) = AsKey $ bitCast a+  {-# INLINE bitCast #-}++instance {-# INCOHERENT #-} (BitCast a b) => BitCast a (AsKey b) where+  bitCast a = AsKey $ bitCast a+  {-# INLINE bitCast #-}++instance {-# INCOHERENT #-} (BitCast a b) => BitCast (AsKey a) b where+  bitCast (AsKey a) = bitCast a+  {-# INLINE bitCast #-}++instance+  {-# INCOHERENT #-}+  (BitCastCanonical a b) =>+  BitCastCanonical (AsKey a) (AsKey b)+  where+  bitCastCanonicalValue _ = AsKey $ bitCastCanonicalValue (Proxy @a)++instance+  {-# INCOHERENT #-}+  (BitCastCanonical a b) =>+  BitCastCanonical (AsKey a) b+  where+  bitCastCanonicalValue _ = bitCastCanonicalValue (Proxy @a)++instance+  {-# INCOHERENT #-}+  (BitCastCanonical a b) =>+  BitCastCanonical a (AsKey b)+  where+  bitCastCanonicalValue p = AsKey $ bitCastCanonicalValue p++instance (SignConversion a b) => SignConversion (AsKey a) (AsKey b) where+  toSigned (AsKey a) = AsKey $ toSigned a+  toUnsigned (AsKey a) = AsKey $ toUnsigned a++instance (IEEEFPConstants a) => IEEEFPConstants (AsKey a) where+  fpPositiveInfinite = AsKey fpPositiveInfinite+  fpNegativeInfinite = AsKey fpNegativeInfinite+  fpNaN = AsKey fpNaN+  fpNegativeZero = AsKey fpNegativeZero+  fpPositiveZero = AsKey fpPositiveZero+  fpMinNormalized = AsKey fpMinNormalized+  fpMinSubnormal = AsKey fpMinSubnormal+  fpMaxNormalized = AsKey fpMaxNormalized+  fpMaxSubnormal = AsKey fpMaxSubnormal++instance (IEEEFPOp a) => IEEEFPOp (AsKey a) where+  fpAbs (AsKey a) = AsKey $ fpAbs a+  fpNeg (AsKey a) = AsKey $ fpNeg a+  fpRem (AsKey a) (AsKey b) = AsKey $ fpRem a b+  fpMinimum (AsKey a) (AsKey b) = AsKey $ fpMinimum a b+  fpMaximum (AsKey a) (AsKey b) = AsKey $ fpMaximum a b+  fpMinimumNumber (AsKey a) (AsKey b) = AsKey $ fpMinimumNumber a b+  fpMaximumNumber (AsKey a) (AsKey b) = AsKey $ fpMaximumNumber a b++instance (IEEEFPRoundingMode a) => IEEEFPRoundingMode (AsKey a) where+  rne = AsKey rne+  rna = AsKey rna+  rtp = AsKey rtp+  rtn = AsKey rtn+  rtz = AsKey rtz++instance+  (IEEEFPRoundingOp a mode) =>+  IEEEFPRoundingOp (AsKey a) (AsKey mode)+  where+  fpAdd (AsKey mode) (AsKey a) (AsKey b) = AsKey $ fpAdd mode a b+  fpSub (AsKey mode) (AsKey a) (AsKey b) = AsKey $ fpSub mode a b+  fpMul (AsKey mode) (AsKey a) (AsKey b) = AsKey $ fpMul mode a b+  fpDiv (AsKey mode) (AsKey a) (AsKey b) = AsKey $ fpDiv mode a b+  fpFMA (AsKey mode) (AsKey a) (AsKey b) (AsKey c) = AsKey $ fpFMA mode a b c+  fpSqrt (AsKey mode) (AsKey a) = AsKey $ fpSqrt mode a+  fpRoundToIntegral (AsKey mode) (AsKey a) = AsKey $ fpRoundToIntegral mode a++instance+  {-# INCOHERENT #-}+  (IEEEFPConvertible a fp mode) =>+  IEEEFPConvertible (AsKey a) (AsKey fp) (AsKey mode)+  where+  fromFPOr (AsKey d) (AsKey mode) (AsKey fp) = AsKey $ fromFPOr d mode fp+  toFP (AsKey mode) (AsKey a) = AsKey $ toFP mode a++instance+  {-# INCOHERENT #-}+  (IEEEFPConvertible a fp mode) =>+  IEEEFPConvertible a (AsKey fp) (AsKey mode)+  where+  fromFPOr a (AsKey mode) (AsKey fp) = fromFPOr a mode fp+  toFP (AsKey mode) a = AsKey $ toFP mode a++instance+  {-# INCOHERENT #-}+  (IEEEFPConvertible a fp mode) =>+  IEEEFPConvertible (AsKey a) fp mode+  where+  fromFPOr (AsKey a) mode fp = AsKey $ fromFPOr a mode fp+  toFP mode (AsKey a) = toFP mode a++instance+  {-# INCOHERENT #-}+  (IEEEFPToAlgReal a fp mode) =>+  IEEEFPToAlgReal (AsKey a) (AsKey fp) (AsKey mode)+  where+  fpToAlgReal (AsKey d) (AsKey fp) = AsKey $ fpToAlgReal d fp++instance+  {-# INCOHERENT #-}+  (IEEEFPToAlgReal a fp mode) =>+  IEEEFPToAlgReal a (AsKey fp) (AsKey mode)+  where+  fpToAlgReal a (AsKey fp) = fpToAlgReal a fp++instance+  {-# INCOHERENT #-}+  (IEEEFPToAlgReal a fp mode) =>+  IEEEFPToAlgReal (AsKey a) fp mode+  where+  fpToAlgReal (AsKey d) fp = AsKey $ fpToAlgReal d fp++instance Concrete (AsKey a)++instance (BV a) => BV (AsKey a) where+  bvConcat (AsKey a) (AsKey b) = AsKey $ bvConcat a b+  bvZext n (AsKey a) = AsKey $ bvZext n a+  bvSext n (AsKey a) = AsKey $ bvSext n a+  bvExt n (AsKey a) = AsKey $ bvExt n a+  bvSelect ix w (AsKey a) = AsKey $ bvSelect ix w a+  bv n a = AsKey $ bv n a
+ src/Grisette/Internal/Core/Data/Class/BitCast.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# 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 (..),+    BitCastCanonical (..),+    BitCastOr (..),+    bitCastOrCanonical,+    BitCastOrCanonical,+  )+where++import Control.Monad.ST (ST, runST)+import Data.Array.ST (MArray (newArray), STUArray, readArray)+import Data.Array.Unsafe (castSTUArray)+import Data.Int (Int32, Int64)+import Data.Word (Word32, Word64)++-- | Type class for bit-casting between types.+--+-- __Special Considerations for Floating-Point Types:__+--+-- Typically, bit-casting a value from type @a@ to type @b@ and then back to+-- type @a@ should result in the original value. However, this is not always+-- true for floating-point values. In SMT-LIB2, there is only one NaN value with+-- multiple bit representations.+--+-- Given this, we do not provide 'BitCast' for the t'Grisette.SymPrim.FP' type,+-- instead, we use the 'bitCastOrCanonical' function to use a canonical+-- representation for the NaN values.+--+-- If your application requires distinguishing between different NaN values,+-- it is recommended to define your own floating-point type using bit-vectors.+-- This allows you to check for NaN values and perform operations by bitcasting+-- back to the provided floating-point types when they are not NaN values.+class BitCast from to where+  bitCast :: from -> to++#define BITCAST_WITH_MARRAY(from, to) \+instance BitCast from to where \+  bitCast x = runST $ bitcastWithMArray x; \+  {-# INLINE bitCast #-}++#if 1+BITCAST_WITH_MARRAY(Int64, Double)+BITCAST_WITH_MARRAY(Double, Int64)+BITCAST_WITH_MARRAY(Word64, Double)+BITCAST_WITH_MARRAY(Double, Word64)+BITCAST_WITH_MARRAY(Word64, Int64)+BITCAST_WITH_MARRAY(Int64, Word64)+BITCAST_WITH_MARRAY(Int32, Float)+BITCAST_WITH_MARRAY(Float, Int32)+BITCAST_WITH_MARRAY(Word32, Float)+BITCAST_WITH_MARRAY(Float, Word32)+BITCAST_WITH_MARRAY(Word32, Int32)+BITCAST_WITH_MARRAY(Int32, Word32)+#endif++{-# INLINE bitcastWithMArray #-}+bitcastWithMArray ::+  ( MArray (STUArray s) a (ST s),+    MArray (STUArray s) b (ST s)+  ) =>+  a ->+  ST s b+bitcastWithMArray x =+  newArray (0 :: Int, 0) x >>= castSTUArray >>= flip readArray 0++-- | The canonical value when the bitcast cannot be precisely performed.+--+-- For example, with SMT-LIB2, there is only one NaN for floating point numbers,+-- with multiple bit representations. Our underlying t'Grisette.SymPrim.FP' type+-- also follows this convention. This means that we cannot precisely bitcast a+-- t'Grisette.SymPrim.FP' to other types. So instead, we bitcast the NaN value+-- to a canonical representation, defined with this type class.+class BitCastCanonical from to where+  bitCastCanonicalValue :: proxy from -> to++-- | Bitcasting a value. If the value cannot be precisely bitcast, use the+-- default value.+class BitCastOr from to where+  bitCastOr :: to -> from -> to++-- | Constraint for bitcasting a value and when the value cannot be precisely+-- bitcast, use the canonical value.+type BitCastOrCanonical a b = (BitCastCanonical a b, BitCastOr a b)++-- | Bitcasting a value and when the value cannot be precisely bitcast, use the+-- canonical value.+bitCastOrCanonical :: (BitCastOrCanonical from to) => from -> to+bitCastOrCanonical x = bitCastOr (bitCastCanonicalValue [x]) x
+ src/Grisette/Internal/Core/Data/Class/BitVector.hs view
@@ -0,0 +1,249 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++-- |+-- Module      :   Grisette.Internal.Core.Data.Class.BitVector+-- 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.BitVector+  ( -- * Bit vector operations+    BV (..),+    bvExtract,+    SizedBV (..),+    sizedBVExtract,+  )+where++import Data.Proxy (Proxy (Proxy))+import GHC.TypeNats (KnownNat, type (+), type (-), type (<=))+import Grisette.Internal.Utils.Parameterized+  ( KnownProof (KnownProof),+    LeqProof (LeqProof),+    addNat,+    hasRepr,+    natRepr,+    subNat,+    unsafeLeqProof,+  )++-- $setup+-- >>> import Grisette.Core+-- >>> import Grisette.SymPrim+-- >>> import Grisette.Utils++-- | Bit vector operations. Including concatenation ('bvConcat'),+-- extension ('bvZext', 'bvSext', 'bvExt'), and selection+-- ('bvSelect').+class BV bv where+  -- | Concatenation of two bit vectors.+  --+  -- >>> bvConcat (SomeSymWordN (0b101 :: SymWordN 3)) (SomeSymWordN (0b010 :: SymWordN 3))+  -- 0b101010+  bvConcat :: bv -> bv -> bv++  -- | Zero extension of a bit vector.+  --+  -- >>> bvZext 6 (SomeSymWordN (0b101 :: SymWordN 3))+  -- 0b000101+  bvZext ::+    -- | Desired output length+    Int ->+    -- | Bit vector to extend+    bv ->+    bv++  -- | Sign extension of a bit vector.+  --+  -- >>> bvSext 6 (SomeSymWordN (0b101 :: SymWordN 3))+  -- 0b111101+  bvSext ::+    -- | Desired output length+    Int ->+    -- | Bit vector to extend+    bv ->+    bv++  -- | Extension of a bit vector.+  -- Signedness is determined by the input bit vector type.+  --+  -- >>> bvExt 6 (SomeSymIntN (0b101 :: SymIntN 3))+  -- 0b111101+  -- >>> bvExt 6 (SomeSymIntN (0b001 :: SymIntN 3))+  -- 0b000001+  -- >>> bvExt 6 (SomeSymWordN (0b101 :: SymWordN 3))+  -- 0b000101+  -- >>> bvExt 6 (SomeSymWordN (0b001 :: SymWordN 3))+  -- 0b000001+  bvExt ::+    -- | Desired output length+    Int ->+    -- | Bit vector to extend+    bv ->+    bv++  -- | Slicing out a smaller bit vector from a larger one,+  -- selecting a slice with width @w@ starting from index @ix@.+  --+  -- The least significant bit is indexed as 0.+  --+  -- >>> bvSelect 1 3 (SomeSymIntN (0b001010 :: SymIntN 6))+  -- 0b101+  bvSelect ::+    -- | Index of the least significant bit of the slice+    Int ->+    -- | Desired output width, @ix + w <= n@ must hold where @n@ is+    -- the size of the input bit vector+    Int ->+    -- | Bit vector to select from+    bv ->+    bv++  -- | Create a bit vector from an integer. The bit-width is the first argument,+  -- which should not be zero.+  --+  -- >>> bv 12 21 :: SomeSymIntN+  -- 0x015+  bv ::+    (Integral a) =>+    -- | Bit width+    Int ->+    -- | Integral value+    a ->+    bv++-- | Slicing out a smaller bit vector from a larger one, extract a slice from+-- bit @i@ down to @j@.+--+-- The least significant bit is indexed as 0.+--+-- >>> bvExtract 4 2 (SomeSymIntN (0b010100 :: SymIntN 6))+-- 0b101+bvExtract ::+  (BV bv) =>+  -- | The start position to extract from, @i < n@ must hold where @n@ is+  -- the size of the output bit vector+  Int ->+  -- | The end position to extract from, @j <= i@ must hold+  Int ->+  -- | Bit vector to extract from+  bv ->+  bv+bvExtract i j = bvSelect j (i - j + 1)+{-# INLINE bvExtract #-}++-- | Sized bit vector operations. Including concatenation ('sizedBVConcat'),+-- extension ('sizedBVZext', 'sizedBVSext', 'sizedBVExt'), and selection+-- ('sizedBVSelect').+class SizedBV bv where+  -- | Concatenation of two bit vectors.+  --+  -- >>> sizedBVConcat (0b101 :: SymIntN 3) (0b010 :: SymIntN 3)+  -- 0b101010+  sizedBVConcat :: (KnownNat l, KnownNat r, 1 <= l, 1 <= r) => bv l -> bv r -> bv (l + r)++  -- | Zero extension of a bit vector.+  --+  -- >>> sizedBVZext (Proxy @6) (0b101 :: SymIntN 3)+  -- 0b000101+  sizedBVZext ::+    (KnownNat l, KnownNat r, 1 <= l, KnownNat r, l <= r) =>+    -- | Desired output width+    proxy r ->+    -- | Bit vector to extend+    bv l ->+    bv r++  -- | Signed extension of a bit vector.+  --+  -- >>> sizedBVSext (Proxy @6) (0b101 :: SymIntN 3)+  -- 0b111101+  sizedBVSext ::+    (KnownNat l, KnownNat r, 1 <= l, KnownNat r, l <= r) =>+    -- | Desired output width+    proxy r ->+    -- | Bit vector to extend+    bv l ->+    bv r++  -- | Extension of a bit vector.+  -- Signedness is determined by the input bit vector type.+  --+  -- >>> sizedBVExt (Proxy @6) (0b101 :: SymIntN 3)+  -- 0b111101+  -- >>> sizedBVExt (Proxy @6) (0b001 :: SymIntN 3)+  -- 0b000001+  -- >>> sizedBVExt (Proxy @6) (0b101 :: SymWordN 3)+  -- 0b000101+  -- >>> sizedBVExt (Proxy @6) (0b001 :: SymWordN 3)+  -- 0b000001+  sizedBVExt ::+    (KnownNat l, KnownNat r, 1 <= l, KnownNat r, l <= r) =>+    -- | Desired output width+    proxy r ->+    -- | Bit vector to extend+    bv l ->+    bv r++  -- | Slicing out a smaller bit vector from a larger one, selecting a slice with+  -- width @w@ starting from index @ix@.+  --+  -- The least significant bit is indexed as 0.+  --+  -- >>> sizedBVSelect (Proxy @2) (Proxy @3) (con 0b010100 :: SymIntN 6)+  -- 0b101+  sizedBVSelect ::+    (KnownNat n, KnownNat ix, KnownNat w, 1 <= n, 1 <= w, ix + w <= n) =>+    -- | Index of the least significant bit of the slice+    p ix ->+    -- | Desired output width, @ix + w <= n@ must hold where @n@ is+    -- the size of the input bit vector+    q w ->+    -- | Bit vector to select from+    bv n ->+    bv w++  -- Analogous to 'fromIntegral'.+  sizedBVFromIntegral :: (Integral a, KnownNat n, 1 <= n) => a -> bv n+  default sizedBVFromIntegral ::+    (Num (bv n), Integral a, KnownNat n, 1 <= n) => a -> bv n+  sizedBVFromIntegral = fromIntegral++-- | Slicing out a smaller bit vector from a larger one, extract a slice from+-- bit @i@ down to @j@.+--+-- The least significant bit is indexed as 0.+--+-- >>> sizedBVExtract (Proxy @4) (Proxy @2) (con 0b010100 :: SymIntN 6)+-- 0b101+sizedBVExtract ::+  forall p i q j n bv.+  (SizedBV bv, KnownNat n, KnownNat i, KnownNat j, 1 <= n, i + 1 <= n, j <= i) =>+  -- | The start position to extract from, @i < n@ must hold where @n@ is+  -- the size of the output bit vector+  p i ->+  -- | The end position to extract from, @j <= i@ must hold+  q j ->+  -- | Bit vector to extract from+  bv n ->+  bv (i - j + 1)+sizedBVExtract _ _ =+  case ( hasRepr (addNat (subNat (natRepr @i) (natRepr @j)) (natRepr @1)),+         unsafeLeqProof @(j + (i - j + 1)) @n,+         unsafeLeqProof @1 @(i - j + 1)+       ) of+    (KnownProof, LeqProof, LeqProof) ->+      sizedBVSelect (Proxy @j) (Proxy @(i - j + 1))+{-# INLINE sizedBVExtract #-}
+ src/Grisette/Internal/Core/Data/Class/CEGISSolver.hs view
@@ -0,0 +1,1169 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE Trustworthy #-}++-- |+-- Module      :   Grisette.Internal.Core.Data.Class.CEGISSolver+-- 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.CEGISSolver+  ( -- * Note for the examples++    --++    -- | The examples assumes that the [z3](https://github.com/Z3Prover/z3)+    -- solver is available in @PATH@.++    -- * Generic CEGIS interface+    VerifierResult (..),+    SynthesisConstraintFun,+    VerifierFun,+    CEGISResult (..),+    solverGenericCEGIS,+    solverGenericCEGISWithRefinement,+    genericCEGIS,+    genericCEGISWithRefinement,++    -- * CEGIS interfaces with pre/post conditions+    CEGISCondition (..),+    cegisPostCond,+    cegisPrePost,+    solverCegisMultiInputs,+    solverCegis,+    solverCegisExcept,+    solverCegisExceptStdVC,+    solverCegisExceptVC,+    solverCegisExceptMultiInputs,+    solverCegisExceptStdVCMultiInputs,+    solverCegisExceptVCMultiInputs,+    solverCegisForAll,+    solverCegisForAllExcept,+    solverCegisForAllExceptStdVC,+    solverCegisForAllExceptVC,+    cegisMultiInputs,+    cegis,+    cegisExcept,+    cegisExceptStdVC,+    cegisExceptVC,+    cegisExceptMultiInputs,+    cegisExceptStdVCMultiInputs,+    cegisExceptVCMultiInputs,+    cegisForAll,+    cegisForAllExcept,+    cegisForAllExceptStdVC,+    cegisForAllExceptVC,+  )+where++#if MIN_VERSION_base(4,20,0)+import Data.List (partition)+#else+import Data.List (foldl', partition)+#endif++import Control.DeepSeq (NFData)+import qualified Data.Binary as Binary+import Data.Bytes.Serial (Serial (deserialize, serialize))+import Data.Hashable (Hashable)+import qualified Data.Serialize as Cereal+import GHC.Generics (Generic)+import Generics.Deriving (Default (Default))+import Grisette.Internal.Core.Control.Exception+  ( VerificationConditions (AssertionViolation, AssumptionViolation),+  )+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)+import Grisette.Internal.Core.Data.Class.ModelOps+  ( ModelOps (exact, exceptFor),+    SymbolSetOps (isEmptySet),+  )+import Grisette.Internal.Core.Data.Class.PPrint (PPrint (pformat), (<+>))+import Grisette.Internal.Core.Data.Class.SimpleMergeable+  ( SimpleMergeable,+  )+import Grisette.Internal.Core.Data.Class.Solvable (Solvable (con))+import Grisette.Internal.Core.Data.Class.Solver+  ( ConfigurableSolver,+    Solver (solverResetAssertions),+    SolvingFailure (Unsat),+    UnionWithExcept (extractUnionExcept),+    solverSolve,+    withSolver,+  )+import Grisette.Internal.Core.Data.Class.SymEq (SymEq)+import Grisette.Internal.Core.Data.Class.UnionView+  ( UnionView,+    simpleMerge,+  )+import Grisette.Internal.SymPrim.Prim.Model (Model)+import Grisette.Internal.SymPrim.SymBool (SymBool)+import Language.Haskell.TH.Syntax (Lift)++-- $setup+-- >>> import Grisette.Core+-- >>> import Grisette.Lib.Base+-- >>> import Grisette.SymPrim+-- >>> import Grisette.Backend++-- | The response from a verifier.+data VerifierResult cex exception+  = CEGISVerifierFoundCex cex+  | -- | True indicates that the verifier is sure that there is no+    -- counter-example, while False indicates that the verifier is not sure,+    -- but it cannot find a counter-example.+    CEGISVerifierNoCex Bool+  | CEGISVerifierException exception+  deriving (Show, Eq, Generic, Lift)+  deriving anyclass (Hashable, NFData)++instance+  (PPrint cex, PPrint exception) =>+  PPrint (VerifierResult cex exception)+  where+  pformat = \case+    CEGISVerifierFoundCex cex -> "Found cex:" <+> pformat cex+    CEGISVerifierNoCex True -> "No cex"+    CEGISVerifierNoCex False -> "Maybe no cex"+    CEGISVerifierException e -> "Exception:" <+> pformat e++-- | Build the synthesizer constraint from the verfication result. The first+-- argument will be guaranteed to be distinct during each invocation of the+-- function in the CEGIS algorithm, so it can be used to instantiate the+-- identifiers for fresh variables.+type SynthesisConstraintFun cex = cex -> IO SymBool++-- | The verifier.+type VerifierFun cex exception = Model -> IO (VerifierResult cex exception)++type RefinementConditionFun = Model -> IO SymBool++-- | The result of the CEGIS procedure.+data CEGISResult exception+  = CEGISSuccess Model+  | CEGISVerifierFailure exception+  | CEGISSolverFailure SolvingFailure+  deriving (Show, Eq, Generic, Lift)+  deriving anyclass (NFData, Hashable, Serial)++instance (Serial exception) => Cereal.Serialize (CEGISResult exception) where+  put = serialize+  get = deserialize++instance (Serial exception) => Binary.Binary (CEGISResult exception) where+  put = serialize+  get = deserialize++-- | Generic CEGIS procedure. See 'genericCEGIS' for more details.+--+-- The difference from 'genericCEGIS' is that this function accepts a solver+-- handle for the synthesizer, instead of a solver configuration.+solverGenericCEGIS ::+  (Solver handle) =>+  -- | Configuration of the solver.+  handle ->+  -- | Whether we should rerun the passed verifiers if any other verifier found+  -- a counter-example.+  Bool ->+  -- | The initial synthesis constraint.+  SymBool ->+  -- | Synthesis constraint from counter-examples+  SynthesisConstraintFun input ->+  -- | The verifier functions.+  [VerifierFun input exception] ->+  IO ([input], CEGISResult exception)+solverGenericCEGIS solver rerun initConstr synthConstr verifiers = do+  firstResult <- solverSolve solver initConstr+  case firstResult of+    Left err -> return ([], CEGISSolverFailure err)+    Right model -> go model False numAllVerifiers 0 verifiers+  where+    numAllVerifiers = length verifiers+    go prevModel _ 0 _ (_ : _) = return ([], CEGISSuccess prevModel)+    go prevModel needRerun runBound nextBound (verifier : remainingVerifiers) = do+      verifierResult <- verifier prevModel+      case verifierResult of+        CEGISVerifierFoundCex cex -> do+          newResult <- solverSolve solver =<< synthConstr cex+          case newResult of+            Left err -> return ([cex], CEGISSolverFailure err)+            Right model -> do+              (cexes, result) <-+                go+                  model+                  (needRerun || rerun)+                  (length remainingVerifiers + 1)+                  (numAllVerifiers - length remainingVerifiers - 1)+                  $ verifier : remainingVerifiers+              return (cex : cexes, result)+        CEGISVerifierNoCex {} ->+          go prevModel needRerun (runBound - 1) nextBound remainingVerifiers+        CEGISVerifierException exception ->+          return ([], CEGISVerifierFailure exception)+    go prevModel False _ _ [] = return ([], CEGISSuccess prevModel)+    go prevModel True _runBound nextBound [] =+      go prevModel False nextBound 0 verifiers++-- | Generic CEGIS procedure with refinement. See 'genericCEGISWithRefinement'+-- for more details.+--+-- The difference from 'genericCEGISWithRefinement' is that this function+-- accepts a solver handle for the synthesizer, instead of a solver+-- configuration.+solverGenericCEGISWithRefinement ::+  (Solver handle) =>+  -- | Configuration of the solver.+  handle ->+  -- | Whether we should rerun the passed verifiers if any other verifier found+  -- a counter-example.+  Bool ->+  -- | The initial synthesis constraint.+  SymBool ->+  -- | Synthesis constraint from counter-examples+  SynthesisConstraintFun input ->+  -- | Refinement condition generator.+  Maybe RefinementConditionFun ->+  -- | The verifier functions.+  [VerifierFun input exception] ->+  IO ([input], CEGISResult exception)+solverGenericCEGISWithRefinement+  solver+  rerun+  initConstr+  synthConstr+  refineCond+  verifiers = do+    (input, r) <-+      solverGenericCEGIS solver rerun initConstr synthConstr verifiers+    case r of+      CEGISSuccess model -> refine solver input model+      _ -> return (input, r)+    where+      refine solver input model = case refineCond of+        Just f -> do+          cond <- f model+          newResult <-+            solverGenericCEGIS solver rerun cond synthConstr verifiers+          case newResult of+            (newInputs, CEGISSuccess model) ->+              refine solver (input ++ newInputs) model+            _ -> return (input, CEGISSuccess model)+        Nothing -> return (input, CEGISSuccess model)++-- | Generic CEGIS procedure.+--+-- The CEGIS procedure will try to find a model that satisfies the initial+-- synthesis constraint, and satisfies all the inputs generated by the verifier.+genericCEGIS ::+  (ConfigurableSolver config handle) =>+  -- | Configuration of the solver.+  config ->+  -- | Whether we should rerun the passed verifiers if any other verifier found+  -- a counter-example.+  Bool ->+  -- | The initial synthesis constraint.+  SymBool ->+  -- | Synthesis constraint from counter-examples+  SynthesisConstraintFun input ->+  -- | The verifier functions.+  [VerifierFun input exception] ->+  IO ([input], CEGISResult exception)+genericCEGIS config rerun initConstr synthConstr verifier =+  withSolver config $ \solver ->+    solverGenericCEGIS solver rerun initConstr synthConstr verifier++-- | Generic CEGIS procedure.+--+-- The CEGIS procedure will try to find a model that satisfies the initial+-- synthesis constraint, and satisfies all the inputs generated by the verifier.+genericCEGISWithRefinement ::+  (ConfigurableSolver config handle) =>+  -- | Configuration of the solver.+  config ->+  -- | Whether we should rerun the passed verifiers if any other verifier found+  -- a counter-example.+  Bool ->+  -- | The initial synthesis constraint.+  SymBool ->+  -- | Synthesis constraint from counter-examples+  SynthesisConstraintFun input ->+  -- | Refinement condition generator.+  Maybe RefinementConditionFun ->+  -- | The verifier functions.+  [VerifierFun input exception] ->+  IO ([input], CEGISResult exception)+genericCEGISWithRefinement+  config+  rerun+  initConstr+  synthConstr+  refineCond+  verifier =+    withSolver config $ \solver -> do+      solverGenericCEGISWithRefinement+        solver+        rerun+        initConstr+        synthConstr+        refineCond+        verifier++-- | The condition for CEGIS to solve.+--+-- The first argument is the pre-condition, and the second argument is the+-- post-condition.+--+-- The CEGIS procedures would try to find a model for the formula+--+-- \[+--   \forall P. (\exists I. \mathrm{pre}(P, I)) \wedge (\forall I. \mathrm{pre}(P, I)\implies \mathrm{post}(P, I))+-- \]+--+-- In program synthesis tasks, \(P\) is the symbolic constants in the symbolic+-- program, and \(I\) is the input. The pre-condition is used to restrict the+-- search space of the program. The procedure would only return programs that+-- meets the pre-conditions on every possible inputs, and there are at least+-- one possible input. The post-condition is used to specify the desired program+-- behaviors.+data CEGISCondition = CEGISCondition SymBool SymBool+  deriving (Generic)+  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+-- allowed.+cegisPostCond :: SymBool -> CEGISCondition+cegisPostCond = CEGISCondition (con True)++-- | Construct a CEGIS condition with both pre- and post-conditions.+cegisPrePost :: SymBool -> SymBool -> CEGISCondition+cegisPrePost = CEGISCondition++deriving via (Default CEGISCondition) instance Mergeable CEGISCondition++deriving via (Default CEGISCondition) instance SimpleMergeable CEGISCondition++-- | CEGIS with multiple (possibly symbolic) inputs. See 'cegisMultiInputs' for+-- more details.+--+-- The difference from 'cegisMultiInputs' is that this function accepts two+-- solver handles, one for the synthesizer and one for the verifier.+--+-- The synthesizer solver will **not** be reset, while the verifier solver will+-- be reset after each iteration.+solverCegisMultiInputs ::+  ( EvalSym input,+    ExtractSym input,+    Solver handle+  ) =>+  -- The synthesizer solver handle+  handle ->+  -- The verifier solver handle+  handle ->+  -- | Initial symbolic inputs. The solver will try to find a+  -- program that works on all the inputs representable by these inputs (see+  -- t'CEGISCondition').+  [input] ->+  -- | The condition for the solver to solve. All the+  -- symbolic constants that are not in the inputs will+  -- be considered as part of the symbolic program.+  (input -> CEGISCondition) ->+  -- | The counter-examples generated+  -- during the CEGIS loop, and the+  -- model found by the solver.+  IO ([input], CEGISResult SolvingFailure)+solverCegisMultiInputs+  synthesizerSolver+  verifierSolver+  inputs+  toCEGISCondition = do+    solverGenericCEGIS+      synthesizerSolver+      True+      (foldl' (\acc v -> acc .&& cexAssertFun v) (con True) conInputs)+      (return . cexAssertFun)+      $ getVerifier <$> symInputs+    where+      cexAssertFun input =+        case toCEGISCondition input of+          CEGISCondition pre post -> pre .&& post+      getVerifier input md = do+        let CEGISCondition pre post = toCEGISCondition input+        let evaluated =+              evalSym False (exceptFor (extractSym input) md) $+                pre .&& symNot post+        solverResetAssertions verifierSolver+        r <- solverSolve verifierSolver evaluated+        case r of+          Left Unsat -> return $ CEGISVerifierNoCex True+          Left err -> return $ CEGISVerifierException err+          Right model -> do+            let newCexInput =+                  evalSym True (exact (extractSym input) model) input+            return $ CEGISVerifierFoundCex newCexInput+      (conInputs, symInputs) = partition (isEmptySet . extractSym) inputs++-- | CEGIS with a single symbolic input to represent a set of inputs. See+-- 'cegis' for more details.+--+-- The difference from 'cegis' is that this function accepts two solver handles,+-- one for the synthesizer and one for the verifier.+--+-- The synthesizer solver will **not** be reset, while the verifier solver will+-- be reset after each iteration.+solverCegis ::+  ( Solver handle,+    EvalSym inputs,+    ExtractSym inputs,+    SymEq inputs+  ) =>+  -- | The synthesizer solver handle+  handle ->+  -- | The verifier solver handle+  handle ->+  -- | Initial symbolic inputs. The solver will try to find a+  -- program that works on all the inputs representable by it (see+  -- t'CEGISCondition').+  inputs ->+  -- | The condition for the solver to solve. All the+  -- symbolic constants that are not in the inputs will+  -- be considered as part of the symbolic program.+  (inputs -> CEGISCondition) ->+  -- | The counter-examples generated+  -- during the CEGIS loop, and the+  -- model found by the solver.+  IO ([inputs], CEGISResult SolvingFailure)+solverCegis synthesizerSolver verifierSolver inputs =+  solverCegisMultiInputs synthesizerSolver verifierSolver [inputs]++-- |+-- CEGIS for symbolic programs with error handling, using multiple (possibly+-- symbolic) inputs to represent a set of inputs.+--+-- The difference from 'cegisExceptMultiInputs' is that this function accepts+-- two solver handles, one for the synthesizer and one for the verifier.+--+-- The synthesizer solver will **not** be reset, while the verifier solver will+-- be reset after each iteration.+solverCegisExceptMultiInputs ::+  ( Solver handle,+    EvalSym inputs,+    ExtractSym inputs,+    UnionWithExcept t u e v,+    UnionView u,+    Monad u+  ) =>+  handle ->+  handle ->+  [inputs] ->+  (Either e v -> CEGISCondition) ->+  (inputs -> t) ->+  IO ([inputs], CEGISResult SolvingFailure)+solverCegisExceptMultiInputs+  synthesizerSolver+  verifierSolver+  cexes+  interpretFun+  f =+    solverCegisMultiInputs+      synthesizerSolver+      verifierSolver+      cexes+      (simpleMerge . (interpretFun <$>) . extractUnionExcept . f)++-- |+-- CEGIS for symbolic programs with error handling, using multiple (possibly+-- symbolic) inputs to represent a set of inputs.+--+-- The errors should be translated to assertion or assumption violations.+--+-- The difference from 'cegisExceptVCMultiInputs' is that this function accepts+-- two solver handles, one for the synthesizer and one for the verifier.+--+-- The synthesizer solver will **not** be reset, while the verifier solver will+-- be reset after each iteration.+solverCegisExceptVCMultiInputs ::+  ( Solver handle,+    EvalSym inputs,+    ExtractSym inputs,+    UnionWithExcept t u e v,+    UnionView u,+    Monad u+  ) =>+  handle ->+  handle ->+  [inputs] ->+  (Either e v -> u (Either VerificationConditions ())) ->+  (inputs -> t) ->+  IO ([inputs], CEGISResult SolvingFailure)+solverCegisExceptVCMultiInputs+  synthesizerSolver+  verifierSolver+  cexes+  interpretFun+  f =+    solverCegisMultiInputs+      synthesizerSolver+      verifierSolver+      cexes+      ( \v ->+          simpleMerge+            ( ( \case+                  Left AssumptionViolation ->+                    cegisPrePost (con False) (con True)+                  Left AssertionViolation -> cegisPostCond (con False)+                  _ -> cegisPostCond (con True)+              )+                <$> (extractUnionExcept (f v) >>= interpretFun)+            )+      )++-- |+-- CEGIS for symbolic programs with error handling, using multiple (possibly+-- symbolic) inputs to represent a set of inputs. See+-- 'cegisExceptStdVCMultiInputs' for more details.+--+-- The difference from 'cegisExceptStdVCMultiInputs' is that this function+-- accepts two solver handles, one for the synthesizer and one for the verifier.+--+-- The synthesizer solver will **not** be reset, while the verifier solver will+-- be reset after each iteration.+solverCegisExceptStdVCMultiInputs ::+  ( Solver handle,+    EvalSym inputs,+    ExtractSym inputs,+    UnionWithExcept t u VerificationConditions (),+    UnionView u,+    Monad u+  ) =>+  handle ->+  handle ->+  [inputs] ->+  (inputs -> t) ->+  IO ([inputs], CEGISResult SolvingFailure)+solverCegisExceptStdVCMultiInputs synthesizerSolver verifierSolver cexes =+  solverCegisExceptVCMultiInputs synthesizerSolver verifierSolver cexes return++-- |+-- CEGIS for symbolic programs with error handling, using a single symbolic+-- input to represent a set of inputs. See 'cegisExcept' for more details.+--+-- The difference from 'cegisExcept' is that this function accepts two solver+-- handles, one for the synthesizer and one for the verifier.+--+-- The synthesizer solver will **not** be reset, while the verifier solver will+-- be reset after each iteration.+solverCegisExcept ::+  ( UnionWithExcept t u e v,+    UnionView u,+    Functor u,+    EvalSym inputs,+    ExtractSym inputs,+    Solver handle,+    SymEq inputs+  ) =>+  handle ->+  handle ->+  inputs ->+  (Either e v -> CEGISCondition) ->+  (inputs -> t) ->+  IO ([inputs], CEGISResult SolvingFailure)+solverCegisExcept synthesizerSolver verifierSolver inputs f v =+  solverCegis synthesizerSolver verifierSolver inputs $+    \i -> simpleMerge $ f <$> extractUnionExcept (v i)++-- |+-- CEGIS for symbolic programs with error handling, using a single symbolic+-- input to represent a set of inputs.+--+-- The errors should be translated to assertion or assumption violations.+--+-- The difference from 'cegisExceptVC' is that this function accepts two solver+-- handles, one for the synthesizer and one for the verifier.+--+-- The synthesizer solver will **not** be reset, while the verifier solver will+-- be reset after each iteration.+solverCegisExceptVC ::+  ( UnionWithExcept t u e v,+    UnionView u,+    Monad u,+    EvalSym inputs,+    ExtractSym inputs,+    Solver handle,+    SymEq inputs+  ) =>+  handle ->+  handle ->+  inputs ->+  (Either e v -> u (Either VerificationConditions ())) ->+  (inputs -> t) ->+  IO ([inputs], CEGISResult SolvingFailure)+solverCegisExceptVC synthesizerSolver verifierSolver inputs f v = do+  solverCegis synthesizerSolver verifierSolver inputs $ \i ->+    simpleMerge $+      ( \case+          Left AssumptionViolation -> cegisPrePost (con False) (con True)+          Left AssertionViolation -> cegisPostCond (con False)+          _ -> cegisPostCond (con True)+      )+        <$> (extractUnionExcept (v i) >>= f)++-- |+-- CEGIS for symbolic programs with error handling, using a single symbolic+-- input to represent a set of inputs. See 'cegisExceptStdVC' for more details.+--+-- The difference from 'cegisExceptStdVC' is that this function accepts two+-- solver handles, one for the synthesizer and one for the verifier.+--+-- The synthesizer solver will **not** be reset, while the verifier solver will+-- be reset after each iteration.+solverCegisExceptStdVC ::+  ( UnionWithExcept t u VerificationConditions (),+    UnionView u,+    Monad u,+    EvalSym inputs,+    ExtractSym inputs,+    Solver handle,+    SymEq inputs+  ) =>+  handle ->+  handle ->+  inputs ->+  (inputs -> t) ->+  IO ([inputs], CEGISResult SolvingFailure)+solverCegisExceptStdVC synthesizerSolver verifierSolver inputs =+  solverCegisExceptVC synthesizerSolver verifierSolver inputs return++-- |+-- CEGIS with a single symbolic input to represent a set of inputs. See+-- 'cegisForAll' for more details.+--+-- The difference from 'cegisForAll' is that this function accepts two solver+-- handles, one for the synthesizer and one for the verifier.+--+-- The synthesizer solver will **not** be reset, while the verifier solver will+-- be reset after each iteration.+solverCegisForAll ::+  ( ExtractSym forallInput,+    Solver handle+  ) =>+  handle ->+  handle ->+  -- | A symbolic value. All the symbolic constants in the value are treated as+  -- for-all variables.+  forallInput ->+  CEGISCondition ->+  -- | First output are the counter-examples for all the for-all variables, and+  -- the second output is the model for all other variables if CEGIS succeeds.+  IO ([Model], CEGISResult SolvingFailure)+solverCegisForAll+  synthesizerSolver+  verifierSolver+  input+  (CEGISCondition pre post) = do+    (models, result) <-+      solverGenericCEGIS+        synthesizerSolver+        False+        phi+        (\md -> return $ evalSym False md phi)+        [verifier]+    let exactResult = case result of+          CEGISSuccess model -> CEGISSuccess $ exceptFor forallSymbols model+          _ -> result+    return (models, exactResult)+    where+      phi = pre .&& post+      negphi = pre .&& symNot post+      forallSymbols = extractSym input+      verifier candidate = do+        let evaluated =+              evalSym False (exceptFor forallSymbols candidate) negphi+        solverResetAssertions verifierSolver+        r <- solverSolve verifierSolver evaluated+        case r of+          Left Unsat -> return $ CEGISVerifierNoCex True+          Left err -> return $ CEGISVerifierException err+          Right model ->+            return $ CEGISVerifierFoundCex (exact forallSymbols model)++-- |+-- CEGIS for symbolic programs with error handling, with a forall variable.+--+-- See 'cegisForAllExcept', 'cegisForAll' and 'cegisExcept'.+--+-- The difference from 'cegisForAllExcept' is that this function accepts two+-- solver handles, one for the synthesizer and one for the verifier.+--+-- The synthesizer solver will **not** be reset, while the verifier solver will+-- be reset after each iteration.+solverCegisForAllExcept ::+  ( UnionWithExcept t u e v,+    UnionView u,+    Functor u,+    EvalSym inputs,+    ExtractSym inputs,+    Solver handle,+    SymEq inputs+  ) =>+  handle ->+  handle ->+  inputs ->+  (Either e v -> CEGISCondition) ->+  t ->+  IO ([Model], CEGISResult SolvingFailure)+solverCegisForAllExcept synthesizerSolver verifierSolver inputs f v =+  solverCegisForAll synthesizerSolver verifierSolver inputs $+    simpleMerge $+      f <$> extractUnionExcept v++-- |+-- CEGIS for symbolic programs with error handling, with a forall variable.+--+-- See 'cegisForAllExceptVC' 'cegisForAll' and 'cegisExceptVC'.+--+-- The difference from 'cegisForAllExceptVC' is that this function accepts two+-- solver handles, one for the synthesizer and one for the verifier.+--+-- The synthesizer solver will **not** be reset, while the verifier solver will+-- be reset after each iteration.+solverCegisForAllExceptVC ::+  ( UnionWithExcept t u e v,+    UnionView u,+    Monad u,+    EvalSym inputs,+    ExtractSym inputs,+    Solver handle,+    SymEq inputs+  ) =>+  handle ->+  handle ->+  inputs ->+  (Either e v -> u (Either VerificationConditions ())) ->+  t ->+  IO ([Model], CEGISResult SolvingFailure)+solverCegisForAllExceptVC synthesizerSolver verifierSolver inputs f v = do+  solverCegisForAll synthesizerSolver verifierSolver inputs $+    simpleMerge $+      ( \case+          Left AssumptionViolation -> cegisPrePost (con False) (con True)+          Left AssertionViolation -> cegisPostCond (con False)+          _ -> cegisPostCond (con True)+      )+        <$> (extractUnionExcept v >>= f)++-- |+-- CEGIS for symbolic programs with error handling, with a forall variable.+--+-- See 'cegisForAllExceptStdVC' 'cegisForAll' and 'cegisExceptStdVC'.+--+-- The difference from 'cegisForAllExceptStdVC' is that this function accepts+-- two solver handles, one for the synthesizer and one for the verifier.+--+-- The synthesizer solver will **not** be reset, while the verifier solver will+-- be reset after each iteration.+solverCegisForAllExceptStdVC ::+  ( UnionWithExcept t u VerificationConditions (),+    UnionView u,+    Monad u,+    EvalSym inputs,+    ExtractSym inputs,+    Solver handle,+    SymEq inputs+  ) =>+  handle ->+  handle ->+  inputs ->+  t ->+  IO ([Model], CEGISResult SolvingFailure)+solverCegisForAllExceptStdVC synthesizerSolver verifierSolver inputs =+  solverCegisForAllExceptVC synthesizerSolver verifierSolver inputs return++-- |+-- CEGIS with multiple (possibly symbolic) inputs. Solves the following formula+-- (see t'CEGISCondition' for details).+--+-- \[+--   \forall P. (\exists I\in\mathrm{inputs}. \mathrm{pre}(P, I)) \wedge (\forall I\in\mathrm{inputs}. \mathrm{pre}(P, I)\implies \mathrm{post}(P, I))+-- \]+--+-- For simpler queries, where the inputs are representable by a single+-- symbolic value, you may want to use 'cegis' or 'cegisExcept' instead.+-- We have an example for the 'cegis' call.+cegisMultiInputs ::+  ( EvalSym input,+    ExtractSym input,+    ConfigurableSolver config handle+  ) =>+  -- | The configuration of the solver+  config ->+  -- | Initial symbolic inputs. The solver will try to find a+  -- program that works on all the inputs representable by these inputs (see+  -- t'CEGISCondition').+  [input] ->+  -- | The condition for the solver to solve. All the+  -- symbolic constants that are not in the inputs will+  -- be considered as part of the symbolic program.+  (input -> CEGISCondition) ->+  -- | The counter-examples generated+  -- during the CEGIS loop, and the+  -- model found by the solver.+  IO ([input], CEGISResult SolvingFailure)+cegisMultiInputs config inputs toCEGISCondition =+  withSolver config $ \synthesizerSolver ->+    withSolver config $ \verifierSolver ->+      solverCegisMultiInputs+        synthesizerSolver+        verifierSolver+        inputs+        toCEGISCondition++-- |+-- CEGIS with a single symbolic input to represent a set of inputs.+--+-- The following example tries to find the value of @c@ such that for all+-- positive @x@, @x * c < 0 && c > -2@. The @c .> -2@ clause is used to make+-- the solution unique.+--+-- >>> let [x,c] = ["x","c"] :: [SymInteger]+-- >>> cegis z3 x (\x -> cegisPrePost (x .> 0) (x * c .< 0 .&& c .> -2))+-- (...,CEGISSuccess (Model {c -> -1 :: Integer}))+cegis ::+  ( ConfigurableSolver config handle,+    EvalSym inputs,+    ExtractSym inputs,+    SymEq inputs+  ) =>+  -- | The configuration of the solver+  config ->+  -- | Initial symbolic inputs. The solver will try to find a+  -- program that works on all the inputs representable by it (see+  -- t'CEGISCondition').+  inputs ->+  -- | The condition for the solver to solve. All the+  -- symbolic constants that are not in the inputs will+  -- be considered as part of the symbolic program.+  (inputs -> CEGISCondition) ->+  -- | The counter-examples generated+  -- during the CEGIS loop, and the+  -- model found by the solver.+  IO ([inputs], CEGISResult SolvingFailure)+cegis config inputs condition =+  withSolver config $ \synthesizerSolver ->+    withSolver config $ \verifierSolver ->+      solverCegis synthesizerSolver verifierSolver inputs condition++-- |+-- CEGIS for symbolic programs with error handling, using multiple (possibly+-- symbolic) inputs to represent a set of inputs.+cegisExceptMultiInputs ::+  ( ConfigurableSolver config handle,+    EvalSym inputs,+    ExtractSym inputs,+    UnionWithExcept t u e v,+    UnionView u,+    Monad u+  ) =>+  config ->+  [inputs] ->+  (Either e v -> CEGISCondition) ->+  (inputs -> t) ->+  IO ([inputs], CEGISResult SolvingFailure)+cegisExceptMultiInputs config cexes interpretFun f =+  withSolver config $ \synthesizerSolver ->+    withSolver config $ \verifierSolver ->+      solverCegisExceptMultiInputs+        synthesizerSolver+        verifierSolver+        cexes+        interpretFun+        f++-- |+-- CEGIS for symbolic programs with error handling, using multiple (possibly+-- symbolic) inputs to represent a set of inputs.+--+-- The errors should be translated to assertion or assumption violations.+cegisExceptVCMultiInputs ::+  ( ConfigurableSolver config handle,+    EvalSym inputs,+    ExtractSym inputs,+    UnionWithExcept t u e v,+    UnionView u,+    Monad u+  ) =>+  config ->+  [inputs] ->+  (Either e v -> u (Either VerificationConditions ())) ->+  (inputs -> t) ->+  IO ([inputs], CEGISResult SolvingFailure)+cegisExceptVCMultiInputs config cexes interpretFun f =+  withSolver config $ \synthesizerSolver ->+    withSolver config $ \verifierSolver ->+      solverCegisExceptVCMultiInputs+        synthesizerSolver+        verifierSolver+        cexes+        interpretFun+        f++-- |+-- 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 @()@.+--+-- This function translates assumption violations to failed pre-conditions,+-- and translates assertion violations to failed post-conditions.+-- The @()@ result will not fail any conditions.+cegisExceptStdVCMultiInputs ::+  ( ConfigurableSolver config handle,+    EvalSym inputs,+    ExtractSym inputs,+    UnionWithExcept t u VerificationConditions (),+    UnionView u,+    Monad u+  ) =>+  config ->+  [inputs] ->+  (inputs -> t) ->+  IO ([inputs], CEGISResult SolvingFailure)+cegisExceptStdVCMultiInputs config cexes f =+  withSolver config $ \synthesizerSolver ->+    withSolver config $ \verifierSolver ->+      solverCegisExceptStdVCMultiInputs synthesizerSolver verifierSolver cexes f++-- |+-- CEGIS for symbolic programs with error handling, using a single symbolic+-- input to represent a set of inputs.+--+-- 'cegisExcept' is particularly useful when custom error types are used.+-- With 'cegisExcept', you define how the errors are interpreted to the+-- CEGIS conditions after the symbolic evaluation. This could increase the+-- readability and modularity of the code.+--+-- 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+-- the solution unique.+--+-- >>> let [x,c] = ["x","c"] :: [SymInteger]+-- >>> import Control.Monad.Except+-- >>> :{+--   res :: SymInteger -> ExceptT VerificationConditions Union ()+--   res x = do+--     symAssume $ x .> 0+--     symAssert $ x * c .< 0+--     symAssert $ c .> -2+-- :}+--+-- >>> :{+--   translation (Left AssumptionViolation) = cegisPrePost (con False) (con True)+--   translation (Left AssertionViolation) = cegisPostCond (con False)+--   translation _ = cegisPostCond (con True)+-- :}+--+-- >>> cegisExcept z3 x translation res+-- ([...],CEGISSuccess (Model {c -> -1 :: Integer}))+cegisExcept ::+  ( UnionWithExcept t u e v,+    UnionView u,+    Functor u,+    EvalSym inputs,+    ExtractSym inputs,+    ConfigurableSolver config handle,+    SymEq inputs+  ) =>+  config ->+  inputs ->+  (Either e v -> CEGISCondition) ->+  (inputs -> t) ->+  IO ([inputs], CEGISResult SolvingFailure)+cegisExcept config inputs f v =+  withSolver config $ \synthesizerSolver ->+    withSolver config $ \verifierSolver ->+      solverCegisExcept synthesizerSolver verifierSolver inputs f v++-- |+-- CEGIS for symbolic programs with error handling, using a single symbolic+-- input to represent a set of inputs.+--+-- The errors should be translated to assertion or assumption violations.+cegisExceptVC ::+  ( UnionWithExcept t u e v,+    UnionView u,+    Monad u,+    EvalSym inputs,+    ExtractSym inputs,+    ConfigurableSolver config handle,+    SymEq inputs+  ) =>+  config ->+  inputs ->+  (Either e v -> u (Either VerificationConditions ())) ->+  (inputs -> t) ->+  IO ([inputs], CEGISResult SolvingFailure)+cegisExceptVC config inputs f v =+  withSolver config $ \synthesizerSolver ->+    withSolver config $ \verifierSolver ->+      solverCegisExceptVC synthesizerSolver verifierSolver inputs f v++-- |+-- 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 @()@.+--+-- 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 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+-- the solution unique.+--+-- >>> let [x,c] = ["x","c"] :: [SymInteger]+-- >>> import Control.Monad.Except+-- >>> :{+--   res :: SymInteger -> ExceptT VerificationConditions Union ()+--   res x = do+--     symAssume $ x .> 0+--     symAssert $ x * c .< 0+--     symAssert $ c .> -2+-- :}+--+-- >>> cegisExceptStdVC z3 x res+-- ([...],CEGISSuccess (Model {c -> -1 :: Integer}))+cegisExceptStdVC ::+  ( UnionWithExcept t u VerificationConditions (),+    UnionView u,+    Monad u,+    EvalSym inputs,+    ExtractSym inputs,+    ConfigurableSolver config handle,+    SymEq inputs+  ) =>+  config ->+  inputs ->+  (inputs -> t) ->+  IO ([inputs], CEGISResult SolvingFailure)+cegisExceptStdVC config inputs f =+  withSolver config $ \synthesizerSolver ->+    withSolver config $ \verifierSolver ->+      solverCegisExceptStdVC synthesizerSolver verifierSolver inputs f++-- |+-- CEGIS with a single symbolic input to represent a set of inputs.+--+-- The following example tries to find the value of @c@ such that for all+-- positive @x@, @x * c < 0 && c > -2@. The @c .> -2@ clause is used to make+-- the solution unique.+--+-- >>> let [x,c] = ["x","c"] :: [SymInteger]+-- >>> cegisForAll z3 x $ cegisPrePost (x .> 0) (x * c .< 0 .&& c .> -2)+-- (...,CEGISSuccess (Model {c -> -1 :: Integer}))+cegisForAll ::+  ( ExtractSym forallInput,+    ConfigurableSolver config handle+  ) =>+  config ->+  -- | A symbolic value. All the symbolic constants in the value are treated as+  -- for-all variables.+  forallInput ->+  CEGISCondition ->+  -- | First output are the counter-examples for all the for-all variables, and+  -- the second output is the model for all other variables if CEGIS succeeds.+  IO ([Model], CEGISResult SolvingFailure)+cegisForAll config input (CEGISCondition pre post) =+  withSolver config $ \synthesizerSolver ->+    withSolver config $ \verifierSolver ->+      solverCegisForAll+        synthesizerSolver+        verifierSolver+        input+        (CEGISCondition pre post)++-- |+-- CEGIS for symbolic programs with error handling, with a forall variable.+--+-- See 'cegisForAll' and 'cegisExcept'.+cegisForAllExcept ::+  ( UnionWithExcept t u e v,+    UnionView u,+    Functor u,+    EvalSym inputs,+    ExtractSym inputs,+    ConfigurableSolver config handle,+    SymEq inputs+  ) =>+  config ->+  inputs ->+  (Either e v -> CEGISCondition) ->+  t ->+  IO ([Model], CEGISResult SolvingFailure)+cegisForAllExcept config inputs f v =+  withSolver config $ \synthesizerSolver ->+    withSolver config $ \verifierSolver ->+      solverCegisForAllExcept synthesizerSolver verifierSolver inputs f v++-- |+-- CEGIS for symbolic programs with error handling, with a forall variable.+--+-- See 'cegisForAll' and 'cegisExceptVC'.+cegisForAllExceptVC ::+  ( UnionWithExcept t u e v,+    UnionView u,+    Monad u,+    EvalSym inputs,+    ExtractSym inputs,+    ConfigurableSolver config handle,+    SymEq inputs+  ) =>+  config ->+  inputs ->+  (Either e v -> u (Either VerificationConditions ())) ->+  t ->+  IO ([Model], CEGISResult SolvingFailure)+cegisForAllExceptVC config inputs f v =+  withSolver config $ \synthesizerSolver ->+    withSolver config $ \verifierSolver ->+      solverCegisForAllExceptVC synthesizerSolver verifierSolver inputs f v++-- |+-- CEGIS for symbolic programs with error handling, with a forall variable.+--+-- See 'cegisForAll' and 'cegisExceptStdVC'.+cegisForAllExceptStdVC ::+  ( UnionWithExcept t u VerificationConditions (),+    UnionView u,+    Monad u,+    EvalSym inputs,+    ExtractSym inputs,+    ConfigurableSolver config handle,+    SymEq inputs+  ) =>+  config ->+  inputs ->+  t ->+  IO ([Model], CEGISResult SolvingFailure)+cegisForAllExceptStdVC config inputs u =+  withSolver config $ \synthesizerSolver ->+    withSolver config $ \verifierSolver ->+      solverCegisForAllExceptStdVC synthesizerSolver verifierSolver inputs u
+ src/Grisette/Internal/Core/Data/Class/Concrete.hs view
@@ -0,0 +1,211 @@+{-# LANGUAGE CPP #-}++module Grisette.Internal.Core.Data.Class.Concrete (Concrete) where++#if MIN_VERSION_base(4,16,0)+import Data.Bits (And, Iff, Ior, Xor)+import Data.Tuple (Solo)+#endif++import Control.Monad.Identity (Identity)+import Data.Complex (Complex)+import Data.Functor.Compose (Compose)+import qualified Data.Functor.Product as Functor+import qualified Data.Functor.Sum as Functor+import Data.Int (Int16, Int32, Int64, Int8)+import Data.List.NonEmpty (NonEmpty)+import Data.Monoid (All, Any, Dual, First, Last, Product, Sum)+import Data.Ord (Down)+import Data.Ratio (Ratio)+import Data.Semigroup (Max, Min)+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import Data.Void (Void)+import Data.Word (Word16, Word32, Word64, Word8)+import GHC.Natural (Natural)++-- | A tag for concrete types.+--+-- Can be used in code to constrain types to concrete ones.+-- For example, when trying to support hash maps in Grisette, we may want to+-- restrict the key type to be concrete. The 'Concrete' type class is handy.+class Concrete a++instance Concrete Void++instance Concrete All++instance Concrete Any++instance Concrete Int++instance Concrete Int8++instance Concrete Int16++instance Concrete Int32++instance Concrete Int64++instance Concrete Integer++instance Concrete Natural++instance Concrete Word++instance Concrete Word8++instance Concrete Word16++instance Concrete Word32++instance Concrete Word64++instance Concrete Float++instance Concrete Double++instance Concrete Char++instance Concrete Bool++instance (Concrete a) => Concrete (Maybe a)++instance (Concrete a, Concrete b) => Concrete (Either a b)++instance (Concrete a) => Concrete [a]++instance (Concrete a, Concrete b) => Concrete (a, b)++instance (Concrete a, Concrete b, Concrete c) => Concrete (a, b, c)++instance+  (Concrete a, Concrete b, Concrete c, Concrete d) =>+  Concrete (a, b, c, d)++instance+  (Concrete a, Concrete b, Concrete c, Concrete d, Concrete e) =>+  Concrete (a, b, c, d, e)++instance+  ( Concrete a,+    Concrete b,+    Concrete c,+    Concrete d,+    Concrete e,+    Concrete f+  ) =>+  Concrete (a, b, c, d, e, f)++instance+  ( Concrete a,+    Concrete b,+    Concrete c,+    Concrete d,+    Concrete e,+    Concrete f,+    Concrete g+  ) =>+  Concrete (a, b, c, d, e, f, g)++instance+  ( Concrete a,+    Concrete b,+    Concrete c,+    Concrete d,+    Concrete e,+    Concrete f,+    Concrete g,+    Concrete h+  ) =>+  Concrete (a, b, c, d, e, f, g, h)++instance+  ( Concrete a,+    Concrete b,+    Concrete c,+    Concrete d,+    Concrete e,+    Concrete f,+    Concrete g,+    Concrete h,+    Concrete i+  ) =>+  Concrete (a, b, c, d, e, f, g, h, i)++instance+  ( Concrete a,+    Concrete b,+    Concrete c,+    Concrete d,+    Concrete e,+    Concrete f,+    Concrete g,+    Concrete h,+    Concrete i,+    Concrete j+  ) =>+  Concrete (a, b, c, d, e, f, g, h, i, j)++instance+  ( Concrete a,+    Concrete b,+    Concrete c,+    Concrete d,+    Concrete e,+    Concrete f,+    Concrete g,+    Concrete h,+    Concrete i,+    Concrete j,+    Concrete k+  ) =>+  Concrete (a, b, c, d, e, f, g, h, i, j, k)++instance (Concrete a) => Concrete (Complex a)++instance (Concrete a) => Concrete (Ratio a)++instance (Concrete a) => Concrete (First a)++instance (Concrete a) => Concrete (Last a)++instance (Concrete a) => Concrete (Min a)++instance (Concrete a) => Concrete (Max a)++instance (Concrete a) => Concrete (NonEmpty a)++#if MIN_VERSION_base(4,16,0)+instance (Concrete a) => Concrete (And a)++instance (Concrete a) => Concrete (Iff a)++instance (Concrete a) => Concrete (Ior a)++instance (Concrete a) => Concrete (Xor a)+#endif++instance (Concrete a) => Concrete (Identity a)++instance (Concrete a) => Concrete (Down a)++instance (Concrete a) => Concrete (Dual a)++instance (Concrete a) => Concrete (Sum a)++instance (Concrete a) => Concrete (Product a)++#if MIN_VERSION_base(4,16,0)+instance (Concrete a) => Concrete (Solo a)+#endif++instance (Concrete (f a), Concrete (g a)) => Concrete (Functor.Product f g a)++instance (Concrete (f a), Concrete (g a)) => Concrete (Functor.Sum f g a)++instance (Concrete (f (g a))) => Concrete (Compose f g a)++instance Concrete T.Text++instance Concrete TL.Text
+ src/Grisette/Internal/Core/Data/Class/Error.hs view
@@ -0,0 +1,205 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE Trustworthy #-}++-- |+-- Module      :   Grisette.Internal.Core.Data.Class.Error+-- 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.Error+  ( -- * Error transformation+    TransformError (..),++    -- * Throwing error+    symAssertWith,+    symAssertTransformableError,+    symThrowTransformableError,+    symAssert,+    symAssume,+  )+where++import Control.Exception (ArithException, ArrayException)+import Control.Monad.Except (MonadError (throwError))+import Grisette.Internal.Core.Control.Exception+  ( AssertionError (AssertionError),+    VerificationConditions (AssertionViolation, AssumptionViolation),+  )+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)+import Grisette.Internal.SymPrim.SymBool (SymBool)++-- $setup+-- >>> import Control.Exception+-- >>> import Grisette.Core+-- >>> import Grisette.SymPrim+-- >>> import Grisette.Lib.Control.Monad+-- >>> import Control.Monad.Except++-- | This class indicates that the error type @to@ can always represent the+-- error type @from@.+--+-- This is useful in implementing generic procedures that may throw errors.+-- For example, we support symbolic division and modulo operations. These+-- operations should throw an error when the divisor is zero, and we use the+-- standard error type 'Control.Exception.ArithException' for this purpose.+-- However, the user may use other type to represent errors, so we need this+-- type class to transform the 'Control.Exception.ArithException' to the+-- user-defined types.+--+-- Another example of these generic procedures is the+-- 'Grisette.Core.symAssert' and 'Grisette.Core.symAssume' functions.+-- They can be used with any error types that are+-- compatible with the 'Grisette.Core.AssertionError' and+-- 'Grisette.Core.VerificationConditions' types, respectively.+class TransformError from to where+  -- | Transforms an error with type @from@ to an error with type @to@.+  transformError :: from -> to++instance {-# OVERLAPPABLE #-} TransformError a a where+  transformError = id+  {-# INLINE transformError #-}++instance {-# OVERLAPS #-} TransformError a () where+  transformError _ = ()+  {-# INLINE transformError #-}++instance {-# OVERLAPPING #-} TransformError () () where+  transformError _ = ()+  {-# INLINE transformError #-}++-- | Used within a monadic multi path computation to begin exception processing.+--+-- Terminate the current execution path with the specified error. Compatible+-- errors can be transformed.+--+-- >>> symThrowTransformableError Overflow :: ExceptT AssertionError Union ()+-- ExceptT {Left AssertionError}+symThrowTransformableError ::+  ( Mergeable to,+    Mergeable a,+    TransformError from to,+    MonadError to erm,+    MonadUnion erm+  ) =>+  from ->+  erm a+symThrowTransformableError = tryMerge . throwError . transformError+{-# INLINE symThrowTransformableError #-}++-- | Used within a monadic multi path computation for exception processing.+--+-- Terminate the current execution path with the specified error if the condition does not hold.+-- Compatible error can be transformed.+--+-- >>> let assert = symAssertTransformableError AssertionError :: SymBool -> ExceptT AssertionError Union ()+-- >>> assert "a"+-- ExceptT {If (! a) (Left AssertionError) (Right ())}+symAssertTransformableError ::+  ( Mergeable to,+    TransformError from to,+    MonadError to erm,+    MonadUnion erm+  ) =>+  from ->+  SymBool ->+  erm ()+symAssertTransformableError err cond = mrgIf cond (return ()) (symThrowTransformableError err)+{-# INLINE symAssertTransformableError #-}++-- | Symbolic assertion with a custom error.+symAssertWith ::+  ( Mergeable e,+    MonadError e erm,+    MonadUnion erm+  ) =>+  e ->+  SymBool ->+  erm ()+symAssertWith err cond = mrgIf cond (return ()) (throwError err)+{-# INLINE symAssertWith #-}++instance TransformError VerificationConditions VerificationConditions where+  transformError = id++instance TransformError AssertionError VerificationConditions where+  transformError _ = AssertionViolation++instance TransformError ArithException AssertionError where+  transformError _ = AssertionError++instance TransformError ArrayException AssertionError where+  transformError _ = AssertionError++instance TransformError AssertionError AssertionError where+  transformError = id++-- | Used within a monadic multi path computation to begin exception processing.+--+-- Checks the condition passed to the function.+-- The current execution path will be terminated with assertion error if the condition is false.+--+-- If the condition is symbolic, Grisette will split the execution into two paths based on the condition.+-- The symbolic execution will continue on the then-branch, where the condition is true.+-- For the else branch, where the condition is false, the execution will be terminated.+--+-- The resulting monadic environment should be compatible with the t'AssertionError'+-- error type. See 'TransformError' type class for details.+--+-- __/Examples/__:+--+-- Terminates the execution if the condition is false.+-- Note that we may lose the 'Mergeable' knowledge here if no possible execution+-- path is viable. This may affect the efficiency in theory, but in practice this+-- should not be a problem as all paths are terminated and no further evaluation+-- would be performed.+--+-- >>> symAssert (con False) :: ExceptT AssertionError Union ()+-- ExceptT {Left AssertionError}+-- >>> do; symAssert (con False); mrgReturn 1 :: ExceptT AssertionError Union Integer+-- ExceptT <Left AssertionError>+--+-- No effect if the condition is true:+--+-- >>> symAssert (con True) :: ExceptT AssertionError Union ()+-- ExceptT {Right ()}+-- >>> 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 Union ()+-- ExceptT {If (! a) (Left AssertionError) (Right ())}+-- >>> do; symAssert (ssym "a"); mrgReturn 1 :: ExceptT AssertionError Union Integer+-- ExceptT {If (! a) (Left AssertionError) (Right 1)}+--+-- t'AssertionError' is compatible with 'VerificationConditions':+--+-- >>> symAssert (ssym "a") :: ExceptT VerificationConditions Union ()+-- ExceptT {If (! a) (Left AssertionViolation) (Right ())}+symAssert ::+  (TransformError AssertionError to, Mergeable to, MonadError to erm, MonadUnion erm) =>+  SymBool ->+  erm ()+symAssert = symAssertTransformableError AssertionError++-- | Used within a monadic multi path computation to begin exception processing.+--+-- Similar to 'symAssert', but terminates the execution path with 'AssumptionViolation' error.+--+-- /Examples/:+--+-- >>> symAssume (ssym "a") :: ExceptT VerificationConditions Union ()+-- ExceptT {If (! a) (Left AssumptionViolation) (Right ())}+symAssume ::+  (TransformError VerificationConditions to, Mergeable to, MonadError to erm, MonadUnion erm) =>+  SymBool ->+  erm ()+symAssume = symAssertTransformableError AssumptionViolation
+ src/Grisette/Internal/Core/Data/Class/EvalSym.hs view
@@ -0,0 +1,31 @@+{-# OPTIONS_GHC -Wno-missing-import-lists #-}++-- |+-- 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 Grisette.Internal.Internal.Decl.Core.Data.Class.EvalSym+import Grisette.Internal.Internal.Impl.Core.Data.Class.EvalSym ()
+ src/Grisette/Internal/Core/Data/Class/ExtractSym.hs view
@@ -0,0 +1,30 @@+{-# OPTIONS_GHC -Wno-missing-import-lists #-}++-- |+-- 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 (..),+    extractSymMaybe1,+    extractSym1,+    ExtractSym2 (..),+    extractSymMaybe2,+    extractSym2,++    -- * Generic 'ExtractSym'+    ExtractSymArgs (..),+    GExtractSym (..),+    genericExtractSymMaybe,+    genericLiftExtractSymMaybe,+  )+where++import Grisette.Internal.Internal.Decl.Core.Data.Class.ExtractSym+import Grisette.Internal.Internal.Impl.Core.Data.Class.ExtractSym ()
+ src/Grisette/Internal/Core/Data/Class/Function.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeFamilies #-}++-- |+-- Module      :   Grisette.Internal.Core.Data.Class.Function+-- 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.Function+  ( -- * Function operations+    Function (..),+    Apply (..),+  )+where++-- $setup+-- >>> import Grisette.Core+-- >>> import Grisette.SymPrim++-- | Abstraction for function-like types.+class Function f arg ret | f -> arg ret where+  -- | Function application operator.+  --+  -- The operator is not right associated (like `($)`). It is left associated,+  -- and you can provide many arguments with this operator once at a time.+  --+  -- >>> (+1) # 2+  -- 3+  --+  -- >>> (+) # 2 # 3+  -- 5+  (#) :: f -> arg -> ret++  infixl 9 #++instance Function (a -> b) a b where+  f # a = f a++-- | Applying an uninterpreted function.+--+-- >>> let f = "f" :: SymInteger =~> SymInteger =~> SymInteger+-- >>> apply f "a" "b"+-- (apply (apply f a) b)+--+-- Note that for implementation reasons, you can also use `apply` function on+-- a non-function symbolic value. In this case, the function is treated as an+-- `id` function.+class Apply uf where+  type FunType uf+  apply :: uf -> FunType uf++instance Apply Integer where+  type FunType Integer = Integer+  apply = id++instance Apply Bool where+  type FunType Bool = Bool+  apply = id++instance (Apply b) => Apply (a -> b) where+  type FunType (a -> b) = a -> FunType b+  apply f a = apply (f a)
+ src/Grisette/Internal/Core/Data/Class/GenSym.hs view
@@ -0,0 +1,1827 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.Core.Data.Class.GenSym+-- 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.GenSym+  ( -- * Indices and identifiers for fresh symbolic value generation+    FreshIndex (..),++    -- * Monad for fresh symbolic value generation+    MonadFresh (..),+    nextFreshIndex,+    liftFresh,+    FreshT (FreshT, runFreshTFromIndex),+    Fresh,+    runFreshT,+    runFresh,+    mrgRunFreshT,+    freshString,++    -- * Symbolic value generation+    GenSym (..),+    GenSymSimple (..),+    genSym,+    genSymSimple,+    derivedNoSpecFresh,+    derivedNoSpecSimpleFresh,+    derivedSameShapeSimpleFresh,++    -- * Symbolic choices+    chooseFresh,+    chooseSimpleFresh,+    chooseUnionFresh,+    choose,+    chooseSimple,+    chooseUnion,++    -- * Some common GenSym specifications+    ListSpec (..),+    SimpleListSpec (..),+    EnumGenBound (..),+    EnumGenUpperBound (..),+  )+where++import Control.Monad.Except+  ( ExceptT (ExceptT),+    MonadError (catchError, throwError),+  )+import Control.Monad.Identity (Identity (runIdentity))+import Control.Monad.RWS.Class+  ( MonadRWS,+    MonadReader (ask, local),+    MonadState (get, put),+    MonadWriter (listen, pass, writer),+    asks,+    gets,+  )+import qualified Control.Monad.RWS.Lazy as RWSLazy+import qualified Control.Monad.RWS.Strict as RWSStrict+import Control.Monad.Reader (ReaderT (ReaderT))+import Control.Monad.Signatures (Catch)+import qualified Control.Monad.State.Lazy as StateLazy+import qualified Control.Monad.State.Strict as StateStrict+import Control.Monad.Trans.Class+  ( MonadTrans (lift),+  )+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 (first))+import qualified Data.ByteString as B+import Data.Int (Int16, Int32, Int64, Int8)+import Data.List (groupBy, sortOn)+import Data.Ratio (Ratio)+import Data.String (IsString (fromString))+import qualified Data.Text as T+import Data.Typeable (Typeable)+import Data.Word (Word16, Word32, Word64, Word8)+import GHC.TypeNats (KnownNat, type (<=))+import Generics.Deriving+  ( Generic (Rep, from, to),+    K1 (K1),+    M1 (M1),+    U1 (U1),+    type (:*:) ((:*:)),+    type (:+:) (L1, R1),+  )+import Grisette.Internal.Core.Control.Monad.Union+  ( Union,+    isMerged,+    unionBase,+  )+import Grisette.Internal.Core.Data.Class.AsKey (AsKey (AsKey), AsKey1 (AsKey1))+import Grisette.Internal.Core.Data.Class.Mergeable+  ( Mergeable (rootStrategy, sortIndices),+    Mergeable1 (liftRootStrategy),+    Mergeable2 (liftRootStrategy2),+    MergingStrategy (SimpleStrategy),+    rootStrategy1,+    wrapStrategy,+  )+import Grisette.Internal.Core.Data.Class.SimpleMergeable+  ( SimpleMergeable (mrgIte),+    SimpleMergeable1 (liftMrgIte),+    SymBranching (mrgIfPropagatedStrategy, mrgIfWithStrategy),+    mrgIf,+  )+import Grisette.Internal.Core.Data.Class.Solvable (Solvable (isym))+import Grisette.Internal.Core.Data.Class.TryMerge+  ( TryMerge (tryMergeWithStrategy),+    mrgSingle,+    tryMerge,+  )+import Grisette.Internal.Core.Data.Symbol (Identifier)+import Grisette.Internal.Internal.Decl.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 (-->))+import Grisette.Internal.SymPrim.Prim.Term+  ( LinkedRep,+    SupportedNonFuncPrim,+    SupportedPrim,+  )+import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal)+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 (-~>) (SymGeneralFun))+import Grisette.Internal.SymPrim.SymInteger (SymInteger)+import Grisette.Internal.SymPrim.SymTabularFun (type (=~>) (SymTabularFun))+import Grisette.Internal.SymPrim.TabularFun (type (=->))+import Grisette.Unified.Lib.Data.Functor (mrgFmap)++-- $setup+-- >>> import Grisette.Core+-- >>> import Grisette.SymPrim++-- | Index type used for 'GenSym'.+--+-- To generate fresh variables, a monadic stateful context will be maintained.+-- The index should be increased every time a new symbolic constant is+-- generated.+newtype FreshIndex = FreshIndex Int+  deriving (Show)+  deriving (Eq, Ord, Num) via Int++instance Mergeable FreshIndex where+  rootStrategy = SimpleStrategy $ \_ t f -> max t f++instance SimpleMergeable FreshIndex where+  mrgIte _ = max++-- | Monad class for fresh symbolic value generation.+--+-- The monad should be a reader monad for the 'Identifier' and a state monad for+-- the t'FreshIndex'.+class (Monad m) => MonadFresh m where+  -- | Get the current index for fresh variable generation.+  getFreshIndex :: m FreshIndex++  -- | Set the current index for fresh variable generation.+  setFreshIndex :: FreshIndex -> m ()++  -- | Get the identifier.+  getIdentifier :: m Identifier++  -- | Change the identifier locally and use a new index from 0 locally.+  localIdentifier :: (Identifier -> Identifier) -> m a -> m a++-- | Get the next fresh index and increase the current index.+nextFreshIndex :: (MonadFresh m) => m FreshIndex+nextFreshIndex = do+  curr <- getFreshIndex+  let new = curr + 1+  setFreshIndex new+  return curr++-- | Lifts an @`Fresh` a@ into any `MonadFresh`.+liftFresh :: (MonadFresh m) => Fresh a -> m a+liftFresh (FreshT f) = do+  index <- nextFreshIndex+  ident <- getIdentifier+  let (a, newIdx) = runIdentity $ f ident index+  setFreshIndex newIdx+  return a++-- | Generate a fresh string with the given postfix.+--+-- >>> runFresh (freshString "b") "a" :: String+-- "a@0[b]"+freshString :: (MonadFresh m, IsString s) => String -> m s+freshString postfix = do+  ident <- getIdentifier+  FreshIndex index <- nextFreshIndex+  return $+    fromString $+      show ident <> "@" <> show index <> "[" <> postfix <> "]"++-- | A symbolic generation monad transformer.+--+-- It is a reader monad transformer for an identifier and a state monad+-- transformer for indices.+--+-- Each time a fresh symbolic variable is generated, the index should be+-- increased.+newtype FreshT m a = FreshT+  { runFreshTFromIndex :: Identifier -> FreshIndex -> m (a, FreshIndex)+  }++instance+  (Mergeable a, Mergeable1 m) =>+  Mergeable (FreshT m a)+  where+  rootStrategy =+    wrapStrategy+      (liftRootStrategy (liftRootStrategy rootStrategy1))+      FreshT+      runFreshTFromIndex++instance (Mergeable1 m) => Mergeable1 (FreshT m) where+  liftRootStrategy m =+    wrapStrategy+      ( liftRootStrategy . liftRootStrategy . liftRootStrategy $+          liftRootStrategy2 m rootStrategy+      )+      FreshT+      runFreshTFromIndex++instance+  (SymBranching m, Mergeable a) =>+  SimpleMergeable (FreshT m a)+  where+  mrgIte = mrgIf++instance+  (SymBranching m) =>+  SimpleMergeable1 (FreshT m)+  where+  liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m)++instance (TryMerge m) => TryMerge (FreshT m) where+  tryMergeWithStrategy s (FreshT f) =+    FreshT $ \ident index ->+      tryMergeWithStrategy (liftRootStrategy2 s rootStrategy) $ f ident index++instance+  (SymBranching m) =>+  SymBranching (FreshT m)+  where+  mrgIfWithStrategy s cond (FreshT t) (FreshT f) =+    FreshT $ \ident index ->+      mrgIfWithStrategy+        (liftRootStrategy2 s rootStrategy)+        cond+        (t ident index)+        (f ident index)+  mrgIfPropagatedStrategy cond (FreshT t) (FreshT f) =+    FreshT $ \ident index ->+      mrgIfPropagatedStrategy cond (t ident index) (f ident index)++-- | Run the symbolic generation with the given identifier and 0 as the initial+-- index.+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 ->+  Identifier ->+  m a+mrgRunFreshT m ident = tryMerge $ runFreshT m ident++instance (Functor f) => Functor (FreshT f) where+  fmap f (FreshT s) = FreshT $ \ident idx -> first f <$> s ident idx++instance (Applicative m, Monad m) => Applicative (FreshT m) where+  pure a = FreshT $ \_ idx -> pure (a, idx)+  FreshT fs <*> FreshT as = FreshT $ \ident idx -> do+    (f, idx') <- fs ident idx+    (a, idx'') <- as ident idx'+    return (f a, idx'')++instance (Monad m) => Monad (FreshT m) where+  (FreshT s) >>= f = FreshT $ \ident idx -> do+    (a, idx') <- s ident idx+    runFreshTFromIndex (f a) ident idx'++instance MonadTrans FreshT where+  lift x = FreshT $ \_ index -> (,index) <$> x++liftFreshTCache :: (Functor m) => Catch e m (a, FreshIndex) -> Catch e (FreshT m) a+liftFreshTCache catchE (FreshT m) h =+  FreshT $ \ident index -> m ident index `catchE` \e -> runFreshTFromIndex (h e) ident index++instance (MonadError e m) => MonadError e (FreshT m) where+  throwError = lift . throwError+  catchError = liftFreshTCache catchError++instance (MonadWriter w m) => MonadWriter w (FreshT m) where+  writer p = FreshT $ \_ index -> (,index) <$> writer p+  listen (FreshT r) = FreshT $ \ident index -> (\((a, b), c) -> ((a, c), b)) <$> listen (r ident index)+  pass (FreshT r) = FreshT $ \ident index -> pass $ (\((a, b), c) -> ((a, c), b)) <$> r ident index++instance (MonadState s m) => MonadState s (FreshT m) where+  get = FreshT $ \_ index -> gets (,index)+  put s = FreshT $ \_ index -> (,index) <$> put s++instance (MonadReader r m) => MonadReader r (FreshT m) where+  local t (FreshT r) = FreshT $ \ident index -> local t (r ident index)+  ask = FreshT $ \_ index -> asks (,index)++instance (MonadRWS r w s m) => MonadRWS r w s (FreshT m)++instance (MonadFresh m) => MonadFresh (ExceptT e m) where+  getFreshIndex = lift getFreshIndex+  setFreshIndex newIdx = lift $ setFreshIndex newIdx+  getIdentifier = lift getIdentifier+  localIdentifier f (ExceptT m) = ExceptT $ localIdentifier f m++instance (MonadFresh m, Monoid w) => MonadFresh (WriterLazy.WriterT w m) where+  getFreshIndex = lift getFreshIndex+  setFreshIndex newIdx = lift $ setFreshIndex newIdx+  getIdentifier = lift getIdentifier+  localIdentifier f (WriterLazy.WriterT m) =+    WriterLazy.WriterT $ localIdentifier f m++instance (MonadFresh m, Monoid w) => MonadFresh (WriterStrict.WriterT w m) where+  getFreshIndex = lift getFreshIndex+  setFreshIndex newIdx = lift $ setFreshIndex newIdx+  getIdentifier = lift getIdentifier+  localIdentifier f (WriterStrict.WriterT m) =+    WriterStrict.WriterT $ localIdentifier f m++instance (MonadFresh m) => MonadFresh (StateLazy.StateT s m) where+  getFreshIndex = lift getFreshIndex+  setFreshIndex newIdx = lift $ setFreshIndex newIdx+  getIdentifier = lift getIdentifier+  localIdentifier f (StateLazy.StateT m) =+    StateLazy.StateT $ \s -> localIdentifier f (m s)++instance (MonadFresh m) => MonadFresh (StateStrict.StateT s m) where+  getFreshIndex = lift getFreshIndex+  setFreshIndex newIdx = lift $ setFreshIndex newIdx+  getIdentifier = lift getIdentifier+  localIdentifier f (StateStrict.StateT m) =+    StateStrict.StateT $ \s -> localIdentifier f (m s)++instance (MonadFresh m) => MonadFresh (ReaderT r m) where+  getFreshIndex = lift getFreshIndex+  setFreshIndex newIdx = lift $ setFreshIndex newIdx+  getIdentifier = lift getIdentifier+  localIdentifier f (ReaderT m) = ReaderT $ localIdentifier f . m++instance (MonadFresh m, Monoid w) => MonadFresh (RWSLazy.RWST r w s m) where+  getFreshIndex = lift getFreshIndex+  setFreshIndex newIdx = lift $ setFreshIndex newIdx+  getIdentifier = lift getIdentifier+  localIdentifier f (RWSLazy.RWST m) =+    RWSLazy.RWST $ \r s -> localIdentifier f (m r s)++instance (MonadFresh m, Monoid w) => MonadFresh (RWSStrict.RWST r w s m) where+  getFreshIndex = lift getFreshIndex+  setFreshIndex newIdx = lift $ setFreshIndex newIdx+  getIdentifier = lift getIdentifier+  localIdentifier f (RWSStrict.RWST m) =+    RWSStrict.RWST $ \r s -> localIdentifier f (m r s)++-- | t'FreshT' specialized with Identity.+type Fresh = FreshT Identity++-- | Run the symbolic generation with the given identifier and 0 as the initial+-- index.+runFresh :: Fresh a -> Identifier -> a+runFresh m ident = runIdentity $ runFreshT m ident++instance (Monad m) => MonadFresh (FreshT m) where+  getFreshIndex = FreshT $ \_ idx -> return (idx, idx)+  setFreshIndex newIdx = FreshT $ \_ _ -> return ((), newIdx)+  getIdentifier = FreshT $ curry return+  localIdentifier f (FreshT m) = FreshT $ \ident idx -> do+    let newIdent = f ident+    (r, _) <- m newIdent 0+    return (r, idx)++-- | Class of types in which symbolic values can be generated with respect to+-- some specification.+--+-- The result will be wrapped in a union-like monad.+-- This ensures that we can generate those types with complex merging rules.+--+-- The uniqueness of symbolic constants is managed with the a monadic context.+-- 'Fresh' and t'FreshT' can be useful.+class (Mergeable a) => GenSym spec a where+  -- | Generate a symbolic value given some specification. Within a single+  -- `MonadFresh` context, calls to `fresh` would generate unique symbolic+  -- constants.+  --+  -- The following example generates a symbolic boolean. No specification is+  -- needed.+  --+  -- >>> 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" :: 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" :: 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" :: 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" :: (Union SymBool, Union SymBool)+  -- ({a@0},{a@1})+  fresh ::+    (MonadFresh m) =>+    spec ->+    m (Union a)+  default fresh ::+    (GenSymSimple spec a) =>+    (MonadFresh m) =>+    spec ->+    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" :: Union [SymBool]+-- {If a@2 [a@1] [a@0,a@1]}+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.+--+-- The result will __/not/__ be wrapped in a union-like monad.+--+-- The uniqueness of symbolic constants is managed with the a monadic context.+-- 'Fresh' and t'FreshT' can be useful.+class GenSymSimple spec a where+  -- | Generate a symbolic value given some specification. The uniqueness is ensured.+  --+  -- The following example generates a symbolic boolean. No specification is needed.+  --+  -- >>> runFresh (simpleFresh ()) "a" :: SymBool+  -- a@0+  --+  -- The following code generates list of symbolic boolean with length 2.+  -- As the length is fixed, we don't have to wrap the result in unions.+  --+  -- >>> runFresh (simpleFresh (SimpleListSpec 2 ())) "a" :: [SymBool]+  -- [a@0,a@1]+  simpleFresh ::+    (MonadFresh m) =>+    spec ->+    m a++-- | Generate a simple 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.+--+-- >>> genSymSimple (SimpleListSpec 2 ()) "a" :: [SymBool]+-- [a@0,a@1]+genSymSimple :: forall spec a. (GenSymSimple spec a) => spec -> Identifier -> a+genSymSimple = runFresh . simpleFresh++class GenSymNoSpec a where+  freshNoSpec ::+    (MonadFresh m) =>+    m (Union (a c))++instance GenSymNoSpec U1 where+  freshNoSpec = return $ mrgSingle U1++instance (GenSym () c) => GenSymNoSpec (K1 i c) where+  freshNoSpec = fmap K1 <$> fresh ()++instance (GenSymNoSpec a) => GenSymNoSpec (M1 i c a) where+  freshNoSpec = fmap M1 <$> freshNoSpec++instance+  ( GenSymNoSpec a,+    GenSymNoSpec b,+    forall x. Mergeable (a x),+    forall x. Mergeable (b x)+  ) =>+  GenSymNoSpec (a :+: b)+  where+  freshNoSpec ::+    forall m c.+    (MonadFresh m) =>+    m (Union ((a :+: b) c))+  freshNoSpec = do+    cond :: bool <- simpleFresh ()+    l :: Union (a c) <- freshNoSpec+    r :: Union (b c) <- freshNoSpec+    return $ mrgIf cond (fmap L1 l) (fmap R1 r)++instance+  (GenSymNoSpec a, GenSymNoSpec b) =>+  GenSymNoSpec (a :*: b)+  where+  freshNoSpec ::+    forall m c.+    (MonadFresh m) =>+    m (Union ((a :*: b) c))+  freshNoSpec = do+    l :: Union (a c) <- freshNoSpec+    r :: Union (b c) <- freshNoSpec+    return $ do+      l1 <- l+      r1 <- r+      return $ l1 :*: r1++-- | We cannot provide DerivingVia style derivation for 'GenSym', while you can+-- use this 'fresh' implementation to implement 'GenSym' for your own types.+--+-- This 'fresh' implementation is for the types that does not need any specification.+-- It will generate product types by generating each fields with @()@ as specification,+-- and generate all possible values for a sum type.+--+-- __Note:__ __Never__ use on recursive types.+derivedNoSpecFresh ::+  forall a m.+  ( Generic a,+    GenSymNoSpec (Rep a),+    Mergeable a,+    MonadFresh m+  ) =>+  () ->+  m (Union a)+derivedNoSpecFresh _ = tryMerge . fmap to <$> freshNoSpec++class GenSymSimpleNoSpec a where+  simpleFreshNoSpec :: (MonadFresh m) => m (a c)++instance GenSymSimpleNoSpec U1 where+  simpleFreshNoSpec = return U1++instance (GenSymSimple () c) => GenSymSimpleNoSpec (K1 i c) where+  simpleFreshNoSpec = K1 <$> simpleFresh ()++instance (GenSymSimpleNoSpec a) => GenSymSimpleNoSpec (M1 i c a) where+  simpleFreshNoSpec = M1 <$> simpleFreshNoSpec++instance+  (GenSymSimpleNoSpec a, GenSymSimpleNoSpec b) =>+  GenSymSimpleNoSpec (a :*: b)+  where+  simpleFreshNoSpec = do+    l :: a c <- simpleFreshNoSpec+    r :: b c <- simpleFreshNoSpec+    return $ l :*: r++-- | We cannot provide DerivingVia style derivation for 'GenSymSimple', while+-- you can use this 'simpleFresh' implementation to implement 'GenSymSimple' fo+-- 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 not work on sum types.+--+-- __Note:__ __Never__ use on recursive types.+derivedNoSpecSimpleFresh ::+  forall a m.+  ( Generic a,+    GenSymSimpleNoSpec (Rep a),+    MonadFresh m+  ) =>+  () ->+  m a+derivedNoSpecSimpleFresh _ = to <$> simpleFreshNoSpec++class GenSymSameShape a where+  genSymSameShapeFresh ::+    (MonadFresh m) =>+    a c ->+    m (a c)++instance GenSymSameShape U1 where+  genSymSameShapeFresh _ = return U1++instance (GenSymSimple c c) => GenSymSameShape (K1 i c) where+  genSymSameShapeFresh (K1 c) = K1 <$> simpleFresh c++instance (GenSymSameShape a) => GenSymSameShape (M1 i c a) where+  genSymSameShapeFresh (M1 a) = M1 <$> genSymSameShapeFresh a++instance+  (GenSymSameShape a, GenSymSameShape b) =>+  GenSymSameShape (a :+: b)+  where+  genSymSameShapeFresh (L1 a) = L1 <$> genSymSameShapeFresh a+  genSymSameShapeFresh (R1 a) = R1 <$> genSymSameShapeFresh a++instance+  (GenSymSameShape a, GenSymSameShape b) =>+  GenSymSameShape (a :*: b)+  where+  genSymSameShapeFresh (a :*: b) = do+    l :: a c <- genSymSameShapeFresh a+    r :: b c <- genSymSameShapeFresh b+    return $ l :*: r++-- | We cannot provide DerivingVia style derivation for 'GenSymSimple', while+-- you can use this 'simpleFresh' implementation to implement 'GenSymSimple' fo+-- your own types.+--+-- This 'simpleFresh' implementation is for the types that can be generated with+-- a reference value of the same type.+--+-- For sum types, it will generate the result with the same data constructor.+-- For product types, it will generate the result by generating each field with+-- the corresponding reference value.+--+-- __Note:__ __Can__ be used on recursive types.+derivedSameShapeSimpleFresh ::+  forall a m.+  ( Generic a,+    GenSymSameShape (Rep a),+    MonadFresh m+  ) =>+  a ->+  m a+derivedSameShapeSimpleFresh a = to <$> genSymSameShapeFresh (from a)++genGuardsUnion :: (MonadFresh m, Mergeable a) => [Union a] -> m (Union a)+genGuardsUnion [x] = return x+genGuardsUnion (r : rs) = do+  b <- simpleFresh ()+  res <- genGuardsUnion rs+  return $ mrgIf b r res+genGuardsUnion [] = error "chooseFresh expects at least one value"++genGuards :: (MonadFresh m, Mergeable a) => [a] -> m (Union a)+genGuards [x] = return $ mrgSingle x+genGuards (r : rs) = do+  b <- simpleFresh ()+  res <- genGuards rs+  return $ mrgIf b (mrgSingle r) res+genGuards [] = error "chooseFresh expects at least one value"++genGuardsSimple :: (MonadFresh m, SimpleMergeable a) => [a] -> m a+genGuardsSimple [x] = return x+genGuardsSimple (r : rs) = do+  b <- simpleFresh ()+  res <- genGuardsSimple rs+  return $ mrgIte b r res+genGuardsSimple [] = error "chooseFresh expects at least one value"++leveledChoose ::+  (Monad m, Mergeable b1) =>+  ([b2] -> m b2) -> ([b1] -> m b2) -> [b1] -> m b2+leveledChoose gen gen' l = go 0 choicesWithIndices+  where+    indices = sortIndices <$> l+    choicesWithIndices = sortOn snd $ zip l indices+    go i l = do+      let grouped =+            groupBy+              ( \(_, a) (_, b) ->+                  (length a <= i && length b <= i) || a !! i == b !! i+              )+              l+      allChoices <- traverse (go' i) grouped+      gen allChoices+    go' i l =+      if length (snd $ head l) <= i+        then gen' $ fst <$> l+        else go (i + 1) l++-- | Symbolically chooses one of the provided values.+-- The procedure creates @n - 1@ fresh symbolic boolean variables every time it+-- is evaluated, and use these variables to conditionally select one of the @n@+-- provided expressions.+--+-- The result will be wrapped in a union-like monad, and also a monad+-- maintaining the 'MonadFresh' context.+--+-- >>> runFresh (chooseFresh [1,2,3]) "a" :: Union Integer+-- {If a@0 1 (If a@1 2 3)}+chooseFresh ::+  forall a m.+  ( Mergeable a,+    MonadFresh m+  ) =>+  [a] ->+  m (Union a)+chooseFresh = leveledChoose genGuardsUnion genGuards++-- | A wrapper for `chooseFresh` that executes the `MonadFresh` context.+-- A globally unique identifier should be supplied to ensure the uniqueness of+-- symbolic constants in the generated symbolic values.+choose ::+  forall a.+  (Mergeable a) =>+  [a] ->+  Identifier ->+  Union a+choose = runFresh . chooseFresh++-- | Symbolically chooses one of the provided values.+-- The procedure creates @n - 1@ fresh symbolic boolean variables every time it is evaluated, and use+-- these variables to conditionally select one of the @n@ provided expressions.+--+-- The result will __/not/__ be wrapped in a union-like monad, but will be+-- wrapped in a monad maintaining the 'Fresh' context.+--+-- >>> import Data.Proxy+-- >>> runFresh (chooseSimpleFresh [ssym "b", ssym "c", ssym "d"]) "a" :: SymInteger+-- (ite a@0 b (ite a@1 c d))+chooseSimpleFresh ::+  forall a m.+  ( SimpleMergeable a,+    MonadFresh m+  ) =>+  [a] ->+  m a+chooseSimpleFresh = leveledChoose genGuardsSimple genGuardsSimple++-- | A wrapper for `chooseSimpleFresh` that executes the `MonadFresh` context.+-- A globally unique identifier should be supplied to ensure the uniqueness of+-- symbolic constants in the generated symbolic values.+chooseSimple ::+  forall a.+  (SimpleMergeable a) =>+  [a] ->+  Identifier ->+  a+chooseSimple = runFresh . chooseSimpleFresh++-- | Symbolically chooses one of the provided values wrapped in union-like+-- monads. The procedure creates @n - 1@ fresh symbolic boolean variables every+-- time it is evaluated, and use these variables to conditionally select one of+-- the @n@ provided expressions.+--+-- 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" :: 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+  ) =>+  [Union a] ->+  m (Union a)+chooseUnionFresh = leveledChoose genGuardsUnion genGuardsUnion++-- | A wrapper for `chooseUnionFresh` that executes the `MonadFresh` context.+-- A globally unique identifier should be supplied to ensure the uniqueness of+-- symbolic constants in the generated symbolic values.+chooseUnion ::+  forall a.+  (Mergeable a) =>+  [Union a] ->+  Identifier ->+  Union a+chooseUnion = runFresh . chooseUnionFresh++#define CONCRETE_GENSYM_SAME_SHAPE(type) \+instance GenSym type type where fresh = return . mrgSingle++#define CONCRETE_GENSYMSIMPLE_SAME_SHAPE(type) \+instance GenSymSimple type type where simpleFresh = return++#define CONCRETE_GENSYM_SAME_SHAPE_BV(type) \+instance (KnownNat n, 1 <= n) => GenSym (type n) (type n) where fresh = return . mrgSingle++#define CONCRETE_GENSYMSIMPLE_SAME_SHAPE_BV(type) \+instance (KnownNat n, 1 <= n) => GenSymSimple (type n) (type n) where simpleFresh = return++#if 1+CONCRETE_GENSYM_SAME_SHAPE(Bool)+CONCRETE_GENSYM_SAME_SHAPE(Integer)+CONCRETE_GENSYM_SAME_SHAPE(Char)+CONCRETE_GENSYM_SAME_SHAPE(Int)+CONCRETE_GENSYM_SAME_SHAPE(Int8)+CONCRETE_GENSYM_SAME_SHAPE(Int16)+CONCRETE_GENSYM_SAME_SHAPE(Int32)+CONCRETE_GENSYM_SAME_SHAPE(Int64)+CONCRETE_GENSYM_SAME_SHAPE(Word)+CONCRETE_GENSYM_SAME_SHAPE(Word8)+CONCRETE_GENSYM_SAME_SHAPE(Word16)+CONCRETE_GENSYM_SAME_SHAPE(Word32)+CONCRETE_GENSYM_SAME_SHAPE(Word64)+CONCRETE_GENSYM_SAME_SHAPE(Float)+CONCRETE_GENSYM_SAME_SHAPE(Double)+CONCRETE_GENSYM_SAME_SHAPE(B.ByteString)+CONCRETE_GENSYM_SAME_SHAPE(T.Text)+CONCRETE_GENSYM_SAME_SHAPE(FPRoundingMode)+CONCRETE_GENSYM_SAME_SHAPE_BV(WordN)+CONCRETE_GENSYM_SAME_SHAPE_BV(IntN)++CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Bool)+CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Integer)+CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Char)+CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Int)+CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Int8)+CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Int16)+CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Int32)+CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Int64)+CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Word)+CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Word8)+CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Word16)+CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Word32)+CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Word64)+CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Float)+CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Double)+CONCRETE_GENSYMSIMPLE_SAME_SHAPE(B.ByteString)+CONCRETE_GENSYMSIMPLE_SAME_SHAPE(T.Text)+CONCRETE_GENSYMSIMPLE_SAME_SHAPE(FPRoundingMode)+CONCRETE_GENSYMSIMPLE_SAME_SHAPE_BV(WordN)+CONCRETE_GENSYMSIMPLE_SAME_SHAPE_BV(IntN)+#endif++instance (Integral a, Typeable a) => GenSym (Ratio a) (Ratio a) where+  fresh = return . mrgSingle++instance GenSymSimple (Ratio a) (Ratio a) where+  simpleFresh = return++instance (ValidFP eb sb) => GenSym (FP eb sb) (FP eb sb) where+  fresh = return . mrgSingle+  {-# INLINE fresh #-}++instance (ValidFP eb sb) => GenSymSimple (FP eb sb) (FP eb sb) where+  simpleFresh = return+  {-# INLINE simpleFresh #-}++-- Bool+instance GenSym () Bool where+  fresh = derivedNoSpecFresh++-- Enums++-- | Specification for enum values with upper bound (exclusive). The result would chosen from [0 .. upperbound].+--+-- >>> 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++instance (Enum v, Mergeable v) => GenSym (EnumGenUpperBound v) v where+  fresh (EnumGenUpperBound u) = chooseFresh (toEnum <$> [0 .. fromEnum u - 1])++-- | Specification for numbers with lower bound (inclusive) and upper bound (exclusive)+--+-- >>> 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++instance (Enum v, Mergeable v) => GenSym (EnumGenBound v) v where+  fresh (EnumGenBound l u) = chooseFresh (toEnum <$> [fromEnum l .. fromEnum u - 1])++-- Either+instance+  ( GenSym aspec a,+    Mergeable a,+    GenSym bspec b,+    Mergeable b+  ) =>+  GenSym (Either aspec bspec) (Either a b)+  where+  fresh (Left aspec) = (tryMerge . fmap Left) <$> fresh aspec+  fresh (Right bspec) = (tryMerge . fmap Right) <$> fresh bspec++instance+  ( GenSymSimple aspec a,+    GenSymSimple bspec b+  ) =>+  GenSymSimple (Either aspec bspec) (Either a b)+  where+  simpleFresh (Left a) = Left <$> simpleFresh a+  simpleFresh (Right b) = Right <$> simpleFresh b++instance+  (GenSym () a, Mergeable a, GenSym () b, Mergeable b) =>+  GenSym () (Either a b)+  where+  fresh = derivedNoSpecFresh++instance+  ( GenSym aspec a,+    Mergeable a,+    GenSym bspec b,+    Mergeable b+  ) =>+  GenSym (aspec, bspec) (Either a b)+  where+  fresh (aspec, bspec) = do+    l :: Union a <- fresh aspec+    r :: Union b <- fresh bspec+    chooseUnionFresh [Left <$> l, Right <$> r]++-- Maybe+instance+  {-# OVERLAPPING #-}+  (GenSym aspec a, Mergeable a) =>+  GenSym (Maybe aspec) (Maybe a)+  where+  fresh Nothing = return $ mrgSingle Nothing+  fresh (Just aspec) = (tryMerge . fmap Just) <$> fresh aspec++instance+  (GenSymSimple aspec a) =>+  GenSymSimple (Maybe aspec) (Maybe a)+  where+  simpleFresh Nothing = return Nothing+  simpleFresh (Just aspec) = Just <$> simpleFresh aspec++instance+  {-# OVERLAPPABLE #-}+  (GenSym aspec a, Mergeable a) =>+  GenSym aspec (Maybe a)+  where+  fresh aspec = do+    cond <- simpleFresh ()+    a :: Union a <- fresh aspec+    return $ mrgIf cond (mrgSingle Nothing) (Just <$> a)++-- List+instance+  (GenSym () a, Mergeable a) =>+  GenSym Integer [a]+  where+  fresh v = do+    l <- gl v+    let xs = reverse $ scanr (:) [] l+    chooseUnionFresh $ tryMerge . sequence <$> xs+    where+      gl :: (MonadFresh m) => Integer -> m [Union a]+      gl v1+        | v1 <= 0 = return []+        | otherwise = do+            l <- fresh ()+            r <- gl (v1 - 1)+            return $ l : r++-- | Specification for list generation.+--+-- >>> 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" :: 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+    genListMinLength :: Int,+    -- | The maximum length of the generated lists+    genListMaxLength :: Int,+    -- | Each element in the lists will be generated with the sub-specification+    genListSubSpec :: spec+  }+  deriving (Show)++instance+  (GenSym spec a, Mergeable a) =>+  GenSym (ListSpec spec) [a]+  where+  fresh (ListSpec minLen maxLen subSpec) =+    if minLen < 0 || maxLen < 0 || minLen >= maxLen+      then error $ "Bad lengths: " ++ show (minLen, maxLen)+      else do+        l <- gl maxLen+        let xs = drop minLen $ reverse $ scanr (:) [] l+        chooseUnionFresh $ tryMerge . sequence <$> xs+    where+      gl :: (MonadFresh m) => Int -> m [Union a]+      gl currLen+        | currLen <= 0 = return []+        | otherwise = do+            l <- fresh subSpec+            r <- gl (currLen - 1)+            return $ l : r++instance+  (GenSym a a, Mergeable a) =>+  GenSym [a] [a]+  where+  fresh l = do+    r :: [Union a] <- traverse fresh l+    return $ tryMerge $ sequence r++instance+  (GenSymSimple a a) =>+  GenSymSimple [a] [a]+  where+  simpleFresh = derivedSameShapeSimpleFresh++-- | Specification for list generation of a specific length.+--+-- >>> runFresh (simpleFresh (SimpleListSpec 2 ())) "c" :: [SymBool]+-- [c@0,c@1]+data SimpleListSpec spec = SimpleListSpec+  { -- | The length of the generated list+    genSimpleListLength :: Int,+    -- | Each element in the list will be generated with the sub-specification+    genSimpleListSubSpec :: spec+  }+  deriving (Show)++instance+  (GenSym spec a, Mergeable a) =>+  GenSym (SimpleListSpec spec) [a]+  where+  fresh (SimpleListSpec len subSpec) =+    if len < 0+      then error $ "Bad lengths: " ++ show len+      else do+        tryMerge . sequence <$> gl len+    where+      gl :: (MonadFresh m) => Int -> m [Union a]+      gl currLen+        | currLen <= 0 = return []+        | otherwise = do+            l <- fresh subSpec+            r <- gl (currLen - 1)+            return $ l : r++instance+  (GenSymSimple spec a) =>+  GenSymSimple (SimpleListSpec spec) [a]+  where+  simpleFresh (SimpleListSpec len subSpec) =+    if len < 0+      then error $ "Bad lengths: " ++ show len+      else do+        gl len+    where+      gl :: (MonadFresh m) => Int -> m [a]+      gl currLen+        | currLen <= 0 = return []+        | otherwise = do+            l <- simpleFresh subSpec+            r <- gl (currLen - 1)+            return $ l : r++-- ()+instance GenSym () ()++instance GenSymSimple () () where+  simpleFresh = derivedNoSpecSimpleFresh++-- (,)+instance+  ( GenSym aspec a,+    Mergeable a,+    GenSym bspec b,+    Mergeable b+  ) =>+  GenSym (aspec, bspec) (a, b)+  where+  fresh (aspec, bspec) = do+    a1 <- fresh aspec+    b1 <- fresh bspec+    return $ do+      ax <- a1+      bx <- b1+      mrgSingle (ax, bx)++instance+  ( GenSymSimple aspec a,+    GenSymSimple bspec b+  ) =>+  GenSymSimple (aspec, bspec) (a, b)+  where+  simpleFresh (aspec, bspec) = do+    (,)+      <$> simpleFresh aspec+      <*> simpleFresh bspec++instance+  (GenSym () a, Mergeable a, GenSym () b, Mergeable b) =>+  GenSym () (a, b)+  where+  fresh = derivedNoSpecFresh++instance+  ( GenSymSimple () a,+    GenSymSimple () b+  ) =>+  GenSymSimple () (a, b)+  where+  simpleFresh = derivedNoSpecSimpleFresh++-- (,,)+instance+  ( GenSym aspec a,+    Mergeable a,+    GenSym bspec b,+    Mergeable b,+    GenSym cspec c,+    Mergeable c+  ) =>+  GenSym (aspec, bspec, cspec) (a, b, c)+  where+  fresh (aspec, bspec, cspec) = do+    a1 <- fresh aspec+    b1 <- fresh bspec+    c1 <- fresh cspec+    return $ do+      ax <- a1+      bx <- b1+      cx <- c1+      mrgSingle (ax, bx, cx)++instance+  ( GenSymSimple aspec a,+    GenSymSimple bspec b,+    GenSymSimple cspec c+  ) =>+  GenSymSimple (aspec, bspec, cspec) (a, b, c)+  where+  simpleFresh (aspec, bspec, cspec) = do+    (,,)+      <$> simpleFresh aspec+      <*> simpleFresh bspec+      <*> simpleFresh cspec++instance+  ( GenSym () a,+    Mergeable a,+    GenSym () b,+    Mergeable b,+    GenSym () c,+    Mergeable c+  ) =>+  GenSym () (a, b, c)+  where+  fresh = derivedNoSpecFresh++instance+  ( GenSymSimple () a,+    GenSymSimple () b,+    GenSymSimple () c+  ) =>+  GenSymSimple () (a, b, c)+  where+  simpleFresh = derivedNoSpecSimpleFresh++-- (,,,)+instance+  ( GenSym aspec a,+    Mergeable a,+    GenSym bspec b,+    Mergeable b,+    GenSym cspec c,+    Mergeable c,+    GenSym dspec d,+    Mergeable d+  ) =>+  GenSym (aspec, bspec, cspec, dspec) (a, b, c, d)+  where+  fresh (aspec, bspec, cspec, dspec) = do+    a1 <- fresh aspec+    b1 <- fresh bspec+    c1 <- fresh cspec+    d1 <- fresh dspec+    return $ do+      ax <- a1+      bx <- b1+      cx <- c1+      dx <- d1+      mrgSingle (ax, bx, cx, dx)++instance+  ( GenSymSimple aspec a,+    GenSymSimple bspec b,+    GenSymSimple cspec c,+    GenSymSimple dspec d+  ) =>+  GenSymSimple (aspec, bspec, cspec, dspec) (a, b, c, d)+  where+  simpleFresh (aspec, bspec, cspec, dspec) = do+    (,,,)+      <$> simpleFresh aspec+      <*> simpleFresh bspec+      <*> simpleFresh cspec+      <*> simpleFresh dspec++instance+  ( GenSym () a,+    Mergeable a,+    GenSym () b,+    Mergeable b,+    GenSym () c,+    Mergeable c,+    GenSym () d,+    Mergeable d+  ) =>+  GenSym () (a, b, c, d)+  where+  fresh = derivedNoSpecFresh++instance+  ( GenSymSimple () a,+    GenSymSimple () b,+    GenSymSimple () c,+    GenSymSimple () d+  ) =>+  GenSymSimple () (a, b, c, d)+  where+  simpleFresh = derivedNoSpecSimpleFresh++-- (,,,,)+instance+  ( GenSym aspec a,+    Mergeable a,+    GenSym bspec b,+    Mergeable b,+    GenSym cspec c,+    Mergeable c,+    GenSym dspec d,+    Mergeable d,+    GenSym espec e,+    Mergeable e+  ) =>+  GenSym (aspec, bspec, cspec, dspec, espec) (a, b, c, d, e)+  where+  fresh (aspec, bspec, cspec, dspec, espec) = do+    a1 <- fresh aspec+    b1 <- fresh bspec+    c1 <- fresh cspec+    d1 <- fresh dspec+    e1 <- fresh espec+    return $ do+      ax <- a1+      bx <- b1+      cx <- c1+      dx <- d1+      ex <- e1+      mrgSingle (ax, bx, cx, dx, ex)++instance+  ( GenSymSimple aspec a,+    GenSymSimple bspec b,+    GenSymSimple cspec c,+    GenSymSimple dspec d,+    GenSymSimple espec e+  ) =>+  GenSymSimple (aspec, bspec, cspec, dspec, espec) (a, b, c, d, e)+  where+  simpleFresh (aspec, bspec, cspec, dspec, espec) = do+    (,,,,)+      <$> simpleFresh aspec+      <*> simpleFresh bspec+      <*> simpleFresh cspec+      <*> simpleFresh dspec+      <*> simpleFresh espec++instance+  ( GenSym () a,+    Mergeable a,+    GenSym () b,+    Mergeable b,+    GenSym () c,+    Mergeable c,+    GenSym () d,+    Mergeable d,+    GenSym () e,+    Mergeable e+  ) =>+  GenSym () (a, b, c, d, e)+  where+  fresh = derivedNoSpecFresh++instance+  ( GenSymSimple () a,+    GenSymSimple () b,+    GenSymSimple () c,+    GenSymSimple () d,+    GenSymSimple () e+  ) =>+  GenSymSimple () (a, b, c, d, e)+  where+  simpleFresh = derivedNoSpecSimpleFresh++-- (,,,,,)+instance+  ( GenSym aspec a,+    Mergeable a,+    GenSym bspec b,+    Mergeable b,+    GenSym cspec c,+    Mergeable c,+    GenSym dspec d,+    Mergeable d,+    GenSym espec e,+    Mergeable e,+    GenSym fspec f,+    Mergeable f+  ) =>+  GenSym (aspec, bspec, cspec, dspec, espec, fspec) (a, b, c, d, e, f)+  where+  fresh (aspec, bspec, cspec, dspec, espec, fspec) = do+    a1 <- fresh aspec+    b1 <- fresh bspec+    c1 <- fresh cspec+    d1 <- fresh dspec+    e1 <- fresh espec+    f1 <- fresh fspec+    return $ do+      ax <- a1+      bx <- b1+      cx <- c1+      dx <- d1+      ex <- e1+      fx <- f1+      mrgSingle (ax, bx, cx, dx, ex, fx)++instance+  ( GenSymSimple aspec a,+    GenSymSimple bspec b,+    GenSymSimple cspec c,+    GenSymSimple dspec d,+    GenSymSimple espec e,+    GenSymSimple fspec f+  ) =>+  GenSymSimple (aspec, bspec, cspec, dspec, espec, fspec) (a, b, c, d, e, f)+  where+  simpleFresh (aspec, bspec, cspec, dspec, espec, fspec) = do+    (,,,,,)+      <$> simpleFresh aspec+      <*> simpleFresh bspec+      <*> simpleFresh cspec+      <*> simpleFresh dspec+      <*> simpleFresh espec+      <*> simpleFresh fspec++instance+  ( GenSym () a,+    Mergeable a,+    GenSym () b,+    Mergeable b,+    GenSym () c,+    Mergeable c,+    GenSym () d,+    Mergeable d,+    GenSym () e,+    Mergeable e,+    GenSym () f,+    Mergeable f+  ) =>+  GenSym () (a, b, c, d, e, f)+  where+  fresh = derivedNoSpecFresh++instance+  ( GenSymSimple () a,+    GenSymSimple () b,+    GenSymSimple () c,+    GenSymSimple () d,+    GenSymSimple () e,+    GenSymSimple () f+  ) =>+  GenSymSimple () (a, b, c, d, e, f)+  where+  simpleFresh = derivedNoSpecSimpleFresh++-- (,,,,,,)+instance+  ( GenSym aspec a,+    Mergeable a,+    GenSym bspec b,+    Mergeable b,+    GenSym cspec c,+    Mergeable c,+    GenSym dspec d,+    Mergeable d,+    GenSym espec e,+    Mergeable e,+    GenSym fspec f,+    Mergeable f,+    GenSym gspec g,+    Mergeable g+  ) =>+  GenSym (aspec, bspec, cspec, dspec, espec, fspec, gspec) (a, b, c, d, e, f, g)+  where+  fresh (aspec, bspec, cspec, dspec, espec, fspec, gspec) = do+    a1 <- fresh aspec+    b1 <- fresh bspec+    c1 <- fresh cspec+    d1 <- fresh dspec+    e1 <- fresh espec+    f1 <- fresh fspec+    g1 <- fresh gspec+    return $ do+      ax <- a1+      bx <- b1+      cx <- c1+      dx <- d1+      ex <- e1+      fx <- f1+      gx <- g1+      mrgSingle (ax, bx, cx, dx, ex, fx, gx)++instance+  ( GenSymSimple aspec a,+    GenSymSimple bspec b,+    GenSymSimple cspec c,+    GenSymSimple dspec d,+    GenSymSimple espec e,+    GenSymSimple fspec f,+    GenSymSimple gspec g+  ) =>+  GenSymSimple (aspec, bspec, cspec, dspec, espec, fspec, gspec) (a, b, c, d, e, f, g)+  where+  simpleFresh (aspec, bspec, cspec, dspec, espec, fspec, gspec) = do+    (,,,,,,)+      <$> simpleFresh aspec+      <*> simpleFresh bspec+      <*> simpleFresh cspec+      <*> simpleFresh dspec+      <*> simpleFresh espec+      <*> simpleFresh fspec+      <*> simpleFresh gspec++instance+  ( GenSym () a,+    Mergeable a,+    GenSym () b,+    Mergeable b,+    GenSym () c,+    Mergeable c,+    GenSym () d,+    Mergeable d,+    GenSym () e,+    Mergeable e,+    GenSym () f,+    Mergeable f,+    GenSym () g,+    Mergeable g+  ) =>+  GenSym () (a, b, c, d, e, f, g)+  where+  fresh = derivedNoSpecFresh++instance+  ( GenSymSimple () a,+    GenSymSimple () b,+    GenSymSimple () c,+    GenSymSimple () d,+    GenSymSimple () e,+    GenSymSimple () f,+    GenSymSimple () g+  ) =>+  GenSymSimple () (a, b, c, d, e, f, g)+  where+  simpleFresh = derivedNoSpecSimpleFresh++-- (,,,,,,,)+instance+  ( GenSym aspec a,+    Mergeable a,+    GenSym bspec b,+    Mergeable b,+    GenSym cspec c,+    Mergeable c,+    GenSym dspec d,+    Mergeable d,+    GenSym espec e,+    Mergeable e,+    GenSym fspec f,+    Mergeable f,+    GenSym gspec g,+    Mergeable g,+    GenSym hspec h,+    Mergeable h+  ) =>+  GenSym (aspec, bspec, cspec, dspec, espec, fspec, gspec, hspec) (a, b, c, d, e, f, g, h)+  where+  fresh (aspec, bspec, cspec, dspec, espec, fspec, gspec, hspec) = do+    a1 <- fresh aspec+    b1 <- fresh bspec+    c1 <- fresh cspec+    d1 <- fresh dspec+    e1 <- fresh espec+    f1 <- fresh fspec+    g1 <- fresh gspec+    h1 <- fresh hspec+    return $ do+      ax <- a1+      bx <- b1+      cx <- c1+      dx <- d1+      ex <- e1+      fx <- f1+      gx <- g1+      hx <- h1+      mrgSingle (ax, bx, cx, dx, ex, fx, gx, hx)++instance+  ( GenSymSimple aspec a,+    GenSymSimple bspec b,+    GenSymSimple cspec c,+    GenSymSimple dspec d,+    GenSymSimple espec e,+    GenSymSimple fspec f,+    GenSymSimple gspec g,+    GenSymSimple hspec h+  ) =>+  GenSymSimple (aspec, bspec, cspec, dspec, espec, fspec, gspec, hspec) (a, b, c, d, e, f, g, h)+  where+  simpleFresh (aspec, bspec, cspec, dspec, espec, fspec, gspec, hspec) = do+    (,,,,,,,)+      <$> simpleFresh aspec+      <*> simpleFresh bspec+      <*> simpleFresh cspec+      <*> simpleFresh dspec+      <*> simpleFresh espec+      <*> simpleFresh fspec+      <*> simpleFresh gspec+      <*> simpleFresh hspec++instance+  ( GenSym () a,+    Mergeable a,+    GenSym () b,+    Mergeable b,+    GenSym () c,+    Mergeable c,+    GenSym () d,+    Mergeable d,+    GenSym () e,+    Mergeable e,+    GenSym () f,+    Mergeable f,+    GenSym () g,+    Mergeable g,+    GenSym () h,+    Mergeable h+  ) =>+  GenSym () (a, b, c, d, e, f, g, h)+  where+  fresh = derivedNoSpecFresh++instance+  ( GenSymSimple () a,+    GenSymSimple () b,+    GenSymSimple () c,+    GenSymSimple () d,+    GenSymSimple () e,+    GenSymSimple () f,+    GenSymSimple () g,+    GenSymSimple () h+  ) =>+  GenSymSimple () (a, b, c, d, e, f, g, h)+  where+  simpleFresh = derivedNoSpecSimpleFresh++-- MaybeT+instance+  {-# OVERLAPPABLE #-}+  ( GenSym spec (m (Maybe a)),+    Mergeable1 m,+    Mergeable a+  ) =>+  GenSym spec (MaybeT m a)+  where+  fresh v = do+    x <- fresh v+    return $ tryMerge . fmap MaybeT $ x++instance+  {-# OVERLAPPABLE #-}+  (GenSymSimple spec (m (Maybe a))) =>+  GenSymSimple spec (MaybeT m a)+  where+  simpleFresh v = MaybeT <$> simpleFresh v++instance+  {-# OVERLAPPING #-}+  (GenSymSimple (m (Maybe a)) (m (Maybe a))) =>+  GenSymSimple (MaybeT m a) (MaybeT m a)+  where+  simpleFresh (MaybeT v) = MaybeT <$> simpleFresh v++instance+  {-# OVERLAPPING #-}+  ( GenSymSimple (m (Maybe a)) (m (Maybe a)),+    Mergeable1 m,+    Mergeable a+  ) =>+  GenSym (MaybeT m a) (MaybeT m a)++-- ExceptT+instance+  {-# OVERLAPPABLE #-}+  ( GenSym spec (m (Either a b)),+    Mergeable1 m,+    Mergeable a,+    Mergeable b+  ) =>+  GenSym spec (ExceptT a m b)+  where+  fresh v = do+    x <- fresh v+    return $ tryMerge . fmap ExceptT $ x++instance+  {-# OVERLAPPABLE #-}+  (GenSymSimple spec (m (Either a b))) =>+  GenSymSimple spec (ExceptT a m b)+  where+  simpleFresh v = ExceptT <$> simpleFresh v++instance+  {-# OVERLAPPING #-}+  (GenSymSimple (m (Either e a)) (m (Either e a))) =>+  GenSymSimple (ExceptT e m a) (ExceptT e m a)+  where+  simpleFresh (ExceptT v) = ExceptT <$> simpleFresh v++instance+  {-# OVERLAPPING #-}+  ( GenSymSimple (m (Either e a)) (m (Either e a)),+    Mergeable1 m,+    Mergeable e,+    Mergeable a+  ) =>+  GenSym (ExceptT e m a) (ExceptT e m a)++#define GENSYM_SIMPLE(symtype) \+instance GenSym symtype symtype+#define GENSYM_SIMPLE_SIMPLE(symtype) \+instance GenSymSimple symtype symtype where \+  simpleFresh _ = simpleFresh ()+#define GENSYM_UNIT_SIMPLE(symtype) \+instance GenSym () symtype where \+  fresh _ = mrgSingle <$> simpleFresh ()+#define GENSYM_UNIT_SIMPLE_SIMPLE(symtype) \+instance GenSymSimple () symtype where \+  simpleFresh _ = do; \+    ident <- getIdentifier; \+    FreshIndex index <- nextFreshIndex; \+    return $ isym ident index++#define GENSYM_BV(symtype) \+instance (KnownNat n, 1 <= n) => GenSym (symtype n) (symtype n)+#define GENSYM_SIMPLE_BV(symtype) \+instance (KnownNat n, 1 <= n) => GenSymSimple (symtype n) (symtype n) where \+  simpleFresh _ = simpleFresh ()+#define GENSYM_UNIT_BV(symtype) \+instance (KnownNat n, 1 <= n) => GenSym () (symtype n) where \+  fresh _ = mrgSingle <$> simpleFresh ()+#define GENSYM_UNIT_SIMPLE_BV(symtype) \+instance (KnownNat n, 1 <= n) => GenSymSimple () (symtype n) where \+  simpleFresh _ = do; \+    ident <- getIdentifier; \+    FreshIndex index <- nextFreshIndex; \+    return $ isym ident index++#define GENSYM_FUN(cop, op, consop) \+instance GenSym (op sa sb) (op sa sb) where \+  fresh consop{} = fresh ()+#define GENSYM_SIMPLE_FUN(cop, op, consop) \+instance GenSymSimple (op sa sb) (op sa sb) where \+  simpleFresh consop{} = simpleFresh ()+#define GENSYM_UNIT_FUN(cop, op) \+instance \+  ( SupportedPrim (cop ca cb), \+    SupportedNonFuncPrim ca, \+    LinkedRep ca sa, \+    LinkedRep cb sb \+  ) => \+  GenSym () (op sa sb) where \+  fresh _ = mrgSingle <$> simpleFresh ()+#define GENSYM_UNIT_SIMPLE_FUN(cop, op) \+instance \+  ( SupportedPrim (cop ca cb), \+    SupportedNonFuncPrim ca, \+    LinkedRep ca sa, \+    LinkedRep cb sb \+  ) => \+  GenSymSimple () (op sa sb) where \+  simpleFresh _ = do; \+    ident <- getIdentifier; \+    FreshIndex index <- nextFreshIndex; \+    return $ isym ident index++#if 1+GENSYM_SIMPLE(SymBool)+GENSYM_SIMPLE_SIMPLE(SymBool)+GENSYM_UNIT_SIMPLE(SymBool)+GENSYM_UNIT_SIMPLE_SIMPLE(SymBool)+GENSYM_SIMPLE(SymInteger)+GENSYM_SIMPLE_SIMPLE(SymInteger)+GENSYM_UNIT_SIMPLE(SymInteger)+GENSYM_UNIT_SIMPLE_SIMPLE(SymInteger)+GENSYM_SIMPLE(SymFPRoundingMode)+GENSYM_SIMPLE_SIMPLE(SymFPRoundingMode)+GENSYM_UNIT_SIMPLE(SymFPRoundingMode)+GENSYM_UNIT_SIMPLE_SIMPLE(SymFPRoundingMode)+GENSYM_SIMPLE(SymAlgReal)+GENSYM_SIMPLE_SIMPLE(SymAlgReal)+GENSYM_UNIT_SIMPLE(SymAlgReal)+GENSYM_UNIT_SIMPLE_SIMPLE(SymAlgReal)++GENSYM_BV(SymIntN)+GENSYM_SIMPLE_BV(SymIntN)+GENSYM_UNIT_BV(SymIntN)+GENSYM_UNIT_SIMPLE_BV(SymIntN)+GENSYM_BV(SymWordN)+GENSYM_SIMPLE_BV(SymWordN)+GENSYM_UNIT_BV(SymWordN)+GENSYM_UNIT_SIMPLE_BV(SymWordN)++GENSYM_FUN((=->), (=~>), SymTabularFun)+GENSYM_SIMPLE_FUN((=->), (=~>), SymTabularFun)+GENSYM_UNIT_FUN((=->), (=~>))+GENSYM_UNIT_SIMPLE_FUN((=->), (=~>))+GENSYM_FUN((-->), (-~>), SymGeneralFun)+GENSYM_SIMPLE_FUN((-->), (-~>), SymGeneralFun)+GENSYM_UNIT_FUN((-->), (-~>))+GENSYM_UNIT_SIMPLE_FUN((-->), (-~>))+#endif++instance (ValidFP eb sb) => GenSym (SymFP eb sb) (SymFP eb sb)++instance (ValidFP eb sb) => GenSymSimple (SymFP eb sb) (SymFP eb sb) where+  simpleFresh _ = simpleFresh ()++instance (ValidFP eb sb) => GenSym () (SymFP eb sb) where+  fresh _ = mrgSingle <$> simpleFresh ()++instance (ValidFP eb sb) => GenSymSimple () (SymFP eb sb) where+  simpleFresh _ = do+    ident <- getIdentifier+    FreshIndex index <- nextFreshIndex+    return $ isym ident index++instance (GenSym spec a, Mergeable a) => GenSym spec (Union a)++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 (Union a) a+  where+  fresh spec = go (unionBase $ tryMerge spec)+    where+      go (UnionSingle x) = fresh x+      go (UnionIf _ _ _ t f) = mrgIf <$> simpleFresh () <*> go t <*> go f++instance {-# INCOHERENT #-} (GenSym a b) => GenSym a (AsKey b) where+  fresh spec = mrgFmap AsKey <$> fresh spec++instance {-# INCOHERENT #-} (GenSym a b) => GenSym (AsKey a) b where+  fresh (AsKey spec) = fresh spec++instance {-# INCOHERENT #-} (GenSym a b) => GenSym (AsKey a) (AsKey b) where+  fresh (AsKey spec) = mrgFmap AsKey <$> fresh spec++instance {-# INCOHERENT #-} (GenSymSimple a b) => GenSymSimple a (AsKey b) where+  simpleFresh spec = AsKey <$> simpleFresh spec++instance {-# INCOHERENT #-} (GenSymSimple a b) => GenSymSimple (AsKey a) (AsKey b) where+  simpleFresh (AsKey spec) = AsKey <$> simpleFresh spec++instance {-# INCOHERENT #-} (GenSymSimple a b) => GenSymSimple (AsKey a) b where+  simpleFresh (AsKey spec) = simpleFresh spec++instance {-# INCOHERENT #-} (GenSym a (f b)) => GenSym a (AsKey1 f b) where+  fresh spec = mrgFmap AsKey1 <$> fresh spec++instance {-# INCOHERENT #-} (GenSym (f a) (f b)) => GenSym (AsKey1 f a) (AsKey1 f b) where+  fresh (AsKey1 spec) = mrgFmap AsKey1 <$> fresh spec++instance {-# INCOHERENT #-} (GenSym (f a) b) => GenSym (AsKey1 f a) b where+  fresh (AsKey1 spec) = fresh spec++instance {-# INCOHERENT #-} (GenSymSimple a (f b)) => GenSymSimple a (AsKey1 f b) where+  simpleFresh spec = AsKey1 <$> simpleFresh spec++instance {-# INCOHERENT #-} (GenSymSimple (f a) (f b)) => GenSymSimple (AsKey1 f a) (AsKey1 f b) where+  simpleFresh (AsKey1 spec) = AsKey1 <$> simpleFresh spec++instance {-# INCOHERENT #-} (GenSymSimple (f a) b) => GenSymSimple (AsKey1 f a) b where+  simpleFresh (AsKey1 spec) = simpleFresh spec
+ src/Grisette/Internal/Core/Data/Class/IEEEFP.hs view
@@ -0,0 +1,226 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# 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,+    fpIsNegativeZero,+    fpIsPositiveInfinite,+    fpIsNegativeInfinite,+    fpIsPositive,+    fpIsNegative,+    fpIsInfinite,+    fpIsZero,+    fpIsNormal,+    fpIsSubnormal,+    fpIsPoint,+    IEEEFPConstants (..),+    IEEEFPRoundingMode (..),+    IEEEFPOp (..),+    IEEEFPRoundingOp (..),+    IEEEFPConvertible (..),+    IEEEFPToAlgReal (..),+  )+where++-- | Check if a floating-point number is not-a-number.+fpIsNaN :: (RealFloat a) => a -> Bool+fpIsNaN = isNaN+{-# INLINE fpIsNaN #-}++-- | Check if a floating-point number is positive zero.+fpIsPositiveZero :: (RealFloat a) => a -> Bool+fpIsPositiveZero x = x == 0 && not (fpIsNegativeZero x)+{-# INLINE fpIsPositiveZero #-}++-- | Check if a floating-point number is negative zero.+fpIsNegativeZero :: (RealFloat a) => a -> Bool+fpIsNegativeZero = isNegativeZero+{-# INLINE fpIsNegativeZero #-}++-- | Check if a floating-point number is positive infinite.+fpIsPositiveInfinite :: (RealFloat a) => a -> Bool+fpIsPositiveInfinite x = isInfinite x && x > 0+{-# INLINE fpIsPositiveInfinite #-}++-- | Check if a floating-point number is negative infinite.+fpIsNegativeInfinite :: (RealFloat a) => a -> Bool+fpIsNegativeInfinite x = isInfinite x && x < 0+{-# INLINE fpIsNegativeInfinite #-}++-- | Check if a floating-point number is positive.+-- +0, +inf are considered positive. nan, -0, -inf are not positive.+fpIsPositive :: (RealFloat a) => a -> Bool+fpIsPositive x = not (fpIsNaN x) && (x > 0 || fpIsPositiveZero x)+{-# INLINE fpIsPositive #-}++-- | Check if a floating-point number is negative.+-- -0, -inf are considered negative. nan, +0, +inf are not negative.+fpIsNegative :: (RealFloat a) => a -> Bool+fpIsNegative x = not (fpIsNaN x) && (x < 0 || isNegativeZero x)+{-# INLINE fpIsNegative #-}++-- | Check if a floating-point number is infinite.+fpIsInfinite :: (RealFloat a) => a -> Bool+fpIsInfinite x = fpIsPositiveInfinite x || fpIsNegativeInfinite x+{-# INLINE fpIsInfinite #-}++-- | Check if a floating-point number is zero.+fpIsZero :: (RealFloat a) => a -> Bool+fpIsZero x = fpIsPositiveZero x || fpIsNegativeZero x+{-# INLINE fpIsZero #-}++-- | Check if a floating-point number is normal, i.e., not 0, not inf, not+-- nan, and not denormalized.+fpIsNormal :: (RealFloat a) => a -> Bool+fpIsNormal x =+  not (fpIsZero x)+    && not (fpIsSubnormal x)+    && not (fpIsInfinite x)+    && not (fpIsNaN x)+{-# INLINE fpIsNormal #-}++-- | Check if a floating-point number is subnormal, i.e., denormalized. 0,+-- inf, or nan are not subnormal.+fpIsSubnormal :: (RealFloat a) => a -> Bool+fpIsSubnormal = isDenormalized+{-# INLINE fpIsSubnormal #-}++-- | Check if a floating-point number is a point, i.e., not inf, not nan.+fpIsPoint :: (RealFloat a) => a -> Bool+fpIsPoint x = not (fpIsInfinite x) && not (fpIsNaN x)+{-# INLINE fpIsPoint #-}++-- | Constants for IEEE floating-point numbers.+class IEEEFPConstants a where+  -- | Positive infinity.+  fpPositiveInfinite :: a++  -- | Negative infinity.+  fpNegativeInfinite :: a++  -- | Not-a-number.+  fpNaN :: a++  -- | Negative zero.+  fpNegativeZero :: a++  -- | Positive zero.+  fpPositiveZero :: a++  -- | Smallest positive normalized number.+  fpMinNormalized :: a++  -- | Smallest positive subnormal number.+  fpMinSubnormal :: a++  -- | Largest positive normalized number.+  fpMaxNormalized :: a++  -- | Largest positive subnormal number.+  fpMaxSubnormal :: a++-- | Operations on IEEE floating-point numbers, without rounding mode.+class IEEEFPOp a where+  -- | IEEE754-2019 abs operation.+  fpAbs :: a -> a++  -- | IEEE754-2019 negate operation.+  fpNeg :: a -> a++  -- | IEEE754-2019 remainder operation.+  fpRem :: a -> a -> a++  -- | IEEE754-2019 minimum operation.+  --+  -- * The comparison for zeros follows -0 < 0+  -- * Returns NaN if one operand is NaN.+  fpMinimum :: a -> a -> a++  -- | IEEE754-2019 minimumNumber operation.+  --+  -- * The comparison for zeros follows -0 < 0+  -- * Returns the other operand if one operand is NaN.+  fpMinimumNumber :: a -> a -> a++  -- | IEEE754-2019 maximum operation.+  --+  -- * The comparison for zeros follows -0 < 0+  -- * Returns NaN if one operand is NaN.+  fpMaximum :: a -> a -> a++  -- | IEEE754-2019 maximumNumber operation.+  --+  -- * The comparison for zeros follows -0 < 0+  -- * Returns the other operand if one operand is NaN.+  fpMaximumNumber :: a -> a -> a++-- | 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++-- | Operations on IEEE floating-point numbers, with rounding mode.+class (IEEEFPRoundingMode mode) => IEEEFPRoundingOp a mode | a -> mode where+  fpAdd :: mode -> a -> a -> a+  fpSub :: mode -> a -> a -> a+  fpMul :: mode -> a -> a -> a+  fpDiv :: mode -> a -> a -> a+  fpFMA :: mode -> a -> a -> a -> a+  fpSqrt :: mode -> a -> a+  fpRoundToIntegral :: mode -> a -> a++-- | Conversion from and to FPs.+class IEEEFPConvertible a fp mode | fp -> mode where+  fromFPOr ::+    -- | Default value when converting non-representable FPs. For example, when+    -- converting to non-FP types, the NaN and infinities are not representable.+    -- Additionally, when converting to bit-vectors, out-of-bound FPs are not+    -- representable.+    --+    -- Note that out-of-bound means that the /value after conversion/ is out of+    -- bound, not the /value before conversion/, meaning that converting from+    -- 3.5 to 2-bit unsigned bit-vector is out-of-bound when rounding to+    -- positive, but not when rounding to negative.+    a ->+    -- | Rounding mode. Ignored when converting to 'Grisette.AlgReal' because+    -- every representable FP value is converted to an exact 'Grisette.AlgReal'.+    mode ->+    -- | FP value.+    fp ->+    a+  toFP :: mode -> a -> fp++-- | Converting FP to real numbers.+class+  (IEEEFPConvertible a fp mode, IEEEFPRoundingMode mode) =>+  IEEEFPToAlgReal a fp mode+    | fp -> mode+  where+  -- | Similar to 'fromFPOr' for 'Grisette.AlgReal', but dropped the ignored+  -- rounding mode.+  fpToAlgReal :: a -> fp -> a+  fpToAlgReal d = fromFPOr d rna
+ src/Grisette/Internal/Core/Data/Class/ITEOp.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.Core.Data.Class.ITEOp+-- 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.ITEOp+  ( ITEOp (..),+  )+where++import Control.Monad.Identity (Identity (Identity))+import qualified Data.HashSet as HS+import Data.Proxy (Proxy)+import GHC.TypeNats (KnownNat, type (<=))+import Grisette.Internal.Core.Data.Class.AsKey (AsKey (AsKey))+import Grisette.Internal.SymPrim.FP (ValidFP)+import Grisette.Internal.SymPrim.GeneralFun+  ( freshArgSymbol,+    substTerm,+    type (-->) (GeneralFun),+  )+import Grisette.Internal.SymPrim.Prim.SomeTerm (SomeTerm (SomeTerm))+import Grisette.Internal.SymPrim.Prim.Term+  ( SupportedPrim (pevalITETerm),+    TypedConstantSymbol,+    symTerm,+  )+import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal (SymAlgReal))+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))++-- $setup+-- >>> import Grisette.Core+-- >>> import Grisette.SymPrim++-- | ITE operator for solvable (see "Grisette.Core#g:solvable")s, including+-- symbolic boolean, integer, etc.+--+-- >>> let a = "a" :: SymBool+-- >>> let b = "b" :: SymBool+-- >>> let c = "c" :: SymBool+-- >>> symIte a b c+-- (ite a b c)+class ITEOp v where+  -- | Symbolic if-then-else.+  symIte :: SymBool -> v -> v -> v++-- ITEOp instances+#define ITEOP_SIMPLE(type) \+instance ITEOp type where \+  symIte (SymBool c) (type t) (type f) = type $ pevalITETerm c t f; \+  {-# INLINE symIte #-}++#define ITEOP_BV(type) \+instance (KnownNat n, 1 <= n) => ITEOp (type n) where \+  symIte (SymBool c) (type t) (type f) = type $ pevalITETerm c t f; \+  {-# INLINE symIte #-}++#define ITEOP_FUN(cop, op, cons) \+instance ITEOp (op sa sb) where \+  symIte (SymBool c) (cons t) (cons f) = cons $ pevalITETerm c t f; \+  {-# INLINE symIte #-}++#if 1+ITEOP_SIMPLE(SymBool)+ITEOP_SIMPLE(SymInteger)+ITEOP_SIMPLE(SymFPRoundingMode)+ITEOP_SIMPLE(SymAlgReal)+ITEOP_BV(SymIntN)+ITEOP_BV(SymWordN)+ITEOP_FUN((=->), (=~>), SymTabularFun)+ITEOP_FUN((-->), (-~>), SymGeneralFun)+#endif++instance ITEOp (a --> b) where+  symIte+    (SymBool c)+    (GeneralFun (ta :: TypedConstantSymbol a) a)+    (GeneralFun tb b) =+      GeneralFun argSymbol $+        pevalITETerm+          c+          (substTerm ta (symTerm argSymbol) HS.empty a)+          (substTerm tb (symTerm argSymbol) HS.empty b)+      where+        argSymbol :: TypedConstantSymbol a+        argSymbol = freshArgSymbol [SomeTerm a, SomeTerm b]+  {-# INLINE symIte #-}++instance (ValidFP eb sb) => ITEOp (SymFP eb sb) where+  symIte (SymBool c) (SymFP t) (SymFP f) = SymFP $ pevalITETerm c t f+  {-# INLINE symIte #-}++instance (ITEOp v) => ITEOp (Identity v) where+  symIte c (Identity t) (Identity f) = Identity $ symIte c t f+  {-# INLINE symIte #-}++instance ITEOp (Proxy a) where+  symIte _ l _ = l+  {-# INLINE symIte #-}++instance (ITEOp a) => ITEOp (AsKey a) where+  symIte c (AsKey t) (AsKey f) = AsKey $ symIte c t f+  {-# INLINE symIte #-}
+ src/Grisette/Internal/Core/Data/Class/LogicalOp.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE CPP #-}++-- |+-- 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++#if !MIN_VERSION_base(4,18,0)+import Control.Applicative (liftA2)+#endif++import Control.Monad.Identity (Identity)+import Grisette.Internal.Core.Data.Class.AsKey (AsKey (AsKey))+import Grisette.Internal.Core.Data.Class.Solvable (Solvable (con))+import Grisette.Internal.SymPrim.Prim.Term+  ( pevalAndTerm,+    pevalImplyTerm,+    pevalNotTerm,+    pevalOrTerm,+    pevalXorTerm,+  )+import Grisette.Internal.SymPrim.SymBool (SymBool (SymBool))++-- $setup+-- >>> import Grisette.Core+-- >>> import Grisette.SymPrim++-- | Symbolic logical operators for symbolic booleans.+--+-- >>> let t = true :: SymBool+-- >>> let f = false :: SymBool+-- >>> let a = "a" :: SymBool+-- >>> let b = "b" :: SymBool+-- >>> t .|| f+-- true+-- >>> a .|| t+-- true+-- >>> a .|| f+-- a+-- >>> a .|| b+-- (|| a b)+-- >>> t .&& f+-- false+-- >>> a .&& t+-- a+-- >>> a .&& f+-- false+-- >>> a .&& b+-- (&& a b)+-- >>> symNot t+-- false+-- >>> symNot f+-- true+-- >>> symNot a+-- (! a)+-- >>> t `symXor` f+-- true+-- >>> t `symXor` t+-- false+-- >>> a `symXor` t+-- (! a)+-- >>> a `symXor` f+-- a+-- >>> 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+  {-# INLINE (.||) #-}++  infixr 2 .||++  -- | Symbolic conjunction+  (.&&) :: b -> b -> b+  a .&& b = symNot $ symNot a .|| symNot b+  {-# INLINE (.&&) #-}++  infixr 3 .&&++  -- | Symbolic negation+  symNot :: b -> b++  -- | Symbolic exclusive disjunction+  symXor :: b -> b -> b+  a `symXor` b = (a .&& symNot b) .|| (symNot a .&& b)+  {-# INLINE symXor #-}++  -- | Symbolic implication+  symImplies :: b -> b -> b+  a `symImplies` b = symNot a .|| b+  {-# INLINE symImplies #-}++  {-# MINIMAL (true | false), ((.||), symNot | (.&&), symNot) #-}++-- LogicalOp instances+instance LogicalOp Bool where+  true = True+  false = False+  (.||) = (||)+  {-# INLINE (.||) #-}+  (.&&) = (&&)+  {-# INLINE (.&&) #-}+  symNot = not+  {-# 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+  (SymBool l) `symXor` (SymBool r) = SymBool $ pevalXorTerm l r+  (SymBool l) `symImplies` (SymBool r) = SymBool $ pevalImplyTerm l r++instance (LogicalOp a) => LogicalOp (Identity a) where+  true = pure true+  false = pure false+  (.||) = liftA2 (.||)+  (.&&) = liftA2 (.&&)+  symNot = fmap symNot+  symXor = liftA2 symXor+  symImplies = liftA2 symImplies++instance (LogicalOp a) => LogicalOp (AsKey a) where+  true = AsKey true+  false = AsKey false+  (AsKey l) .|| (AsKey r) = AsKey $ l .|| r+  (AsKey l) .&& (AsKey r) = AsKey $ l .&& r+  symNot (AsKey v) = AsKey $ symNot v+  (AsKey l) `symXor` (AsKey r) = AsKey $ l `symXor` r+  (AsKey l) `symImplies` (AsKey r) = AsKey $ l `symImplies` r
+ src/Grisette/Internal/Core/Data/Class/Mergeable.hs view
@@ -0,0 +1,43 @@+{-# OPTIONS_GHC -Wno-missing-import-lists #-}++-- |+-- 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',+    resolveMergeable1,+  )+where++import Grisette.Internal.Internal.Decl.Core.Data.Class.Mergeable+import Grisette.Internal.Internal.Impl.Core.Data.Class.Mergeable ()
+ src/Grisette/Internal/Core/Data/Class/ModelOps.hs view
@@ -0,0 +1,170 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeFamilies #-}++-- |+-- Module      :   Grisette.Internal.Core.Data.Class.ModelOps+-- 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.ModelOps+  ( -- * Model and symbolic set operations+    SymbolSetOps (..),+    SymbolSetRep (..),+    ModelOps (..),+    ModelRep (..),+  )+where++import Data.Kind (Type)++-- $setup+-- >>> import Grisette.Core+-- >>> import Grisette.SymPrim++-- | The operations on symbolic constant sets+--+-- Note that symbolic constants with different types are considered different.+--+-- >>> let aBool = "a" :: TypedAnySymbol Bool+-- >>> let bBool = "b" :: TypedAnySymbol Bool+-- >>> let cBool = "c" :: TypedAnySymbol Bool+-- >>> let aInteger = "a" :: TypedAnySymbol Integer+-- >>> emptySet :: AnySymbolSet+-- SymbolSet {}+-- >>> containsSymbol aBool (buildSymbolSet aBool :: AnySymbolSet)+-- True+-- >>> containsSymbol bBool (buildSymbolSet aBool :: AnySymbolSet)+-- False+-- >>> insertSymbol aBool (buildSymbolSet aBool :: AnySymbolSet)+-- SymbolSet {a :: Bool}+-- >>> insertSymbol aInteger (buildSymbolSet aBool :: AnySymbolSet)+-- SymbolSet {a :: Bool, a :: Integer}+-- >>> let abSet = buildSymbolSet (aBool, bBool) :: AnySymbolSet+-- >>> let acSet = buildSymbolSet (aBool, cBool) :: AnySymbolSet+-- >>> intersectionSet abSet acSet+-- SymbolSet {a :: Bool}+-- >>> unionSet abSet acSet+-- SymbolSet {a :: Bool, b :: Bool, c :: Bool}+-- >>> differenceSet abSet acSet+-- SymbolSet {b :: Bool}+class+  (Monoid symbolSet) =>+  SymbolSetOps symbolSet (typedSymbol :: Type -> Type)+    | symbolSet -> typedSymbol+  where+  -- | Construct an empty set+  emptySet :: symbolSet++  -- | Check if the set is empty+  isEmptySet :: symbolSet -> Bool++  -- | Check if the set contains the given symbol+  containsSymbol :: forall a. typedSymbol a -> symbolSet -> Bool++  -- | Insert a symbol into the set+  insertSymbol :: forall a. typedSymbol a -> symbolSet -> symbolSet++  -- | Set intersection+  intersectionSet :: symbolSet -> symbolSet -> symbolSet++  -- | Set union+  unionSet :: symbolSet -> symbolSet -> symbolSet++  -- | Set difference+  differenceSet :: symbolSet -> symbolSet -> symbolSet++-- | A type class for building a symbolic constant set manually from a symbolic+-- constant set representation+--+-- >>> buildSymbolSet ("a" :: TypedAnySymbol Bool, "b" :: TypedAnySymbol Bool) :: AnySymbolSet+-- SymbolSet {a :: Bool, b :: Bool}+class+  (SymbolSetOps symbolSet typedSymbol) =>+  SymbolSetRep rep symbolSet (typedSymbol :: Type -> Type)+  where+  -- | Build a symbolic constant set+  buildSymbolSet :: rep -> symbolSet++-- | The operations on Models.+--+-- Note that symbolic constants with different types are considered different.+--+-- >>> let aBool = "a" :: TypedAnySymbol Bool+-- >>> let bBool = "b" :: TypedAnySymbol Bool+-- >>> let cBool = "c" :: TypedAnySymbol Bool+-- >>> let aInteger = "a" :: TypedAnySymbol Integer+-- >>> emptyModel :: Model+-- Model {}+-- >>> valueOf aBool (buildModel (aBool ::= True) :: Model)+-- Just True+-- >>> valueOf bBool (buildModel (aBool ::= True) :: Model)+-- Nothing+-- >>> insertValue bBool False (buildModel (aBool ::= True) :: Model)+-- Model {a -> true :: Bool, b -> false :: Bool}+-- >>> let abModel = buildModel (aBool ::= True, bBool ::= False) :: Model+-- >>> let acSet = buildSymbolSet (aBool, cBool) :: AnySymbolSet+-- >>> exceptFor acSet abModel+-- Model {b -> false :: Bool}+-- >>> restrictTo acSet abModel+-- Model {a -> true :: Bool}+-- >>> extendTo acSet abModel+-- Model {a -> true :: Bool, b -> false :: Bool, c -> false :: Bool}+-- >>> exact acSet abModel+-- Model {a -> true :: Bool, c -> false :: Bool}+class+  (SymbolSetOps symbolSet typedSymbol) =>+  ModelOps model symbolSet typedSymbol+    | model -> symbolSet typedSymbol+  where+  -- | Construct an empty model+  emptyModel :: model++  -- | Check if the model is empty+  isEmptyModel :: model -> Bool++  -- | Check if the model contains the given symbol+  modelContains :: typedSymbol a -> model -> Bool++  -- | Extract the assigned value for a given symbolic constant+  valueOf :: typedSymbol t -> model -> Maybe t++  -- | Insert an assignment into the model+  insertValue :: typedSymbol t -> t -> model -> model++  -- | Returns a model that removed all the assignments for the symbolic+  -- constants in the set+  exceptFor :: symbolSet -> model -> model++  -- | Returns a model that removed the assignments for the symbolic constants+  exceptFor' :: typedSymbol t -> model -> model++  -- | Returns a model that only keeps the assignments for the symbolic+  -- constants in the set+  restrictTo :: symbolSet -> model -> model++  -- | Returns a model that extends the assignments for the symbolic constants+  -- in the set by assigning default values to them+  extendTo :: symbolSet -> model -> model++  -- | Returns a model that contains the assignments for exactly the symbolic+  -- constants in the set by removing assignments for the symbolic constants that+  -- are not in the set and add assignments for the missing symbolic constants+  -- by assigning default values to them.+  exact :: symbolSet -> model -> model+  exact s = restrictTo s . extendTo s++-- | A type class for building a model manually from a model representation+class ModelRep rep model | rep -> model where+  -- | Build a model+  --+  -- >>> let aBool = "a" :: TypedAnySymbol Bool+  -- >>> let bBool = "b" :: TypedAnySymbol Bool+  -- >>> buildModel (aBool ::= True, bBool ::= False) :: Model+  -- Model {a -> true :: Bool, b -> false :: Bool}+  buildModel :: rep -> model
+ src/Grisette/Internal/Core/Data/Class/PPrint.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE CPP #-}+{-# 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+#else+import Data.Text.Prettyprint.Doc as Prettyprinter+#endif++import Grisette.Internal.Internal.Decl.Core.Data.Class.PPrint+import Grisette.Internal.Internal.Impl.Core.Data.Class.PPrint ()
+ src/Grisette/Internal/Core/Data/Class/SafeBitCast.hs view
@@ -0,0 +1,190 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.Core.Data.Class.SafeBitCast+-- 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.SafeBitCast+  ( SafeBitCast (..),+  )+where++import Control.Monad.Error.Class (MonadError (throwError))+import Data.Int (Int16, Int32, Int64)+import Data.SBV (Word32)+import Data.Word (Word16, Word64)+import GHC.TypeLits (KnownNat, type (+), type (<=))+import Grisette.Internal.Core.Control.Monad.Class.Union (MonadUnion)+import Grisette.Internal.Core.Data.Class.AsKey (AsKey (AsKey))+import Grisette.Internal.Core.Data.Class.BitCast+  ( BitCast (bitCast),+    BitCastOr (bitCastOr),+    bitCastOrCanonical,+  )+import Grisette.Internal.Core.Data.Class.IEEEFP (fpIsNaN)+import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable)+import Grisette.Internal.Core.Data.Class.SimpleMergeable (mrgIf)+import Grisette.Internal.Core.Data.Class.SymIEEEFP+  ( SymIEEEFPTraits (symFpIsNaN),+  )+import Grisette.Internal.Core.Data.Class.TryMerge (TryMerge, mrgSingle, tryMerge)+import Grisette.Internal.SymPrim.BV (IntN, WordN, WordN16, WordN32, WordN64)+import Grisette.Internal.SymPrim.FP+  ( FP,+    FP16,+    FP32,+    FP64,+    NotRepresentableFPError (NaNError),+    ValidFP,+  )+import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN)+import Grisette.Internal.SymPrim.SymFP (SymFP)++-- | Bitcasting a value. If the value cannot be precisely bitcast, throw an+-- error.+class+  (MonadError e m, TryMerge m, Mergeable b, BitCastOr a b) =>+  SafeBitCast e a b m+  where+  safeBitCast :: a -> m b++instance+  ( ValidFP eb sb,+    r ~ (eb + sb),+    KnownNat r,+    1 <= r,+    TryMerge m,+    MonadError NotRepresentableFPError m+  ) =>+  SafeBitCast NotRepresentableFPError (FP eb sb) (WordN r) m+  where+  safeBitCast a+    | fpIsNaN a = tryMerge $ throwError NaNError+    | otherwise = tryMerge $ return $ bitCastOrCanonical a++instance+  ( ValidFP eb sb,+    r ~ (eb + sb),+    KnownNat r,+    1 <= r,+    TryMerge m,+    MonadError NotRepresentableFPError m+  ) =>+  SafeBitCast NotRepresentableFPError (FP eb sb) (IntN r) m+  where+  safeBitCast a+    | fpIsNaN a = tryMerge $ throwError NaNError+    | otherwise = tryMerge $ return $ bitCastOrCanonical a++#define SAFE_BIT_CAST_VIA_INTERMEDIATE(from, to, intermediate) \+instance \+  (MonadError NotRepresentableFPError m, TryMerge m) => \+  SafeBitCast NotRepresentableFPError from to m \+  where \+  safeBitCast a = do \+    r :: intermediate <- safeBitCast a; \+    tryMerge $ return $ bitCast r++#if 1+SAFE_BIT_CAST_VIA_INTERMEDIATE(FP64, Word64, WordN64)+SAFE_BIT_CAST_VIA_INTERMEDIATE(FP64, Int64, WordN64)+SAFE_BIT_CAST_VIA_INTERMEDIATE(FP64, Double, WordN64)+SAFE_BIT_CAST_VIA_INTERMEDIATE(FP32, Word32, WordN32)+SAFE_BIT_CAST_VIA_INTERMEDIATE(FP32, Int32, WordN32)+SAFE_BIT_CAST_VIA_INTERMEDIATE(FP32, Float, WordN32)+SAFE_BIT_CAST_VIA_INTERMEDIATE(FP16, Word16, WordN16)+SAFE_BIT_CAST_VIA_INTERMEDIATE(FP16, Int16, WordN16)+#endif++instance+  ( ValidFP eb sb,+    r ~ (eb + sb),+    KnownNat r,+    1 <= r,+    MonadUnion m,+    MonadError NotRepresentableFPError m+  ) =>+  SafeBitCast NotRepresentableFPError (SymFP eb sb) (SymWordN r) m+  where+  safeBitCast a =+    mrgIf+      (symFpIsNaN a)+      (throwError NaNError)+      (return $ bitCastOrCanonical a)++instance+  ( ValidFP eb sb,+    r ~ (eb + sb),+    KnownNat r,+    1 <= r,+    MonadUnion m,+    MonadError NotRepresentableFPError m+  ) =>+  SafeBitCast NotRepresentableFPError (SymFP eb sb) (SymIntN r) m+  where+  safeBitCast a =+    mrgIf+      (symFpIsNaN a)+      (throwError NaNError)+      (return $ bitCastOrCanonical a)++instance+  {-# INCOHERENT #-}+  (SafeBitCast e a b m) =>+  SafeBitCast e (AsKey a) (AsKey b) m+  where+  safeBitCast (AsKey a) = do+    r <- safeBitCast a+    mrgSingle $ AsKey r++instance+  {-# INCOHERENT #-}+  (SafeBitCast e a b m) =>+  SafeBitCast e (AsKey a) b m+  where+  safeBitCast (AsKey a) = do+    r <- safeBitCast a+    mrgSingle r++instance+  {-# INCOHERENT #-}+  (SafeBitCast e a b m) =>+  SafeBitCast e a (AsKey b) m+  where+  safeBitCast a = do+    r <- safeBitCast a+    mrgSingle $ AsKey r++instance+  {-# INCOHERENT #-}+  (BitCastOr a b) =>+  BitCastOr (AsKey a) (AsKey b)+  where+  bitCastOr (AsKey d) (AsKey a) = AsKey $ bitCastOr d a++instance+  {-# INCOHERENT #-}+  (BitCastOr a b) =>+  BitCastOr a (AsKey b)+  where+  bitCastOr (AsKey d) a = AsKey $ bitCastOr d a++instance+  {-# INCOHERENT #-}+  (BitCastOr a b) =>+  BitCastOr (AsKey a) b+  where+  bitCastOr d (AsKey a) = bitCastOr d a
+ src/Grisette/Internal/Core/Data/Class/SafeDiv.hs view
@@ -0,0 +1,25 @@+{-# OPTIONS_GHC -Wno-missing-import-lists #-}++-- |+-- Module      :   Grisette.Internal.Core.Data.Class.SafeDiv+-- 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.SafeDiv+  ( ArithException (..),+    SafeDiv (..),+    DivOr (..),+    divOrZero,+    modOrDividend,+    quotOrZero,+    remOrDividend,+    divModOrZeroDividend,+    quotRemOrZeroDividend,+  )+where++import Grisette.Internal.Internal.Decl.Core.Data.Class.SafeDiv+import Grisette.Internal.Internal.Impl.Core.Data.Class.SafeDiv ()
+ src/Grisette/Internal/Core/Data/Class/SafeFdiv.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.Core.Data.Class.SafeFdiv+-- 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.SafeFdiv+  ( SafeFdiv (..),+    FdivOr (..),+    fdivOrZero,+    recipOrZero,+  )+where++import Control.Exception (ArithException (RatioZeroDenominator), throw)+import Control.Monad.Error.Class (MonadError (throwError))+import Grisette.Internal.Core.Control.Monad.Class.Union (MonadUnion)+import Grisette.Internal.Core.Data.Class.AsKey (AsKey (AsKey))+import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp (symIte))+import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable)+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.AlgReal+  ( AlgReal (AlgExactRational),+    UnsupportedAlgRealOperation (UnsupportedAlgRealOperation),+  )+import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal)++-- $setup+-- >>> import Grisette.Core+-- >>> import Grisette.SymPrim+-- >>> import Control.Monad.Except+-- >>> import Control.Exception++-- | Safe fractional with default values returned on exception.+class FdivOr a where+  -- | Safe '/' with default values returned on exception.+  --+  -- >>> fdivOr "d" "a" "b" :: SymAlgReal+  -- (ite (= b 0.0) d (fdiv a b))+  fdivOr :: a -> a -> a -> a++  -- | Safe 'recip' with default values returned on exception.+  --+  -- >>> recipOr "d" "a" :: SymAlgReal+  -- (ite (= a 0.0) d (recip a))+  recipOr :: a -> a -> a++-- | Safe '/' with 0 returned on exception.+fdivOrZero :: (FdivOr a, Num a) => a -> a -> a+fdivOrZero l = fdivOr (l - l) l++-- | Safe 'recip' with 0 returned on exception.+recipOrZero :: (FdivOr a, Num a) => a -> a+recipOrZero v = recipOr (v - v) v++-- | Safe fractional division with monadic error handling in multi-path+-- execution. These procedures throw an exception when the denominator is zero.+-- The result should be able to handle errors with `MonadError`.+class (MonadError e m, TryMerge m, Mergeable a) => SafeFdiv e a m where+  -- | Safe fractional division with monadic error handling in multi-path+  -- execution.+  --+  -- >>> safeFdiv "a" "b" :: ExceptT ArithException Union SymAlgReal+  -- ExceptT {If (= b 0.0) (Left Ratio has zero denominator) (Right (fdiv a b))}+  safeFdiv :: a -> a -> m a++  -- | Safe fractional reciprocal with monadic error handling in multi-path+  -- execution.+  --+  -- >>> safeRecip "a" :: ExceptT ArithException Union SymAlgReal+  -- ExceptT {If (= a 0.0) (Left Ratio has zero denominator) (Right (recip a))}+  safeRecip :: a -> m a+  default safeRecip :: (Fractional a) => a -> m a+  safeRecip = safeFdiv (fromRational 1)+  {-# INLINE safeRecip #-}++  {-# MINIMAL safeFdiv #-}++instance FdivOr AlgReal where+  fdivOr d (AlgExactRational l) (AlgExactRational r)+    | r /= 0 = AlgExactRational (l / r)+    | otherwise = d+  fdivOr d l r =+    -- Throw the error because the user should never construct an AlgReal+    -- other than AlgExactRational.+    throw $+      UnsupportedAlgRealOperation "fdivOr" $+        show d <> " and " <> show l <> " and " <> show r+  {-# INLINE fdivOr #-}+  recipOr d (AlgExactRational l)+    | l /= 0 = AlgExactRational (recip l)+    | otherwise = d+  recipOr d l =+    throw $ UnsupportedAlgRealOperation "recipOr" $ show d <> " and " <> show l+  {-# INLINE recipOr #-}++instance+  ( MonadError ArithException m,+    TryMerge m+  ) =>+  SafeFdiv ArithException AlgReal m+  where+  safeFdiv (AlgExactRational l) (AlgExactRational r)+    | r /= 0 =+        pure $ AlgExactRational (l / r)+    | otherwise = tryMerge $ throwError RatioZeroDenominator+  safeFdiv l r =+    -- Throw the error because the user should never construct an AlgReal+    -- other than AlgExactRational.+    throw $+      UnsupportedAlgRealOperation "safeFdiv" $+        show l <> " and " <> show r+  {-# INLINE safeFdiv #-}+  safeRecip (AlgExactRational l)+    | l /= 0 =+        pure $ AlgExactRational (recip l)+    | otherwise = tryMerge $ throwError RatioZeroDenominator+  safeRecip l =+    throw $ UnsupportedAlgRealOperation "safeRecip" $ show l++instance FdivOr SymAlgReal where+  fdivOr d l r = symIte (r .== con 0) d (l / r)+  recipOr d l = symIte (l .== con 0) d (recip l)++instance+  (MonadError ArithException m, MonadUnion m) =>+  SafeFdiv ArithException SymAlgReal m+  where+  safeFdiv l r =+    mrgIf (r .== con 0) (throwError RatioZeroDenominator) (pure $ l / r)+  safeRecip l =+    mrgIf (l .== con 0) (throwError RatioZeroDenominator) (pure $ recip l)++instance (SafeFdiv e a m) => SafeFdiv e (AsKey a) m where+  safeFdiv (AsKey a) (AsKey b) = do+    r <- safeFdiv a b+    mrgSingle $ AsKey r+  safeRecip (AsKey a) = do+    r <- safeRecip a+    mrgSingle $ AsKey r++instance (FdivOr a) => FdivOr (AsKey a) where+  fdivOr (AsKey d) (AsKey a) (AsKey b) = AsKey $ fdivOr d a b+  {-# INLINE fdivOr #-}+  recipOr (AsKey d) (AsKey a) = AsKey $ recipOr d a+  {-# INLINE recipOr #-}
+ src/Grisette/Internal/Core/Data/Class/SafeFromFP.hs view
@@ -0,0 +1,265 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.Core.Data.Class.SafeFromFP+-- 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.SafeFromFP (SafeFromFP (..)) where++import Control.Monad.Error.Class (MonadError (throwError))+import GHC.TypeLits (KnownNat, type (<=))+import Grisette.Internal.Core.Control.Monad.Class.Union (MonadUnion)+import Grisette.Internal.Core.Data.Class.IEEEFP+  ( IEEEFPConvertible (fromFPOr),+    IEEEFPRoundingMode (rna, rne, rtn, rtp, rtz),+    fpIsNaN,+    fpIsNegativeInfinite,+    fpIsPositiveInfinite,+  )+import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp (symIte))+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.SymIEEEFP+  ( SymIEEEFPTraits+      ( symFpIsNaN,+        symFpIsNegativeInfinite,+        symFpIsPositiveInfinite+      ),+  )+import Grisette.Internal.Core.Data.Class.SymOrd (SymOrd ((.<), (.>)))+import Grisette.Internal.Core.Data.Class.TryMerge+  ( TryMerge,+    mrgSingle,+    tryMerge,+  )+import Grisette.Internal.SymPrim.AlgReal (AlgReal)+import Grisette.Internal.SymPrim.BV (IntN, WordN)+import Grisette.Internal.SymPrim.FP+  ( ConvertibleBound (convertibleLowerBound, convertibleUpperBound),+    FP,+    FPRoundingMode,+    NotRepresentableFPError+      ( FPOverflowError,+        FPUnderflowError,+        NaNError+      ),+    ValidFP,+  )+import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal)+import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN)+import Grisette.Internal.SymPrim.SymFP (SymFP, SymFPRoundingMode)+import Grisette.Internal.SymPrim.SymInteger (SymInteger)++-- | Safe conversion from floating point numbers that throws exceptions when+-- the result isn't representable by the type.+class+  (MonadError e m, TryMerge m, IEEEFPConvertible a fp fprd) =>+  SafeFromFP e a fp fprd m+  where+  safeFromFP :: fprd -> fp -> m a++instance+  (MonadError NotRepresentableFPError m, TryMerge m, ValidFP eb sb) =>+  SafeFromFP NotRepresentableFPError AlgReal (FP eb sb) FPRoundingMode m+  where+  safeFromFP mode a+    | fpIsPositiveInfinite a = tryMerge $ throwError FPOverflowError+    | fpIsNegativeInfinite a = tryMerge $ throwError FPUnderflowError+    | fpIsNaN a = tryMerge $ throwError NaNError+    | otherwise = mrgSingle $ fromFPOr undefined mode a++instance+  (MonadError NotRepresentableFPError m, MonadUnion m, ValidFP eb sb) =>+  SafeFromFP+    NotRepresentableFPError+    SymAlgReal+    (SymFP eb sb)+    SymFPRoundingMode+    m+  where+  safeFromFP mode a =+    mrgIf (symFpIsPositiveInfinite a) (tryMerge $ throwError FPOverflowError)+      $ mrgIf+        (symFpIsNegativeInfinite a)+        (tryMerge $ throwError FPUnderflowError)+      $ mrgIf (symFpIsNaN a) (tryMerge $ throwError NaNError)+      $ mrgSingle+      $ fromFPOr 0 mode a++instance+  (MonadError NotRepresentableFPError m, TryMerge m, ValidFP eb sb) =>+  SafeFromFP NotRepresentableFPError Integer (FP eb sb) FPRoundingMode m+  where+  safeFromFP mode a+    | fpIsPositiveInfinite a = tryMerge $ throwError FPOverflowError+    | fpIsNegativeInfinite a = tryMerge $ throwError FPUnderflowError+    | fpIsNaN a = tryMerge $ throwError NaNError+    | otherwise = mrgSingle $ fromFPOr 0 mode a++instance+  (MonadError NotRepresentableFPError m, MonadUnion m, ValidFP eb sb) =>+  SafeFromFP+    NotRepresentableFPError+    SymInteger+    (SymFP eb sb)+    SymFPRoundingMode+    m+  where+  safeFromFP mode a =+    mrgIf (symFpIsPositiveInfinite a) (tryMerge $ throwError FPOverflowError)+      $ mrgIf+        (symFpIsNegativeInfinite a)+        (tryMerge $ throwError FPUnderflowError)+      $ mrgIf+        (symFpIsNaN a)+        (tryMerge $ throwError NaNError)+      $ mrgSingle+      $ fromFPOr 0 mode a++instance+  ( MonadError NotRepresentableFPError m,+    TryMerge m,+    ValidFP eb sb,+    KnownNat n,+    1 <= n+  ) =>+  SafeFromFP NotRepresentableFPError (WordN n) (FP eb sb) FPRoundingMode m+  where+  safeFromFP mode a = do+    p :: Integer <- safeFromFP mode a+    if p < (fromIntegral (minBound :: WordN n))+      then tryMerge $ throwError FPUnderflowError+      else+        if p > (fromIntegral (maxBound :: WordN n))+          then tryMerge $ throwError FPOverflowError+          else mrgSingle $ fromIntegral p++symConvertibleLowerBound ::+  forall conBV symBV n eb sb.+  ( ConvertibleBound conBV,+    ValidFP eb sb,+    KnownNat n,+    1 <= n,+    Solvable (conBV n) (symBV n)+  ) =>+  symBV n ->+  SymFPRoundingMode ->+  SymFP eb sb+symConvertibleLowerBound _ mode =+  symIte+    (mode .== rne)+    (con $ convertibleLowerBound (undefined :: conBV n) rne)+    $ symIte+      (mode .== rna)+      (con $ convertibleLowerBound (undefined :: conBV n) rna)+    $ symIte+      (mode .== rtp)+      (con $ convertibleLowerBound (undefined :: conBV n) rtp)+    $ symIte+      (mode .== rtn)+      (con $ convertibleLowerBound (undefined :: conBV n) rtn)+      (con $ convertibleLowerBound (undefined :: conBV n) rtz)++symConvertibleUpperBound ::+  forall conBV symBV n eb sb.+  ( ConvertibleBound conBV,+    ValidFP eb sb,+    KnownNat n,+    1 <= n,+    Solvable (conBV n) (symBV n)+  ) =>+  symBV n ->+  SymFPRoundingMode ->+  SymFP eb sb+symConvertibleUpperBound _ mode =+  symIte+    (mode .== rne)+    (con $ convertibleUpperBound (undefined :: conBV n) rne)+    $ symIte+      (mode .== rna)+      (con $ convertibleUpperBound (undefined :: conBV n) rna)+    $ symIte+      (mode .== rtp)+      (con $ convertibleUpperBound (undefined :: conBV n) rtp)+    $ symIte+      (mode .== rtn)+      (con $ convertibleUpperBound (undefined :: conBV n) rtn)+      (con $ convertibleUpperBound (undefined :: conBV n) rtz)++instance+  ( MonadError NotRepresentableFPError m,+    MonadUnion m,+    ValidFP eb sb,+    KnownNat n,+    1 <= n+  ) =>+  SafeFromFP NotRepresentableFPError (SymWordN n) (SymFP eb sb) SymFPRoundingMode m+  where+  safeFromFP mode a =+    mrgIf (symFpIsPositiveInfinite a) (tryMerge $ throwError FPOverflowError)+      $ mrgIf+        (symFpIsNegativeInfinite a)+        (tryMerge $ throwError FPUnderflowError)+      $ mrgIf (symFpIsNaN a) (tryMerge $ throwError NaNError)+      $ mrgIf+        (a .< symConvertibleLowerBound (undefined :: SymWordN n) mode)+        (tryMerge $ throwError FPUnderflowError)+      $ mrgIf+        (a .> symConvertibleUpperBound (undefined :: SymWordN n) mode)+        (tryMerge $ throwError FPOverflowError)+      $ mrgSingle+      $ fromFPOr 0 mode a++instance+  ( MonadError NotRepresentableFPError m,+    TryMerge m,+    ValidFP eb sb,+    KnownNat n,+    1 <= n+  ) =>+  SafeFromFP NotRepresentableFPError (IntN n) (FP eb sb) FPRoundingMode m+  where+  safeFromFP mode a = do+    p :: Integer <- safeFromFP mode a+    if p < (fromIntegral (minBound :: IntN n))+      then tryMerge $ throwError FPUnderflowError+      else+        if p > (fromIntegral (maxBound :: IntN n))+          then tryMerge $ throwError FPOverflowError+          else mrgSingle $ fromIntegral p++instance+  ( MonadError NotRepresentableFPError m,+    MonadUnion m,+    ValidFP eb sb,+    KnownNat n,+    1 <= n+  ) =>+  SafeFromFP NotRepresentableFPError (SymIntN n) (SymFP eb sb) SymFPRoundingMode m+  where+  safeFromFP mode a =+    mrgIf (symFpIsPositiveInfinite a) (tryMerge $ throwError FPOverflowError)+      $ mrgIf+        (symFpIsNegativeInfinite a)+        (tryMerge $ throwError FPUnderflowError)+      $ mrgIf (symFpIsNaN a) (tryMerge $ throwError NaNError)+      $ mrgIf+        (a .< symConvertibleLowerBound (undefined :: SymIntN n) mode)+        (tryMerge $ throwError FPUnderflowError)+      $ mrgIf+        (a .> symConvertibleUpperBound (undefined :: SymIntN n) mode)+        (tryMerge $ throwError FPOverflowError)+      $ mrgSingle+      $ fromFPOr 0 mode a
+ src/Grisette/Internal/Core/Data/Class/SafeLinearArith.hs view
@@ -0,0 +1,241 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.Core.Data.Class.SafeLinearArith+-- 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.SafeLinearArith+  ( ArithException (..),+    SafeLinearArith (..),+  )+where++import Control.Exception (ArithException (DivideByZero, Overflow, Underflow))+import Control.Monad.Except (MonadError (throwError))+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.Class.Union (MonadUnion)+import Grisette.Internal.Core.Data.Class.AsKey (AsKey (AsKey))+import Grisette.Internal.Core.Data.Class.LogicalOp+  ( LogicalOp ((.&&), (.||)),+  )+import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable)+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,+    WordN,+  )+import Grisette.Internal.SymPrim.SymBV+  ( SymIntN,+    SymWordN,+  )+import Grisette.Internal.SymPrim.SymInteger (SymInteger)++-- $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.+-- The result should be able to handle errors with `MonadError`.+class (MonadError e m, TryMerge m, Mergeable a) => SafeLinearArith e a m where+  -- | Safe '+' with monadic error handling in multi-path execution.+  -- Overflows or underflows are treated as errors.+  --+  -- >>> safeAdd (ssym "a") (ssym "b") :: ExceptT ArithException Union SymInteger+  -- ExceptT {Right (+ a b)}+  -- >>> 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 Union SymInteger+  -- ExceptT {Right (- a)}+  -- >>> 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 Union SymInteger+  -- ExceptT {Right (+ a (- b))}+  -- >>> 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++instance+  (MonadError ArithException m, TryMerge m) =>+  SafeLinearArith ArithException Integer m+  where+  safeAdd l r = mrgSingle (l + r)+  safeNeg l = mrgSingle (-l)+  safeSub l r = mrgSingle (l - r)++#define SAFE_LINARITH_SIGNED_CONCRETE_BODY \+  safeAdd l r = let res = l + r in \+    if l > 0 && r > 0 && res < 0 \+      then tryMerge $ throwError Overflow \+      else if l < 0 && r < 0 && res >= 0 \+        then tryMerge $ throwError Underflow \+        else mrgSingle res;\+  safeSub l r = let res = l - r in \+    if l >= 0 && r < 0 && res < 0 \+      then tryMerge $ throwError Overflow \+      else if l < 0 && r > 0 && res > 0 \+        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 \+  (MonadError ArithException m, TryMerge m) => \+  SafeLinearArith ArithException type m \+  where \+  SAFE_LINARITH_SIGNED_CONCRETE_BODY++#define SAFE_LINARITH_SIGNED_BV_CONCRETE(type) \+instance \+  (MonadError ArithException m, TryMerge m, KnownNat n, 1 <= n) => \+  SafeLinearArith ArithException (type n) m \+  where \+  SAFE_LINARITH_SIGNED_CONCRETE_BODY++#define SAFE_LINARITH_UNSIGNED_CONCRETE_BODY \+  safeAdd l r = let res = l + r in \+    if l > res || r > res \+      then tryMerge $ throwError Overflow \+      else mrgSingle res;\+  safeSub l r = \+    if r > l \+      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 \+  (MonadError ArithException m, TryMerge m) => \+  SafeLinearArith ArithException type m \+  where \+  SAFE_LINARITH_UNSIGNED_CONCRETE_BODY++#define SAFE_LINARITH_UNSIGNED_BV_CONCRETE(type) \+instance \+  (MonadError ArithException m, TryMerge m, KnownNat n, 1 <= n) => \+  SafeLinearArith ArithException (type n) m \+  where \+  SAFE_LINARITH_UNSIGNED_CONCRETE_BODY++#if 1+SAFE_LINARITH_SIGNED_CONCRETE(Int8)+SAFE_LINARITH_SIGNED_CONCRETE(Int16)+SAFE_LINARITH_SIGNED_CONCRETE(Int32)+SAFE_LINARITH_SIGNED_CONCRETE(Int64)+SAFE_LINARITH_SIGNED_CONCRETE(Int)+SAFE_LINARITH_SIGNED_BV_CONCRETE(IntN)+SAFE_LINARITH_UNSIGNED_CONCRETE(Word8)+SAFE_LINARITH_UNSIGNED_CONCRETE(Word16)+SAFE_LINARITH_UNSIGNED_CONCRETE(Word32)+SAFE_LINARITH_UNSIGNED_CONCRETE(Word64)+SAFE_LINARITH_UNSIGNED_CONCRETE(Word)+SAFE_LINARITH_UNSIGNED_BV_CONCRETE(WordN)+#endif++instance+  (MonadError ArithException m, TryMerge m) =>+  SafeLinearArith ArithException SymInteger m+  where+  safeAdd ls rs = mrgSingle $ ls + rs+  safeNeg v = mrgSingle $ -v+  safeSub ls rs = mrgSingle $ ls - rs++instance+  (MonadError ArithException m, MonadUnion m, KnownNat n, 1 <= n) =>+  SafeLinearArith ArithException (SymIntN n) m+  where+  safeAdd ls rs =+    mrgIf+      (ls .> 0)+      (mrgIf (rs .> 0 .&& res .< 0) (throwError Overflow) (return res))+      ( mrgIf+          (ls .< 0 .&& rs .< 0 .&& res .>= 0)+          (throwError Underflow)+          (mrgSingle res)+      )+    where+      res = ls + rs+  safeNeg v = mrgIf (v .== con minBound) (throwError Overflow) (mrgSingle $ -v)+  safeSub ls rs =+    mrgIf+      (ls .>= 0)+      (mrgIf (rs .< 0 .&& res .< 0) (throwError Overflow) (return res))+      ( mrgIf+          (ls .< 0 .&& rs .> 0 .&& res .> 0)+          (throwError Underflow)+          (mrgSingle res)+      )+    where+      res = ls - rs++instance+  (MonadError ArithException m, MonadUnion m, KnownNat n, 1 <= n) =>+  SafeLinearArith ArithException (SymWordN n) m+  where+  safeAdd ls rs =+    mrgIf+      (ls .> res .|| rs .> res)+      (throwError Overflow)+      (mrgSingle res)+    where+      res = ls + rs+  safeNeg v = mrgIf (v ./= 0) (throwError Underflow) (mrgSingle v)+  safeSub ls rs =+    mrgIf+      (rs .> ls)+      (throwError Underflow)+      (mrgSingle res)+    where+      res = ls - rs++instance (SafeLinearArith e a m) => SafeLinearArith e (AsKey a) m where+  safeAdd (AsKey a) (AsKey b) = do+    r <- safeAdd a b+    mrgSingle $ AsKey r+  safeNeg (AsKey a) = do+    r <- safeNeg a+    mrgSingle $ AsKey r+  safeSub (AsKey a) (AsKey b) = do+    r <- safeSub a b+    mrgSingle $ AsKey r
+ src/Grisette/Internal/Core/Data/Class/SafeLogBase.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- |+-- Module      :   Grisette.Internal.Core.Data.Class.SafeLogBase+-- 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.SafeLogBase+  ( SafeLogBase (..),+    LogBaseOr (..),+    logBaseOrZero,+  )+where++import Control.Exception (ArithException (RatioZeroDenominator))+import Control.Monad.Error.Class (MonadError (throwError))+import Grisette.Internal.Core.Control.Monad.Class.Union (MonadUnion)+import Grisette.Internal.Core.Data.Class.AsKey (AsKey (AsKey))+import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp (symIte))+import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable)+import Grisette.Internal.Core.Data.Class.SimpleMergeable (mrgIf)+import Grisette.Internal.Core.Data.Class.SymEq (SymEq ((.==)))+import Grisette.Internal.Core.Data.Class.TryMerge (TryMerge, mrgSingle)+import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal)++-- $setup+-- >>> import Grisette.Core+-- >>> import Grisette.SymPrim+-- >>> import Control.Monad.Except+-- >>> import Control.Exception++-- | Safe 'logBase' with default values returned on exception.+class LogBaseOr a where+  -- | Safe 'logBase' with default values returned on exception.+  --+  -- >>> logBaseOr "d" "base" "val" :: SymAlgReal+  -- (ite (= base 1.0) d (fdiv (log val) (log base)))+  logBaseOr :: a -> a -> a -> a++-- | Safe 'logBase' with 0 returned on exception.+logBaseOrZero :: (LogBaseOr a, Num a) => a -> a -> a+logBaseOrZero l = logBaseOr (l - l) l+{-# INLINE logBaseOrZero #-}++-- | Safe 'logBase' with monadic error handling in multi-path execution.+-- These procedures throw an exception when the base is 1.+-- The result should be able to handle errors with `MonadError`.+class (MonadError e m, TryMerge m, Mergeable a) => SafeLogBase e a m where+  -- | Safe 'logBase' with monadic error handling in multi-path execution.+  --+  -- >>> safeLogBase (ssym "base") (ssym "val") :: ExceptT ArithException Union SymAlgReal+  -- ExceptT {If (= base 1.0) (Left Ratio has zero denominator) (Right (fdiv (log val) (log base)))}+  safeLogBase :: a -> a -> m a+  safeLogBase = undefined+  {-# INLINE safeLogBase #-}++instance LogBaseOr SymAlgReal where+  logBaseOr d base a = symIte (base .== 1) d $ logBase base a+  {-# INLINE logBaseOr #-}++instance+  (MonadError ArithException m, MonadUnion m) =>+  SafeLogBase ArithException SymAlgReal m+  where+  safeLogBase base a =+    mrgIf (base .== 1) (throwError RatioZeroDenominator) $ pure $ logBase base a+  {-# INLINE safeLogBase #-}++instance (LogBaseOr a) => LogBaseOr (AsKey a) where+  logBaseOr (AsKey d) (AsKey base) (AsKey a) =+    AsKey $ logBaseOr d base a+  {-# INLINE logBaseOr #-}++instance (SafeLogBase e a m) => SafeLogBase e (AsKey a) m where+  safeLogBase (AsKey base) (AsKey a) = do+    r <- safeLogBase base a+    mrgSingle $ AsKey r+  {-# INLINE safeLogBase #-}
+ src/Grisette/Internal/Core/Data/Class/SafeSymRotate.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.Core.Data.Class.SafeSymRotate+-- 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.SafeSymRotate (SafeSymRotate (..)) where++import Control.Exception (ArithException (Overflow))+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.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.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+      ( pevalRotateLeftTerm,+        pevalRotateRightTerm+      ),+  )+import Grisette.Internal.SymPrim.SymBV+  ( SymIntN (SymIntN),+    SymWordN (SymWordN),+  )++-- | Safe rotation operations. The operators will reject negative shift amounts.+class (MonadError e m, TryMerge m, Mergeable a) => SafeSymRotate e a m where+  safeSymRotateL :: a -> a -> m a+  safeSymRotateR :: a -> a -> m a++-- | This function handles the case when the shift amount is out the range of+-- `Int` correctly.+safeSymRotateLConcreteNum ::+  ( MonadError ArithException m,+    TryMerge m,+    Integral a,+    FiniteBits a,+    Mergeable a+  ) =>+  a ->+  a ->+  m a+safeSymRotateLConcreteNum _ s | s < 0 = tryMerge $ throwError Overflow+safeSymRotateLConcreteNum a 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.+safeSymRotateRConcreteNum ::+  ( MonadError ArithException m,+    TryMerge m,+    Integral a,+    FiniteBits a,+    Mergeable a+  ) =>+  a ->+  a ->+  m a+safeSymRotateRConcreteNum _ s | s < 0 = tryMerge $ throwError Overflow+safeSymRotateRConcreteNum a s =+  mrgSingle $ rotateR a (fromIntegral $ s `rem` fromIntegral (finiteBitSize s))++#define SAFE_SYM_ROTATE_CONCRETE(T) \+  instance (MonadError ArithException m, TryMerge m) => \+    SafeSymRotate ArithException T m where \+    safeSymRotateL = safeSymRotateLConcreteNum; \+    safeSymRotateR = safeSymRotateRConcreteNum \++#if 1+SAFE_SYM_ROTATE_CONCRETE(Word8)+SAFE_SYM_ROTATE_CONCRETE(Word16)+SAFE_SYM_ROTATE_CONCRETE(Word32)+SAFE_SYM_ROTATE_CONCRETE(Word64)+SAFE_SYM_ROTATE_CONCRETE(Word)+SAFE_SYM_ROTATE_CONCRETE(Int8)+SAFE_SYM_ROTATE_CONCRETE(Int16)+SAFE_SYM_ROTATE_CONCRETE(Int32)+SAFE_SYM_ROTATE_CONCRETE(Int64)+SAFE_SYM_ROTATE_CONCRETE(Int)+#endif++instance+  (MonadError ArithException m, TryMerge m, KnownNat n, 1 <= n) =>+  SafeSymRotate ArithException (WordN n) m+  where+  safeSymRotateL = safeSymRotateLConcreteNum+  safeSymRotateR = safeSymRotateRConcreteNum++instance+  (MonadError ArithException m, TryMerge m, KnownNat n, 1 <= n) =>+  SafeSymRotate ArithException (IntN n) m+  where+  safeSymRotateL = safeSymRotateLConcreteNum+  safeSymRotateR = safeSymRotateRConcreteNum++instance+  (MonadError ArithException m, TryMerge m, KnownNat n, 1 <= n) =>+  SafeSymRotate ArithException (SymWordN n) m+  where+  safeSymRotateL (SymWordN ta) (SymWordN tr) =+    mrgSingle $ SymWordN $ pevalRotateLeftTerm ta tr+  safeSymRotateR (SymWordN ta) (SymWordN tr) =+    mrgSingle $ SymWordN $ pevalRotateRightTerm ta tr++instance+  (MonadError ArithException m, MonadUnion m, KnownNat n, 1 <= n) =>+  SafeSymRotate ArithException (SymIntN n) m+  where+  safeSymRotateL (SymIntN ta) r@(SymIntN tr) =+    mrgIf+      (r .< 0)+      (throwError Overflow)+      (mrgSingle $ SymIntN $ pevalRotateLeftTerm ta tr)+  safeSymRotateR (SymIntN ta) r@(SymIntN tr) =+    mrgIf+      (r .< 0)+      (throwError Overflow)+      (mrgSingle $ SymIntN $ pevalRotateRightTerm ta tr)
+ src/Grisette/Internal/Core/Data/Class/SafeSymShift.hs view
@@ -0,0 +1,203 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# 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 (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.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.SimpleMergeable+  ( mrgIf,+  )+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+      ( pevalShiftLeftTerm,+        pevalShiftRightTerm+      ),+  )+import Grisette.Internal.SymPrim.SymBV (SymIntN (SymIntN), SymWordN (SymWordN))++-- | Safe version for `shiftL` or `shiftR`.+--+-- The `safeSymShiftL` and `safeSymShiftR` are defined for all non-negative+-- shift amounts.+--+-- * Shifting by negative shift amounts is an error.+-- * The result is defined to be 0 when shifting left by more than or equal to+-- the  bit size of the number.+-- * The result is defined to be 0 when shifting right by more than or equal to+-- the bit size of the number and the number is unsigned or signed non-negative.+-- * The result is defined to be -1 when shifting right by more than or equal to+-- the bit size of the number and the number is signed negative.+--+-- The `safeSymStrictShiftL` and `safeSymStrictShiftR` are defined for all+-- non-negative shift amounts that is less than the bit size. Shifting by more+-- than or equal to the bit size is an error, otherwise they are the same as the+-- non-strict versions.+class (MonadError e m, TryMerge m, Mergeable a) => SafeSymShift e a m where+  safeSymShiftL :: a -> a -> m a+  safeSymShiftR :: a -> a -> m a+  safeSymStrictShiftL :: a -> a -> m a+  safeSymStrictShiftR :: a -> a -> m a++-- | This function handles the case when the shift amount is out the range of+-- `Int` correctly.+safeSymShiftLConcreteNum ::+  (MonadError ArithException m, TryMerge m, Integral a, FiniteBits a, Mergeable a) =>+  Bool ->+  a ->+  a ->+  m a+safeSymShiftLConcreteNum _ _ s | s < 0 = tryMerge $ throwError Overflow+safeSymShiftLConcreteNum allowLargeShiftAmount a s+  | (fromIntegral s :: Integer) >= fromIntegral (finiteBitSize a) =+      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.+safeSymShiftRConcreteNum ::+  ( MonadError ArithException m,+    TryMerge m,+    Integral a,+    FiniteBits a,+    Mergeable a+  ) =>+  Bool ->+  a ->+  a ->+  m a+safeSymShiftRConcreteNum _ _ s | s < 0 = tryMerge $ throwError Overflow+safeSymShiftRConcreteNum allowLargeShiftAmount a s+  | (fromIntegral s :: Integer) >= fromIntegral (finiteBitSize a) =+      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) => \+    SafeSymShift ArithException T m where \+    safeSymShiftL = safeSymShiftLConcreteNum True; \+    safeSymShiftR = safeSymShiftRConcreteNum True; \+    safeSymStrictShiftL = safeSymShiftLConcreteNum False; \+    safeSymStrictShiftR = safeSymShiftRConcreteNum False++#if 1+SAFE_SYM_SHIFT_CONCRETE(Word8)+SAFE_SYM_SHIFT_CONCRETE(Word16)+SAFE_SYM_SHIFT_CONCRETE(Word32)+SAFE_SYM_SHIFT_CONCRETE(Word64)+SAFE_SYM_SHIFT_CONCRETE(Word)+SAFE_SYM_SHIFT_CONCRETE(Int8)+SAFE_SYM_SHIFT_CONCRETE(Int16)+SAFE_SYM_SHIFT_CONCRETE(Int32)+SAFE_SYM_SHIFT_CONCRETE(Int64)+SAFE_SYM_SHIFT_CONCRETE(Int)+#endif++instance+  (MonadError ArithException m, TryMerge m, KnownNat n, 1 <= n) =>+  SafeSymShift ArithException (WordN n) m+  where+  safeSymShiftL = safeSymShiftLConcreteNum True+  safeSymShiftR = safeSymShiftRConcreteNum True+  safeSymStrictShiftL = safeSymShiftLConcreteNum False+  safeSymStrictShiftR = safeSymShiftRConcreteNum False++instance+  (MonadError ArithException m, TryMerge m, KnownNat n, 1 <= n) =>+  SafeSymShift ArithException (IntN n) m+  where+  safeSymShiftL = safeSymShiftLConcreteNum True+  safeSymShiftR = safeSymShiftRConcreteNum True+  safeSymStrictShiftL = safeSymShiftLConcreteNum False+  safeSymStrictShiftR = safeSymShiftRConcreteNum False++instance+  (MonadError ArithException m, MonadUnion m, KnownNat n, 1 <= n) =>+  SafeSymShift ArithException (SymWordN n) m+  where+  safeSymShiftL (SymWordN a) (SymWordN s) =+    return $ SymWordN $ pevalShiftLeftTerm a s+  safeSymShiftR (SymWordN a) (SymWordN s) =+    return $ SymWordN $ pevalShiftRightTerm a s+  safeSymStrictShiftL a@(SymWordN ta) s@(SymWordN ts) =+    mrgIf+      (s .>= fromIntegral (finiteBitSize a))+      (throwError Overflow)+      (return $ SymWordN $ pevalShiftLeftTerm ta ts)+  safeSymStrictShiftR a@(SymWordN ta) s@(SymWordN ts) =+    mrgIf+      (s .>= fromIntegral (finiteBitSize a))+      (throwError Overflow)+      (return $ SymWordN $ pevalShiftRightTerm ta ts)++instance+  (MonadError ArithException m, MonadUnion m, KnownNat n, 1 <= n) =>+  SafeSymShift ArithException (SymIntN n) m+  where+  safeSymShiftL (SymIntN a) ss@(SymIntN s) =+    mrgIf+      (ss .< 0)+      (throwError Overflow)+      (return $ SymIntN $ pevalShiftLeftTerm a s)+  safeSymShiftR (SymIntN a) ss@(SymIntN s) =+    mrgIf+      (ss .< 0)+      (throwError Overflow)+      (return $ SymIntN $ pevalShiftRightTerm a s)+  safeSymStrictShiftL a@(SymIntN ta) s@(SymIntN ts) =+    mrgIf+      (s .< 0 .|| (bs .>= 0 .&& s .>= bs))+      (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))+      (throwError Overflow)+      (return $ SymIntN $ pevalShiftRightTerm ta ts)+    where+      bs = fromIntegral (finiteBitSize a)
+ src/Grisette/Internal/Core/Data/Class/SignConversion.hs view
@@ -0,0 +1,45 @@+{-# 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 (..),+  )+where++import Data.Int (Int16, Int32, Int64, Int8)+import Data.Word (Word16, Word32, Word64, Word8)++-- | Convert values between signed and unsigned.+class SignConversion ubv sbv | ubv -> sbv, sbv -> ubv where+  -- | Convert unsigned value to the corresponding signed value.+  toSigned :: ubv -> sbv++  -- | Convert signed value to the corresponding unsigned value.+  toUnsigned :: sbv -> ubv++instance SignConversion Word8 Int8 where+  toSigned = fromIntegral+  toUnsigned = fromIntegral++instance SignConversion Word16 Int16 where+  toSigned = fromIntegral+  toUnsigned = fromIntegral++instance SignConversion Word32 Int32 where+  toSigned = fromIntegral+  toUnsigned = fromIntegral++instance SignConversion Word64 Int64 where+  toSigned = fromIntegral+  toUnsigned = fromIntegral++instance SignConversion Word Int where+  toSigned = fromIntegral+  toUnsigned = fromIntegral
+ src/Grisette/Internal/Core/Data/Class/SimpleMergeable.hs view
@@ -0,0 +1,34 @@+{-# OPTIONS_GHC -Wno-missing-import-lists #-}++-- |+-- Module      :   Grisette.Internal.Core.Data.Class.SimpleMergeable+-- 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.SimpleMergeable+  ( -- * Simple mergeable types+    SimpleMergeable (..),+    SimpleMergeable1 (..),+    mrgIte1,+    SimpleMergeable2 (..),+    mrgIte2,++    -- * Generic 'SimpleMergeable'+    SimpleMergeableArgs (..),+    GSimpleMergeable (..),+    genericMrgIte,+    genericLiftMrgIte,++    -- * Symbolic branching+    SymBranching (..),+    mrgIf,+    mergeWithStrategy,+    merge,+  )+where++import Grisette.Internal.Internal.Decl.Core.Data.Class.SimpleMergeable+import Grisette.Internal.Internal.Impl.Core.Data.Class.SimpleMergeable ()
+ src/Grisette/Internal/Core/Data/Class/Solvable.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# HLINT ignore "Unused LANGUAGE pragma" #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++-- |+-- Module      :   Grisette.Internal.Core.Data.Class.Solvable+-- 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.Solvable+  ( -- * Solvable type interface+    Solvable (..),+    pattern Con,+    slocsym,+    ilocsym,+  )+where++import Data.String (IsString)+import qualified Data.Text as T+import Grisette.Internal.Core.Data.Class.AsKey (AsKey (AsKey), AsKey1 (AsKey1))+import Grisette.Internal.Core.Data.Symbol+  ( Identifier,+    Symbol (IndexedSymbol, SimpleSymbol),+    withLocation,+  )+import Language.Haskell.TH.Syntax.Compat (SpliceQ)++-- $setup+-- >>> import Grisette.Core+-- >>> import Grisette.SymPrim++-- | The class defines the creation and pattern matching of solvable type+-- values.+class (IsString t) => Solvable c t | t -> c where+  -- | Wrap a concrete value in a symbolic value.+  --+  -- >>> con True :: SymBool+  -- true+  con :: c -> t++  -- | Extract the concrete value from a symbolic value.+  --+  -- >>> conView (con True :: SymBool)+  -- Just True+  --+  -- >>> conView (ssym "a" :: SymBool)+  -- Nothing+  conView :: t -> Maybe c++  -- | Generate symbolic constants.+  --+  -- Two symbolic constants with the same symbol are the same symbolic constant,+  -- and will always be assigned with the same value by the solver.+  --+  -- In the examples, we use 'AsKey' to check if two symbolic constants are the+  -- same term, concretely.+  --+  -- >>> sym "a" :: SymBool+  -- a+  -- >>> AsKey (sym "a" :: SymBool) == AsKey (sym "a" :: SymBool)+  -- True+  -- >>> AsKey (sym "a" :: SymBool) == AsKey (sym "b")+  -- False+  -- >>> (sym "a" :: SymBool) .&& sym "a"+  -- a+  -- >>> AsKey (sym "a" :: SymBool) == AsKey (isym "a" 1)+  -- False+  sym :: Symbol -> t++  -- | Generate simply-named symbolic constants.+  --+  -- Two symbolic constants with the same identifier are the same symbolic+  -- constant, and will always be assigned with the same value by the solver.+  --+  -- In the examples, we use 'AsKey' to check if two symbolic constants are the+  -- same term, concretely.+  --+  -- >>> ssym "a" :: SymBool+  -- a+  -- >>> AsKey (ssym "a" :: SymBool) == AsKey (ssym "a" :: SymBool)+  -- True+  -- >>> AsKey (ssym "a" :: SymBool) == AsKey (ssym "b")+  -- False+  -- >>> (ssym "a" :: SymBool) .&& ssym "a"+  -- a+  ssym :: Identifier -> t+  ssym = sym . SimpleSymbol++  -- | Generate indexed symbolic constants.+  --+  -- Two symbolic constants with the same identifier but different indices are+  -- not the same symbolic constants.+  --+  -- >>> isym "a" 1 :: SymBool+  -- a@1+  isym :: Identifier -> Int -> t+  isym nm idx = sym $ IndexedSymbol nm idx++-- | Extract the concrete value from a solvable value with 'conView'.+--+-- >>> case con True :: SymBool of Con v -> v+-- True+pattern Con :: (Solvable c t) => c -> t+pattern Con c <-+  (conView -> Just c)+  where+    Con c = con c++-- | Generate simply-named symbolic variables. The file location will be+-- attached to the identifier.+--+-- >>> $$(slocsym "a") :: SymBool+-- a:[grisette-file-location <interactive>...]+--+-- Calling 'slocsym' with the same name at different location will always+-- generate different symbolic constants. Calling 'slocsym' at the same+-- location for multiple times will generate the same symbolic constants.+--+-- In the examples, we use 'AsKey' to check if two symbolic constants are the+-- same term, concretely.+--+-- >>> AsKey ($$(slocsym "a") :: SymBool) == AsKey ($$(slocsym "a") :: SymBool)+-- False+-- >>> let f _ = $$(slocsym "a") :: SymBool+-- >>> AsKey (f ()) == AsKey (f ())+-- True+slocsym :: (Solvable c s) => T.Text -> SpliceQ s+slocsym nm = [||ssym $$(withLocation nm)||]++-- | Generate indexed symbolic variables. The file location will be attached to+-- the identifier.+--+-- >>> $$(ilocsym "a" 1) :: SymBool+-- a:[grisette-file-location <interactive>...]@1+--+-- Calling 'ilocsym' with the same name and index at different location will+-- always generate different symbolic constants. Calling 'slocsym' at the same+-- location for multiple times will generate the same symbolic constants.+ilocsym :: (Solvable c s) => T.Text -> Int -> SpliceQ s+ilocsym nm idx = [||isym $$(withLocation nm) idx||]++instance (Solvable c s) => Solvable c (AsKey s) where+  con = AsKey . con+  conView (AsKey s) = conView s+  sym = AsKey . sym+  ssym = AsKey . ssym+  isym ident = AsKey . isym ident++instance (Solvable c (f s)) => Solvable c (AsKey1 f s) where+  con = AsKey1 . con+  conView (AsKey1 s) = conView s+  sym = AsKey1 . sym+  ssym = AsKey1 . ssym+  isym ident = AsKey1 . isym ident
+ src/Grisette/Internal/Core/Data/Class/Solver.hs view
@@ -0,0 +1,42 @@+{-# OPTIONS_GHC -Wno-missing-import-lists #-}++-- |+-- Module      :   Grisette.Internal.Core.Data.Class.Solver+-- 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.Solver+  ( -- * Note for the examples++    --++    -- | The examples assumes that the [z3](https://github.com/Z3Prover/z3)+    -- solver is available in @PATH@.++    -- * Solver interfaces+    SolvingFailure (..),+    MonadicSolver (..),+    monadicSolverSolve,+    SolverCommand (..),+    ConfigurableSolver (..),+    Solver (..),+    solverSolve,+    withSolver,+    solve,+    solverSolveMulti,+    solveMulti,++    -- * Union with exceptions+    UnionWithExcept (..),+    solverSolveExcept,+    solveExcept,+    solverSolveMultiExcept,+    solveMultiExcept,+  )+where++import Grisette.Internal.Internal.Decl.Core.Data.Class.Solver+import Grisette.Internal.Internal.Impl.Core.Data.Class.Solver ()
+ src/Grisette/Internal/Core/Data/Class/SubstSym.hs view
@@ -0,0 +1,28 @@+{-# OPTIONS_GHC -Wno-missing-import-lists #-}++-- |+-- 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 Grisette.Internal.Internal.Decl.Core.Data.Class.SubstSym+import Grisette.Internal.Internal.Impl.Core.Data.Class.SubstSym ()
+ src/Grisette/Internal/Core/Data/Class/SymEq.hs view
@@ -0,0 +1,32 @@+{-# OPTIONS_GHC -Wno-missing-import-lists #-}++-- |+-- 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,+    pairwiseSymDistinct,++    -- * More 'Eq' helper+    distinct,++    -- * Generic 'SymEq'+    SymEqArgs (..),+    GSymEq (..),+    genericSymEq,+    genericLiftSymEq,+  )+where++import Grisette.Internal.Internal.Decl.Core.Data.Class.SymEq+import Grisette.Internal.Internal.Impl.Core.Data.Class.SymEq ()
+ src/Grisette/Internal/Core/Data/Class/SymFiniteBits.hs view
@@ -0,0 +1,229 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.Core.Data.Class.SymFiniteBits+-- 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.SymFiniteBits+  ( lsb,+    msb,+    setBitTo,+    bitBlast,+    FromBits (..),+    SymFiniteBits (..),+    symBitBlast,+    symLsb,+    symMsb,+    symPopCount,+    symCountLeadingZeros,+    symCountTrailingZeros,+  )+where++import Data.Bits+  ( Bits (bit, clearBit, setBit, testBit, zeroBits, (.|.)),+    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.Data.Class.BitVector+  ( BV (bv, bvConcat, bvSelect),+  )+import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp (symIte))+import Grisette.Internal.Core.Data.Class.SymEq (SymEq ((.==)))+import Grisette.Internal.SymPrim.BV (IntN, WordN)+import Grisette.Internal.SymPrim.SomeBV+  ( SomeBV (SomeBV),+    SomeIntN,+    SomeWordN,+    unsafeSomeBV,+  )+import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN)+import Grisette.Internal.SymPrim.SymBool (SymBool)+import Unsafe.Coerce (unsafeCoerce)++-- | Set a bit in a concrete value to a specific value.+setBitTo :: (Bits a) => a -> Int -> Bool -> a+setBitTo v i b = if b then setBit v i else clearBit v i++-- | Bit-blast a concrete value into a list of concrete bits. The first element+-- in the resulting list corresponds to the least significant bit.+bitBlast :: (FiniteBits a) => a -> [Bool]+bitBlast x = map (testBit x) [0 .. finiteBitSize x - 1]++-- | Extract the least significant bit of a concrete value.+lsb :: (Bits a) => a -> Bool+lsb x = testBit x 0++-- | Extract the most significant bit of a concrete value.+msb :: (FiniteBits a) => a -> Bool+msb x = testBit x (finiteBitSize x - 1)++-- | Type class for assembling concrete bits to a bit-vector.+class (FiniteBits a) => FromBits a where+  -- | Assembling concrete bits to a bit-vector. The first boolean value in the+  -- list corresponding to the least signification value.+  fromBits :: [Bool] -> a+  fromBits bits+    | length bits /= finiteBitSize (undefined :: a) =+        error "fromBits: length mismatch"+    | otherwise = foldl1 (.|.) lst+    where+      lst :: [a]+      lst = (\(pos, b) -> if b then bit pos else zeroBits) <$> zip [0 ..] bits++instance FromBits Int++instance FromBits Int8++instance FromBits Int16++instance FromBits Int32++instance FromBits Int64++instance FromBits Word++instance FromBits Word8++instance FromBits Word16++instance FromBits Word32++instance FromBits Word64++instance (KnownNat n, 1 <= n) => FromBits (WordN n)++instance (KnownNat n, 1 <= n) => FromBits (IntN n)++instance FromBits SomeIntN where+  fromBits bits+    | null bits =+        error "Cannot create a SomeBV from an empty list of bits."+  fromBits bits = unsafeSomeBV (length bits) $ \_ -> fromBits bits++instance FromBits SomeWordN where+  fromBits bits+    | null bits =+        error "Cannot create a SomeBV from an empty list of bits."+  fromBits bits = unsafeSomeBV (length bits) $ \_ -> fromBits bits++-- | A class for symbolic finite bit operations.+class (FiniteBits a, ITEOp a) => SymFiniteBits a where+  -- | Test a symbolic bit in a symbolic bit-vector.+  symTestBit :: a -> Int -> SymBool++  -- | Set a bit in a symbolic value to a specific value.+  symSetBitTo :: a -> Int -> SymBool -> a+  symSetBitTo v i b = symIte b (setBit v i) (clearBit v i)++  -- | Assembling symbolic bits to a symbolic bit-vector. The first symbolic+  -- boolean value in the list corresponding to the least signification value.+  symFromBits :: [SymBool] -> a++instance SymFiniteBits (SomeBV SymIntN) where+  symTestBit v i = bvSelect i 1 v .== bv 1 1+  symFromBits bits+    | null bits =+        error "Cannot create a SomeBV from an empty list of bits."+  symFromBits bits = unsafeSomeBV (length bits) $ \_ -> symFromBits bits++instance SymFiniteBits (SomeBV SymWordN) where+  symTestBit v i = bvSelect i 1 v .== bv 1 1+  symFromBits bits+    | null bits =+        error "Cannot create a SomeBV from an empty list of bits."+  symFromBits bits = unsafeSomeBV (length bits) $ \_ -> symFromBits bits++instance (KnownNat n, 1 <= n) => SymFiniteBits (SymIntN n) where+  symTestBit v = symTestBit (SomeBV v)+  symSetBitTo v i b = symIte b (setBit v i) (clearBit v i)+  symFromBits bits+    | length bits /= finiteBitSize (undefined :: SymWordN n) =+        error "symFromBits: length mismatch"+    | otherwise = case foldl1 bvConcat $ SomeBV <$> reverse lst of+        SomeBV r -> unsafeCoerce r+        _ -> error "symFromBits: length mismatch"+    where+      lst :: [SymIntN 1]+      lst = (\b -> symIte b 1 0) <$> bits++instance (KnownNat n, 1 <= n) => SymFiniteBits (SymWordN n) where+  symTestBit v = symTestBit (SomeBV v)+  symSetBitTo v i b = symIte b (setBit v i) (clearBit v i)+  symFromBits bits+    | length bits /= finiteBitSize (undefined :: SymWordN n) =+        error "symFromBits: length mismatch"+    | otherwise = case foldl1 bvConcat $ SomeBV <$> reverse lst of+        SomeBV r -> unsafeCoerce r+        _ -> error "symFromBits: length mismatch"+    where+      lst :: [SymWordN 1]+      lst = (\b -> symIte b 1 0) <$> bits++-- | Bit-blast a symbolic value into a list of symbolic bits. The first element+-- in the resulting list corresponds to the least significant bit.+symBitBlast :: (SymFiniteBits a) => a -> [SymBool]+symBitBlast x = map (symTestBit x) [0 .. finiteBitSize x - 1]++-- | Extract the least significant bit of a symbolic value.+symLsb :: (SymFiniteBits a) => a -> SymBool+symLsb x = symTestBit x 0++-- | Extract the most significant bit of a symbolic value.+symMsb :: (SymFiniteBits a) => a -> SymBool+symMsb x = symTestBit x (finiteBitSize x - 1)++-- | Count the number of set bits in a symbolic value.+symPopCount :: (Num a, ITEOp a, SymFiniteBits a) => a -> a+symPopCount v = 0 * v + adderTree (map fromBool (symBitBlast v))+  where+    -- Convert a symbolic boolean to a numeric value (0 or 1)+    -- Node: 0 * v + is a trick to assign the correct bit-width to the result.+    fromBool b = 0 * v + symIte b 1 0++    -- Implement binary adder tree to efficiently sum values+    adderTree :: (Num a) => [a] -> a+    adderTree [] = 0+    adderTree [x] = x+    adderTree xs = adderTree (pairwiseAdd xs)++    -- Add adjacent pairs of values+    pairwiseAdd :: (Num a) => [a] -> [a]+    pairwiseAdd [] = []+    pairwiseAdd [x] = [x]+    pairwiseAdd (x : y : rest) = (x + y) : pairwiseAdd rest++-- | Count the number of leading zeros in a symbolic value.+symCountLeadingZeros :: (Num a, ITEOp a, SymFiniteBits a) => a -> a+-- Node: 0 * v + is a trick to assign the correct bit-width to the result.+symCountLeadingZeros v = 0 * v + go bits rs+  where+    bits = reverse $ symBitBlast v+    rs = fromIntegral <$> [0 ..]+    go [] (r : _) = r+    go (b : bs) (r : rs) = symIte b r (go bs rs)+    go _ [] = error "Should not happen"++-- | Count the number of trailing zeros in a symbolic value.+symCountTrailingZeros :: (Num a, ITEOp a, SymFiniteBits a) => a -> a+-- Node: 0 * v + is a trick to assign the correct bit-width to the result.+symCountTrailingZeros v = 0 * v + go bits rs+  where+    bits = symBitBlast v+    rs = fromIntegral <$> [0 ..]+    go [] (r : _) = r+    go (b : bs) (r : rs) = symIte b r (go bs rs)+    go _ [] = error "Should not happen"
+ src/Grisette/Internal/Core/Data/Class/SymFromIntegral.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.Core.Data.Class.SymFromIntegral+-- 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.SymFromIntegral+  ( SymFromIntegral (..),+  )+where++import GHC.TypeLits (KnownNat, type (<=))+import Grisette.Internal.Core.Data.Class.AsKey (AsKey (AsKey))+import Grisette.Internal.SymPrim.FP (ValidFP)+import Grisette.Internal.SymPrim.Prim.Internal.Term+  ( PEvalFromIntegralTerm (pevalFromIntegralTerm),+  )+import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal (SymAlgReal))+import Grisette.Internal.SymPrim.SymBV (SymIntN (SymIntN), SymWordN (SymWordN))+import Grisette.Internal.SymPrim.SymFP (SymFP (SymFP))+import Grisette.Internal.SymPrim.SymInteger (SymInteger (SymInteger))++-- | Conversion from a symbolic integral type.+class SymFromIntegral from to where+  symFromIntegral :: from -> to++instance SymFromIntegral SymInteger SymInteger where+  symFromIntegral = id+  {-# INLINE symFromIntegral #-}++instance SymFromIntegral SymInteger SymAlgReal where+  symFromIntegral (SymInteger x) = SymAlgReal $ pevalFromIntegralTerm x+  {-# INLINE symFromIntegral #-}++instance (KnownNat n, 1 <= n) => SymFromIntegral SymInteger (SymWordN n) where+  symFromIntegral (SymInteger x) = SymWordN $ pevalFromIntegralTerm x+  {-# INLINE symFromIntegral #-}++instance (KnownNat n, 1 <= n) => SymFromIntegral SymInteger (SymIntN n) where+  symFromIntegral (SymInteger x) = SymIntN $ pevalFromIntegralTerm x+  {-# INLINE symFromIntegral #-}++instance (ValidFP eb sb) => SymFromIntegral SymInteger (SymFP eb sb) where+  symFromIntegral (SymInteger x) = SymFP $ pevalFromIntegralTerm x+  {-# INLINE symFromIntegral #-}++instance (KnownNat n, 1 <= n) => SymFromIntegral (SymWordN n) SymInteger where+  symFromIntegral (SymWordN x) = SymInteger $ pevalFromIntegralTerm x+  {-# INLINE symFromIntegral #-}++instance+  (KnownNat n, KnownNat m, 1 <= n, 1 <= m) =>+  SymFromIntegral (SymWordN n) (SymWordN m)+  where+  symFromIntegral (SymWordN x) = SymWordN $ pevalFromIntegralTerm x+  {-# INLINE symFromIntegral #-}++instance (KnownNat n, 1 <= n) => SymFromIntegral (SymWordN n) SymAlgReal where+  symFromIntegral (SymWordN x) = SymAlgReal $ pevalFromIntegralTerm x+  {-# INLINE symFromIntegral #-}++instance+  (KnownNat n, KnownNat m, 1 <= n, 1 <= m) =>+  SymFromIntegral (SymWordN n) (SymIntN m)+  where+  symFromIntegral (SymWordN x) = SymIntN $ pevalFromIntegralTerm x+  {-# INLINE symFromIntegral #-}++instance+  (KnownNat n, 1 <= n, ValidFP eb sb) =>+  SymFromIntegral (SymWordN n) (SymFP eb sb)+  where+  symFromIntegral (SymWordN x) = SymFP $ pevalFromIntegralTerm x+  {-# INLINE symFromIntegral #-}++instance (KnownNat n, 1 <= n) => SymFromIntegral (SymIntN n) SymInteger where+  symFromIntegral (SymIntN x) = SymInteger $ pevalFromIntegralTerm x+  {-# INLINE symFromIntegral #-}++instance+  (KnownNat n, KnownNat m, 1 <= n, 1 <= m) =>+  SymFromIntegral (SymIntN n) (SymWordN m)+  where+  symFromIntegral (SymIntN x) = SymWordN $ pevalFromIntegralTerm x+  {-# INLINE symFromIntegral #-}++instance (KnownNat n, 1 <= n) => SymFromIntegral (SymIntN n) SymAlgReal where+  symFromIntegral (SymIntN x) = SymAlgReal $ pevalFromIntegralTerm x+  {-# INLINE symFromIntegral #-}++instance+  (KnownNat n, KnownNat m, 1 <= n, 1 <= m) =>+  SymFromIntegral (SymIntN n) (SymIntN m)+  where+  symFromIntegral (SymIntN x) = SymIntN $ pevalFromIntegralTerm x+  {-# INLINE symFromIntegral #-}++instance+  (KnownNat n, 1 <= n, ValidFP eb sb) =>+  SymFromIntegral (SymIntN n) (SymFP eb sb)+  where+  symFromIntegral (SymIntN x) = SymFP $ pevalFromIntegralTerm x+  {-# INLINE symFromIntegral #-}++instance+  {-# INCOHERENT #-}+  (SymFromIntegral a b) =>+  SymFromIntegral (AsKey a) (AsKey b)+  where+  symFromIntegral (AsKey x) = AsKey $ symFromIntegral x+  {-# INLINE symFromIntegral #-}++instance+  {-# INCOHERENT #-}+  (SymFromIntegral a b) =>+  SymFromIntegral (AsKey a) b+  where+  symFromIntegral (AsKey x) = symFromIntegral x+  {-# INLINE symFromIntegral #-}++instance+  {-# INCOHERENT #-}+  (SymFromIntegral a b) =>+  SymFromIntegral a (AsKey b)+  where+  symFromIntegral x = AsKey $ symFromIntegral x+  {-# INLINE symFromIntegral #-}
+ src/Grisette/Internal/Core/Data/Class/SymIEEEFP.hs view
@@ -0,0 +1,163 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.Core.Data.Class.SymIEEEFP+-- 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.SymIEEEFP+  ( SymIEEEFPTraits (..),+  )+where++import Grisette.Internal.Core.Data.Class.AsKey (AsKey (AsKey))+import Grisette.Internal.Core.Data.Class.IEEEFP+  ( fpIsInfinite,+    fpIsNaN,+    fpIsNegative,+    fpIsNegativeInfinite,+    fpIsNegativeZero,+    fpIsNormal,+    fpIsPoint,+    fpIsPositive,+    fpIsPositiveInfinite,+    fpIsPositiveZero,+    fpIsSubnormal,+    fpIsZero,+  )+import Grisette.Internal.Core.Data.Class.Solvable (Solvable (con))+import Grisette.Internal.SymPrim.FP (FP, ValidFP)+import Grisette.Internal.SymPrim.SymBool (SymBool)++-- | A class for symbolic traits of IEEE floating-point numbers.+class SymIEEEFPTraits a where+  -- | Check if a symbolic floating-point number is not-a-number.+  symFpIsNaN :: a -> SymBool++  -- | Check if a symbolic floating-point number is positive.+  -- +0, +inf are considered positive. nan, -0, -inf are not positive.+  symFpIsPositive :: a -> SymBool++  -- | Check if a symbolic floating-point number is negative.+  -- -0, -inf are considered negative. nan, +0, +inf are not negative.+  symFpIsNegative :: a -> SymBool++  -- | Check if a symbolic floating-point number is positive infinite.+  symFpIsPositiveInfinite :: a -> SymBool++  -- | Check if a symbolic floating-point number is negative infinite.+  symFpIsNegativeInfinite :: a -> SymBool++  -- | Check if a symbolic floating-point number is infinite.+  symFpIsInfinite :: a -> SymBool++  -- | Check if a symbolic floating-point number is positive zero.+  symFpIsPositiveZero :: a -> SymBool++  -- | Check if a symbolic floating-point number is negative zero.+  symFpIsNegativeZero :: a -> SymBool++  -- | Check if a symbolic floating-point number is zero.+  symFpIsZero :: a -> SymBool++  -- | Check if a symbolic floating-point number is normal, i.e., not 0, not+  -- inf, not nan, and not denormalized.+  symFpIsNormal :: a -> SymBool++  -- | Check if a symbolic floating-point number is subnormal, i.e.,+  -- denormalized. 0, inf, or nan are not subnormal.+  symFpIsSubnormal :: a -> SymBool++  -- | Check if a symbolic floating-point number is a point, i.e., not inf, not+  -- nan.+  symFpIsPoint :: a -> SymBool++newtype ConcreteFloat f = ConcreteFloat f++instance (RealFloat f) => SymIEEEFPTraits (ConcreteFloat f) where+  symFpIsNaN (ConcreteFloat x) = con $ fpIsNaN x+  {-# INLINE symFpIsNaN #-}++  symFpIsPositive (ConcreteFloat x) = con $ fpIsPositive x+  {-# INLINE symFpIsPositive #-}++  symFpIsNegative (ConcreteFloat x) = con $ fpIsNegative x+  {-# INLINE symFpIsNegative #-}++  symFpIsInfinite (ConcreteFloat x) = con $ fpIsInfinite x+  {-# INLINE symFpIsInfinite #-}++  symFpIsPositiveInfinite (ConcreteFloat x) = con $ fpIsPositiveInfinite x+  {-# INLINE symFpIsPositiveInfinite #-}++  symFpIsNegativeInfinite (ConcreteFloat x) = con $ fpIsNegativeInfinite x+  {-# INLINE symFpIsNegativeInfinite #-}++  symFpIsPositiveZero (ConcreteFloat x) = con $ fpIsPositiveZero x+  {-# INLINE symFpIsPositiveZero #-}++  symFpIsNegativeZero (ConcreteFloat x) = con $ fpIsNegativeZero x+  {-# INLINE symFpIsNegativeZero #-}++  symFpIsZero (ConcreteFloat x) = con $ fpIsZero x+  {-# INLINE symFpIsZero #-}++  symFpIsNormal (ConcreteFloat x) = con $ fpIsNormal x+  {-# INLINE symFpIsNormal #-}++  symFpIsSubnormal (ConcreteFloat x) = con $ fpIsSubnormal x+  {-# INLINE symFpIsSubnormal #-}++  symFpIsPoint (ConcreteFloat x) = con $ fpIsPoint x+  {-# INLINE symFpIsPoint #-}++deriving via (ConcreteFloat Float) instance SymIEEEFPTraits Float++deriving via (ConcreteFloat Double) instance SymIEEEFPTraits Double++deriving via+  (ConcreteFloat (FP eb sb))+  instance+    (ValidFP eb sb) => SymIEEEFPTraits (FP eb sb)++instance (SymIEEEFPTraits a) => SymIEEEFPTraits (AsKey a) where+  symFpIsNaN (AsKey a) = symFpIsNaN a+  {-# INLINE symFpIsNaN #-}++  symFpIsPositive (AsKey a) = symFpIsPositive a+  {-# INLINE symFpIsPositive #-}++  symFpIsNegative (AsKey a) = symFpIsNegative a+  {-# INLINE symFpIsNegative #-}++  symFpIsInfinite (AsKey a) = symFpIsInfinite a+  {-# INLINE symFpIsInfinite #-}++  symFpIsPositiveZero (AsKey a) = symFpIsPositiveZero a+  {-# INLINE symFpIsPositiveZero #-}++  symFpIsNegativeZero (AsKey a) = symFpIsNegativeZero a+  {-# INLINE symFpIsNegativeZero #-}++  symFpIsZero (AsKey a) = symFpIsZero a+  {-# INLINE symFpIsZero #-}++  symFpIsNormal (AsKey a) = symFpIsNormal a+  {-# INLINE symFpIsNormal #-}++  symFpIsSubnormal (AsKey a) = symFpIsSubnormal a+  {-# INLINE symFpIsSubnormal #-}++  symFpIsPoint (AsKey a) = symFpIsPoint a+  {-# INLINE symFpIsPoint #-}++  symFpIsPositiveInfinite (AsKey a) = symFpIsPositiveInfinite a+  {-# INLINE symFpIsPositiveInfinite #-}++  symFpIsNegativeInfinite (AsKey a) = symFpIsNegativeInfinite a+  {-# INLINE symFpIsNegativeInfinite #-}
+ src/Grisette/Internal/Core/Data/Class/SymOrd.hs view
@@ -0,0 +1,34 @@+{-# OPTIONS_GHC -Wno-missing-import-lists #-}++-- |+-- 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 Grisette.Internal.Internal.Decl.Core.Data.Class.SymOrd+import Grisette.Internal.Internal.Impl.Core.Data.Class.SymOrd ()
+ src/Grisette/Internal/Core/Data/Class/SymRotate.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# 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 (..),+  )+where++import Data.Bits (Bits (isSigned, rotate), FiniteBits (finiteBitSize))+import Data.Int (Int16, Int32, Int64, Int8)+import Data.Word (Word16, Word32, Word64, Word8)++-- | The `symRotate` is similar to `rotate`, but accepts the type itself instead+-- of `Int` for the rotate amount. The function works on all inputs, including+-- the rotate amounts that are beyond the bit width of the value.+--+-- The `symRotateNegated` function rotates to the opposite direction of+-- `symRotate`. This function is introduced to handle the asymmetry of the range+-- of values.+class (Bits a) => SymRotate a where+  symRotate :: a -> a -> a+  symRotateNegated :: a -> a -> a++instance SymRotate Int where+  symRotate = rotate+  symRotateNegated a s+    | 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+  }+  deriving newtype (Eq, Bits)++instance+  (Integral a, FiniteBits a) =>+  SymRotate (DefaultFiniteBitsSymRotate a)+  where+  symRotate (DefaultFiniteBitsSymRotate a) (DefaultFiniteBitsSymRotate s)+    | isSigned a = DefaultFiniteBitsSymRotate $ symRotateSigned a s+    | otherwise = DefaultFiniteBitsSymRotate $ symRotateUnsigned a s+    where+      symRotateUnsigned :: a -> a -> a+      symRotateUnsigned a s =+        rotate a (fromIntegral (s `mod` fromIntegral (finiteBitSize a)))+      symRotateSigned :: a -> a -> a+      symRotateSigned a s+        | finiteBitSize s == 1 = a+        | finiteBitSize s == 2 = rotate a (fromIntegral s)+        | otherwise =+            rotate a (fromIntegral (s `mod` fromIntegral (finiteBitSize a)))+  symRotateNegated (DefaultFiniteBitsSymRotate a) (DefaultFiniteBitsSymRotate s)+    | isSigned a = DefaultFiniteBitsSymRotate $ symRotateSigned a s+    | otherwise = DefaultFiniteBitsSymRotate $ symRotateUnsigned a s+    where+      bs = fromIntegral (finiteBitSize a)+      smodbs = s `mod` bs+      symRotateUnsigned :: a -> a -> a+      symRotateUnsigned a _ =+        rotate a (fromIntegral (bs - smodbs))+      symRotateSigned :: a -> a -> a+      symRotateSigned a s+        | finiteBitSize a == 1 = a+        | finiteBitSize a == 2 = rotate a (-fromIntegral s)+        | otherwise =+            if smodbs > 0+              then rotate a (fromIntegral (bs - smodbs))+              else rotate a (fromIntegral (-smodbs))++deriving via (DefaultFiniteBitsSymRotate Int8) instance SymRotate Int8++deriving via (DefaultFiniteBitsSymRotate Int16) instance SymRotate Int16++deriving via (DefaultFiniteBitsSymRotate Int32) instance SymRotate Int32++deriving via (DefaultFiniteBitsSymRotate Int64) instance SymRotate Int64++deriving via (DefaultFiniteBitsSymRotate Word8) instance SymRotate Word8++deriving via (DefaultFiniteBitsSymRotate Word16) instance SymRotate Word16++deriving via (DefaultFiniteBitsSymRotate Word32) instance SymRotate Word32++deriving via (DefaultFiniteBitsSymRotate Word64) instance SymRotate Word64++deriving via (DefaultFiniteBitsSymRotate Word) instance SymRotate Word
+ src/Grisette/Internal/Core/Data/Class/SymShift.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# 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 (..),+  )+where++import Data.Bits (Bits (isSigned, shift, shiftR), FiniteBits (finiteBitSize))+import Data.Int (Int16, Int32, Int64, Int8)+import Data.Word (Word16, Word32, Word64, Word8)++-- | A class for shifting operations.+--+-- The `symShift` function shifts the value to the left if the shift amount is+-- positive, and to the right if the shift amount is negative. If shifting+-- beyond the bit width of the value, the result is the same as shifting with+-- the bit width.+--+-- The `symShiftNegated` function shifts the value to the right if the shift+-- amount is positive, and to the left if the shift amount is negative. This+-- function is introduced to handle the asymmetry of the range of values.+class (Bits a) => SymShift a where+  symShift :: a -> a -> a+  symShiftNegated :: a -> a -> a++instance SymShift Int where+  symShift a s+    | s >= finiteBitSize s = 0+    | s <= -finiteBitSize s = if a >= 0 then 0 else -1+    | otherwise = shift a s+  symShiftNegated :: Int -> Int -> Int+  symShiftNegated a s+    | 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+  }+  deriving newtype (Eq, Bits)++instance+  (Integral a, FiniteBits a) =>+  SymShift (DefaultFiniteBitsSymShift a)+  where+  symShift (DefaultFiniteBitsSymShift a) (DefaultFiniteBitsSymShift s)+    | isSigned a = DefaultFiniteBitsSymShift $ symShiftSigned a s+    | otherwise = DefaultFiniteBitsSymShift $ symShiftUnsigned a s+    where+      symShiftUnsigned :: (Integral a, FiniteBits a) => a -> a -> a+      symShiftUnsigned a s+        | s >= fromIntegral (finiteBitSize a) = 0+        | otherwise = shift a (fromIntegral s)+      {-# INLINE symShiftUnsigned #-}++      symShiftSigned :: (Integral a, FiniteBits a) => a -> a -> a+      symShiftSigned a s+        | finiteBitSize s == 1 = shift a (fromIntegral s)+        | finiteBitSize s == 2 = shift a (fromIntegral s)+        | s >= fromIntegral (finiteBitSize a) = 0+        | s <= fromIntegral (-finiteBitSize a) = if a < 0 then -1 else 0+        | otherwise = shift a (fromIntegral s)+      {-# INLINE symShiftSigned #-}+  {-# INLINE symShift #-}+  symShiftNegated (DefaultFiniteBitsSymShift a) (DefaultFiniteBitsSymShift s)+    | isSigned a = DefaultFiniteBitsSymShift $ symShiftSigned a s+    | otherwise = DefaultFiniteBitsSymShift $ symShiftUnsigned a s+    where+      symShiftUnsigned :: (Integral a, FiniteBits a) => a -> a -> a+      symShiftUnsigned a s+        | s >= fromIntegral (finiteBitSize a) = 0+        | otherwise = shiftR a (fromIntegral s)+      {-# INLINE symShiftUnsigned #-}++      symShiftSigned :: (Integral a, FiniteBits a) => a -> a -> a+      symShiftSigned a s+        | finiteBitSize s == 1 = shift a (-fromIntegral s)+        | finiteBitSize s == 2 = shift a (-fromIntegral s)+        | s <= fromIntegral (-finiteBitSize a) = 0+        | s >= fromIntegral (finiteBitSize a) = if a < 0 then -1 else 0+        | otherwise = shift a (-fromIntegral s)+      {-# INLINE symShiftSigned #-}+  {-# INLINE symShiftNegated #-}++deriving via (DefaultFiniteBitsSymShift Int8) instance SymShift Int8++deriving via (DefaultFiniteBitsSymShift Int16) instance SymShift Int16++deriving via (DefaultFiniteBitsSymShift Int32) instance SymShift Int32++deriving via (DefaultFiniteBitsSymShift Int64) instance SymShift Int64++deriving via (DefaultFiniteBitsSymShift Word8) instance SymShift Word8++deriving via (DefaultFiniteBitsSymShift Word16) instance SymShift Word16++deriving via (DefaultFiniteBitsSymShift Word32) instance SymShift Word32++deriving via (DefaultFiniteBitsSymShift Word64) instance SymShift Word64++deriving via (DefaultFiniteBitsSymShift Word) instance SymShift Word
+ src/Grisette/Internal/Core/Data/Class/ToCon.hs view
@@ -0,0 +1,28 @@+{-# OPTIONS_GHC -Wno-missing-import-lists #-}++-- |+-- Module      :   Grisette.Internal.Core.Data.Class.ToCon+-- 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.ToCon+  ( -- * Converting to concrete values+    ToCon (..),+    ToCon1 (..),+    toCon1,+    ToCon2 (..),+    toCon2,++    -- * Generic 'ToCon'+    ToConArgs (..),+    GToCon (..),+    genericToCon,+    genericLiftToCon,+  )+where++import Grisette.Internal.Internal.Decl.Core.Data.Class.ToCon+import Grisette.Internal.Internal.Impl.Core.Data.Class.ToCon ()
+ src/Grisette/Internal/Core/Data/Class/ToSym.hs view
@@ -0,0 +1,28 @@+{-# OPTIONS_GHC -Wno-missing-import-lists #-}++-- |+-- Module      :   Grisette.Internal.Core.Data.Class.ToSym+-- 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.ToSym+  ( -- * Converting to symbolic values+    ToSym (..),+    ToSym1 (..),+    toSym1,+    ToSym2 (..),+    toSym2,++    -- * Generic 'ToSym'+    ToSymArgs (..),+    GToSym (..),+    genericToSym,+    genericLiftToSym,+  )+where++import Grisette.Internal.Internal.Decl.Core.Data.Class.ToSym+import Grisette.Internal.Internal.Impl.Core.Data.Class.ToSym ()
+ src/Grisette/Internal/Core/Data/Class/TryMerge.hs view
@@ -0,0 +1,23 @@+{-# OPTIONS_GHC -Wno-missing-import-lists #-}++-- |+-- Module      :   Grisette.Internal.Core.Data.Class.TryMerge+-- 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.TryMerge+  ( TryMerge (..),+    tryMerge,+    MonadTryMerge,+    mrgSingle,+    mrgSingleWithStrategy,+    mrgToSym,+    toUnionSym,+  )+where++import Grisette.Internal.Internal.Decl.Core.Data.Class.TryMerge+import Grisette.Internal.Internal.Impl.Core.Data.Class.TryMerge ()
+ src/Grisette/Internal/Core/Data/Class/UnionView.hs view
@@ -0,0 +1,295 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}++-- |+-- Module      :   Grisette.Internal.Core.Data.Class.UnionView+-- 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.UnionView+  ( UnionView (..),+    IfViewResult (..),+    pattern Single,+    pattern If,+    simpleMerge,+    symIteMerge,+    (.#),+    onUnion,+    onUnion2,+    onUnion3,+    onUnion4,+    unionToCon,+    liftUnion,+    liftToMonadUnion,+  )+where++import Control.Monad.Identity (Identity (runIdentity))+import Data.Bifunctor (Bifunctor (first))+import Data.Kind (Type)+import Grisette.Internal.Core.Data.Class.AsKey (AsKey1 (AsKey1))+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 (symNot, (.&&)),+  )+import Grisette.Internal.Core.Data.Class.Solvable (Solvable (con))+import Grisette.Internal.Internal.Decl.Core.Data.Class.Mergeable+  ( Mergeable,+  )+import Grisette.Internal.Internal.Decl.Core.Data.Class.SimpleMergeable+  ( SimpleMergeable,+    SymBranching,+    mrgIf,+  )+import Grisette.Internal.Internal.Decl.Core.Data.Class.ToCon (ToCon (toCon))+import Grisette.Internal.Internal.Decl.Core.Data.Class.TryMerge+  ( TryMerge,+    mrgSingle,+    tryMerge,+  )+import Grisette.Internal.SymPrim.SymBool (SymBool)++-- $setup+-- >>> import Grisette.Core+-- >>> import Grisette.SymPrim++-- | The result of 'ifView'.+data IfViewResult u a where+  IfViewResult :: (SymBranching u) => SymBool -> u a -> u a -> IfViewResult u a++instance (Show (u a)) => Show (IfViewResult u a) where+  showsPrec d (IfViewResult c l r) =+    showParen (d > 10) $+      showString "IfViewResult "+        . showsPrec 11 c+        . showString " "+        . showsPrec 11 l+        . showString " "+        . showsPrec 11 r++-- | Containers that can be projected back into single value or if-guarded+-- values. 'Identity' is an instance of this class as we can always project to+-- single value.+class (Applicative u, TryMerge u) => UnionView (u :: Type -> Type) where+  -- | Pattern match to extract single values.+  --+  -- >>> singleView (return 1 :: Union Integer)+  -- Just 1+  -- >>> singleView (mrgIfPropagatedStrategy "a" (return 1) (return 2) :: Union Integer)+  -- Nothing+  singleView :: u a -> Maybe a++  -- | Pattern match to extract if values.+  --+  -- >>> ifView (return 1 :: Union Integer)+  -- Nothing+  -- >>> ifView (mrgIfPropagatedStrategy "a" (return 1) (return 2) :: Union Integer)+  -- Just (IfViewResult a <1> <2>)+  -- >>> ifView (mrgIf "a" (return 1) (return 2) :: Union Integer)+  -- Just (IfViewResult a {1} {2})+  ifView :: u a -> Maybe (IfViewResult u a)++  -- | Convert the union to a guarded list.+  --+  -- >>> 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 =+    case (singleView u, ifView u) of+      (Just x, _) -> [(con True, x)]+      (_, Just (IfViewResult c l r)) ->+        fmap (first (.&& c)) (toGuardedList l)+          ++ fmap (first (.&& symNot c)) (toGuardedList r)+      _ -> error "Should not happen"++  -- | Return all possible values in the union. Drop the path conditions.+  --+  -- >>> overestimateUnionValues (return 1 :: Union Integer)+  -- [1]+  --+  -- >>> overestimateUnionValues (mrgIf "a" (return 1) (return 2) :: Union Integer)+  -- [1,2]+  overestimateUnionValues :: (Mergeable a) => u a -> [a]+  overestimateUnionValues (Single v) = [v]+  overestimateUnionValues (If _ l r) =+    overestimateUnionValues l ++ overestimateUnionValues r++instance UnionView Identity where+  singleView = Just . runIdentity+  ifView _ = Nothing++-- | Pattern match to extract single values with 'singleView'.+--+-- >>> case (return 1 :: Union Integer) of Single v -> v+-- 1+pattern Single :: (UnionView u, Mergeable a) => a -> u a+pattern Single x <-+  (singleView -> Just x)+  where+    Single x = mrgSingle x++-- | Pattern match to extract guard values with 'ifView'+--+-- >>> case (mrgIfPropagatedStrategy "a" (return 1) (return 2) :: Union Integer) of If c t f -> (c,t,f)+-- (a,<1>,<2>)+pattern If :: (UnionView u, Mergeable a) => (SymBranching u) => SymBool -> u a -> u a -> u a+pattern If c t f <-+  (ifView -> Just (IfViewResult c t f))+  where+    If c t f = mrgIf c t f++#if MIN_VERSION_base(4, 16, 4)+{-# COMPLETE Single, If #-}+#endif++-- | Merge the simply mergeable values in a union, and extract the 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") :: Union SymBool+-- <If a b c>+-- >>> simpleMerge $ (mrgIfPropagatedStrategy (ssym "a") (return $ ssym "b") (return $ ssym "c") :: Union SymBool)+-- (ite a b c)+simpleMerge :: forall u a. (SimpleMergeable a, UnionView u) => u a -> a+simpleMerge u = case tryMerge u of+  Single x -> x+  _ -> error "Should not happen"+{-# INLINE simpleMerge #-}++-- | Merge the mergeable values in a union, using `symIte`, and extract the+-- merged value.+--+-- The reason why we provide this class is that for some types, we only have+-- `ITEOp` (which may throw an error), and we don't have a `SimpleMergeable`+-- instance. In this case, we can use `symIteMerge` to merge the values.+symIteMerge :: (ITEOp a, Mergeable a, UnionView u) => u a -> a+symIteMerge (Single x) = x+symIteMerge (If cond l r) = symIte cond (symIteMerge l) (symIteMerge r)+{-# INLINE symIteMerge #-}++-- | Helper for applying functions on 'UnionView' and 'SimpleMergeable'.+--+-- >>> 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, UnionView u) =>+  f ->+  u a ->+  r+(.#) f u = simpleMerge $ fmap (f #) u+{-# INLINE (.#) #-}++infixl 9 .#++-- | Lift a function to work on union values.+--+-- >>> 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, SymBranching u, UnionView u, Mergeable a) =>+  (a -> r) ->+  (u a -> r)+onUnion f = simpleMerge . fmap f . tryMerge++-- | Lift a function to work on union values.+onUnion2 ::+  forall u a b r.+  ( SimpleMergeable r,+    SymBranching u,+    UnionView u,+    Mergeable a,+    Mergeable b+  ) =>+  (a -> b -> r) ->+  (u a -> u b -> r)+onUnion2 f ua ub = simpleMerge $ f <$> tryMerge ua <*> tryMerge ub++-- | Lift a function to work on union values.+onUnion3 ::+  forall u a b c r.+  ( SimpleMergeable r,+    SymBranching u,+    UnionView u,+    Mergeable a,+    Mergeable b,+    Mergeable c+  ) =>+  (a -> b -> c -> r) ->+  (u a -> u b -> u c -> r)+onUnion3 f ua ub uc =+  simpleMerge $ f <$> tryMerge ua <*> tryMerge ub <*> tryMerge uc++-- | Lift a function to work on union values.+onUnion4 ::+  forall u a b c d r.+  ( SimpleMergeable r,+    SymBranching u,+    UnionView u,+    Mergeable a,+    Mergeable b,+    Mergeable c,+    Mergeable d+  ) =>+  (a -> b -> c -> d -> r) ->+  (u a -> u b -> u c -> u d -> r)+onUnion4 f ua ub uc ud =+  simpleMerge $+    f <$> tryMerge ua <*> tryMerge ub <*> tryMerge uc <*> tryMerge ud++-- | Convert a plain union to concrete values.+--+-- >>> unionToCon (return 1 :: Union SymInteger) :: Maybe Integer+-- Just 1+-- >>> unionToCon (mrgIf "a" (return 1) (return 2) :: Union SymInteger) :: Maybe Integer+-- Nothing+-- >>> unionToCon (return "a" :: Union SymInteger) :: Maybe Integer+-- Nothing+unionToCon :: (ToCon a b, UnionView u) => u a -> Maybe b+unionToCon u =+  case (singleView u, ifView u) of+    (Just x, _) -> toCon x+    (_, Just (IfViewResult c l r)) -> do+      cl <- toCon c+      if cl then unionToCon l else unionToCon r+    _ -> Nothing+{-# INLINE unionToCon #-}++-- | Lift the 'UnionView' value to any Applicative 'SymBranching'.+liftUnion ::+  (Mergeable a, UnionView u, Applicative m, SymBranching m) => u a -> m a+liftUnion u = case u of+  Single x -> mrgSingle x+  If c l r -> mrgIf c (liftUnion l) (liftUnion r)++-- | Alias for 'liftUnion', but for monads.+liftToMonadUnion ::+  (Mergeable a, UnionView u, Monad m, SymBranching m) => u a -> m a+liftToMonadUnion = liftUnion++#if MIN_VERSION_base(4,16,0)+instance (UnionView u) => UnionView (AsKey1 u) where+  singleView (AsKey1 u) = singleView u+  ifView (AsKey1 u) = case ifView u of+    Just (IfViewResult c l r) -> Just (IfViewResult c (AsKey1 l) (AsKey1 r))+    Nothing -> Nothing+  toGuardedList (AsKey1 u) = toGuardedList u+  overestimateUnionValues (AsKey1 u) = overestimateUnionValues u+#endif
+ src/Grisette/Internal/Core/Data/MemoUtils.hs view
@@ -0,0 +1,205 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++-- |+-- Module      :   Grisette.Internal.Core.Data.MemoUtils+-- 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.MemoUtils+  ( -- * Memoization+    stableMemo,+    stableMemo2,+    stableMemo3,+    stableMup,+    stableMemoFix,+    weakStableMemo,+    weakStableMemo2,+    weakStableMemo3,+    weakStableMup,+    weakStableMemoFix,+    htmemo,+    htmemo2,+    htmemo3,+    htmemoFix,+    htmup,+  )+where++import Control.Applicative (Const (Const, getConst))+import Control.Monad.Fix (fix)+import Data.Atomics (atomicModifyIORefCAS_)+import qualified Data.HashMap.Strict as HM+import Data.Hashable (Hashable)+import Data.IORef (IORef, newIORef, readIORef)+import Data.Proxy (Proxy (Proxy))+import GHC.Base (Any, Type)+import System.IO.Unsafe (unsafePerformIO)+import System.Mem.StableName (StableName, makeStableName)+import System.Mem.Weak (Weak)+import qualified System.Mem.Weak as Weak+import Unsafe.Coerce (unsafeCoerce)++newtype (f <<< g) a = O {unO :: f (g a)}++-- Invariant: The type parameters for a key and its corresponding+-- value are the same.+type SNMap f g = IORef (HM.HashMap (StableName (f Any)) (g Any))++type MemoTable ref f g = SNMap f (ref <<< g)++class Ref ref where+  mkRef :: a -> b -> IO () -> IO (ref b)+  deRef :: ref a -> IO (Maybe a)+  finalize :: ref a -> IO ()+  tableFinalizer :: MemoTable ref f g -> IO ()+  tableFinalizer t = readIORef t >>= mapM_ (finalize . unO)++instance Ref Weak where+  mkRef x y = Weak.mkWeak x y . Just+  deRef = Weak.deRefWeak+  finalize = Weak.finalize++newtype Strong a = Strong a++instance Ref Strong where+  mkRef _ y _ = return $ Strong y+  deRef (Strong x) = return $ Just x+  finalize (Strong _) = return ()+  tableFinalizer _ = return ()++finalizer :: StableName (f Any) -> Weak (MemoTable ref f g) -> IO ()+finalizer sn weakTbl = do+  r <- Weak.deRefWeak weakTbl+  case r of+    Nothing -> return ()+    Just tbl -> do+      atomicModifyIORefCAS_ tbl $ HM.delete sn++unsafeToAny :: f a -> f Any+unsafeToAny = unsafeCoerce++unsafeFromAny :: f Any -> f a+unsafeFromAny = unsafeCoerce++{-# NOINLINE memo' #-}+memo' ::+  (Ref ref) =>+  Proxy ref ->+  (forall a. f a -> g a) ->+  MemoTable ref f g ->+  Weak (MemoTable ref f g) ->+  f b ->+  g b+memo' _ f tbl weakTbl !x = unsafePerformIO $ do+  sn <- makeStableName $ unsafeToAny x+  lkp <- HM.lookup sn <$> readIORef tbl+  case lkp of+    Nothing -> notFound sn+    Just (O w) -> do+      maybeVal <- deRef w+      case maybeVal of+        Nothing -> notFound sn+        Just val -> do+          return $ unsafeFromAny val+  where+    notFound sn = do+      let !y = f x+      weak <- mkRef x (unsafeToAny y) $ finalizer sn weakTbl+      atomicModifyIORefCAS_ tbl $ HM.insert sn $ O weak+      return y++{-# NOINLINE memo0 #-}+memo0 ::+  (Ref ref) =>+  Proxy (ref :: Type -> Type) ->+  (forall a. f a -> g a) ->+  f b ->+  g b+memo0 p f =+  let (tbl, weak) = unsafePerformIO $ do+        tbl' <- newIORef HM.empty+        weak' <- Weak.mkWeakPtr tbl . Just $ tableFinalizer tbl+        return (tbl', weak')+   in memo' p f tbl weak++-- | Memoize a unary function.+stableMemo :: (a -> b) -> (a -> b)+stableMemo f = getConst . memo0 (Proxy :: Proxy Strong) (Const . f . getConst) . Const++-- | Lift a memoizer to work with one more argument.+stableMup :: (b -> c) -> (a -> b) -> (a -> c)+stableMup mem f = stableMemo (mem . f)++-- | Curried memoization to share partial evaluation+stableMemo2 :: (a -> b -> c) -> (a -> b -> c)+stableMemo2 = stableMup stableMemo++-- | Curried memoization to share partial evaluation+stableMemo3 :: (a -> b -> c -> d) -> (a -> b -> c -> d)+stableMemo3 = stableMup stableMemo2++-- | Memoizing recursion. Use like 'fix'.+stableMemoFix :: ((a -> b) -> (a -> b)) -> a -> b+stableMemoFix h = fix (stableMemo . h)++-- | Memoize a unary function.+weakStableMemo :: (a -> b) -> (a -> b)+weakStableMemo f = getConst . memo0 (Proxy :: Proxy Weak) (Const . f . getConst) . Const++-- | Lift a memoizer to work with one more argument.+weakStableMup :: (b -> c) -> (a -> b) -> (a -> c)+weakStableMup mem f = weakStableMemo (mem . f)++-- | Curried memoization to share partial evaluation+weakStableMemo2 :: (a -> b -> c) -> (a -> b -> c)+weakStableMemo2 = weakStableMup weakStableMemo++-- | Curried memoization to share partial evaluation+weakStableMemo3 :: (a -> b -> c -> d) -> (a -> b -> c -> d)+weakStableMemo3 = weakStableMup weakStableMemo2++-- | Memoizing recursion. Use like 'fix'.+weakStableMemoFix :: ((a -> b) -> (a -> b)) -> a -> b+weakStableMemoFix h = fix (weakStableMemo . h)++-- | Function memoizer with mutable hash table.+{-# NOINLINE htmemo #-}+htmemo :: (Eq k, Hashable k) => (k -> a) -> k -> a+htmemo f = unsafePerformIO $ do+  cache <- newIORef HM.empty+  return $ \(!x) -> unsafePerformIO $ do+    tryV <- HM.lookup x <$> readIORef cache+    case tryV of+      Nothing -> do+        let !v = f x+        atomicModifyIORefCAS_ cache $ \old -> HM.insert x v old+        return v+      Just v -> return v++-- | Lift a memoizer to work with one more argument.+htmup :: (Eq k, Hashable k) => (b -> c) -> (k -> b) -> (k -> c)+htmup mem f = htmemo (mem . f)++-- | Function memoizer with mutable hash table. Works on binary functions.+htmemo2 :: (Eq k1, Hashable k1, Eq k2, Hashable k2) => (k1 -> k2 -> a) -> (k1 -> k2 -> a)+htmemo2 = htmup htmemo++-- | Function memoizer with mutable hash table. Works on ternary functions.+htmemo3 ::+  (Eq k1, Hashable k1, Eq k2, Hashable k2, Eq k3, Hashable k3) =>+  (k1 -> k2 -> k3 -> a) ->+  (k1 -> k2 -> k3 -> a)+htmemo3 = htmup htmemo2++-- | Memoizing recursion. Use like 'fix'.+htmemoFix :: (Eq k, Hashable k) => ((k -> a) -> (k -> a)) -> k -> a+htmemoFix h = fix (htmemo . h)
+ src/Grisette/Internal/Core/Data/SExpr.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Unused LANGUAGE pragma" #-}++-- |+-- Module      :   Grisette.Internal.Core.Data.SExpr+-- 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.SExpr+  ( SExpr (..),+    showsSExprWithParens,+    parseFileLocation,+    fileLocation,+  )+where++import Control.DeepSeq (NFData)+import qualified Data.Binary as Binary+import Data.Bytes.Serial (Serial (deserialize, serialize))+import Data.Hashable (Hashable)+import qualified Data.Serialize as Cereal+import Data.Serialize.Text ()+import qualified Data.Text as T+import Debug.Trace.LocationTH (__LOCATION__)+import GHC.Generics (Generic)+import Language.Haskell.TH.Syntax (Lift, unsafeTExpCoerce)+import Language.Haskell.TH.Syntax.Compat (SpliceQ, liftSplice)++-- | S-expression data type. Used for symbol metadata.+data SExpr = Atom T.Text | List [SExpr] | NumberAtom Integer | BoolAtom Bool+  deriving stock (Eq, Ord, Generic, Lift)+  deriving anyclass (Hashable, NFData, Serial)++instance Cereal.Serialize SExpr where+  put = serialize+  get = deserialize++instance Binary.Binary SExpr where+  put = serialize+  get = deserialize++instance Show SExpr where+  showsPrec _ = showsSExprWithParens '(' ')'++unwordsS :: [ShowS] -> ShowS+unwordsS [] = id+unwordsS [x] = x+unwordsS (x : xs) = x . showString " " . unwordsS xs++-- | Show an S-expression with specific parentheses.+showsSExprWithParens :: Char -> Char -> SExpr -> ShowS+showsSExprWithParens _ _ (Atom s) = showString $ T.unpack s+showsSExprWithParens lp rp (List l) =+  showString [lp] . unwordsS (map shows l) . (showString [rp])+showsSExprWithParens _ _ (NumberAtom n) = shows n+showsSExprWithParens _ _ (BoolAtom b) = showString $ if b then "#t" else "#f"++-- | Parse a file location string into an S-expression.+parseFileLocation :: String -> SExpr+parseFileLocation str =+  let r = reverse str+      (s2, r1) = break (== '-') r+      (s1, r2) = break (== ':') $ tail r1+      (l, p) = break (== ':') $ tail r2+   in List+        [ Atom "grisette-file-location",+          Atom $ T.pack $ reverse $ tail p,+          NumberAtom $ read $ reverse l,+          List+            [ NumberAtom $ read $ reverse s1,+              NumberAtom $ read $ reverse s2+            ]+        ]++-- | Get the file location of the splice.+fileLocation :: SpliceQ SExpr+fileLocation =+  [||parseFileLocation $$(liftSplice $ unsafeTExpCoerce __LOCATION__)||]
+ src/Grisette/Internal/Core/Data/Symbol.hs view
@@ -0,0 +1,222 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveLift #-}+{-# HLINT ignore "Unused LANGUAGE pragma" #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++-- |+-- Module      :   Grisette.Internal.Core.Data.Symbol+-- 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.Symbol+  ( Identifier (..),+    identifier,+    withMetadata,+    withLocation,+    mapMetadata,+    uniqueIdentifier,+    Symbol (..),+    simple,+    indexed,+    symbolIdentifier,+    mapIdentifier,+    AsMetadata (..),+    pattern Metadata,+  )+where++import Control.DeepSeq (NFData)+import qualified Data.Binary as Binary+import Data.Bytes.Serial (Serial (deserialize, serialize))+import Data.Hashable (Hashable (hashWithSalt))+import Data.IORef (IORef, atomicModifyIORef', newIORef)+import qualified Data.Serialize as Cereal+import Data.String (IsString (fromString))+import qualified Data.Text as T+import GHC.Generics (Generic)+import GHC.IO (unsafePerformIO)+import Grisette.Internal.Core.Data.SExpr+  ( SExpr (Atom, List, NumberAtom),+    fileLocation,+    showsSExprWithParens,+  )+import Language.Haskell.TH.Syntax (Lift)+import Language.Haskell.TH.Syntax.Compat (SpliceQ)++-- $setup+-- >>> import Grisette.Core+-- >>> import Grisette.SymPrim++-- | Identifier type used for 'Grisette.Core.GenSym'+--+-- The constructor is hidden intentionally.+-- You can construct an identifier by:+--+--   * a raw identifier+--+--     The following two expressions will refer to the same identifier (the+--     solver won't distinguish them and would assign the same value to them).+--     The user may need to use unique names to avoid unintentional identifier+--     collision.+--+--     >>> identifier "a"+--     a+--+--     >>> "a" :: Identifier -- available when OverloadedStrings is enabled+--     a+--+--   * bundle the identifier with some user provided metadata+--+--     Identifiers created with different name or different additional+--     information will not be the same.+--+--     >>> withMetadata "a" (NumberAtom 1)+--     a:1+--+--   * bundle the calling file location with the identifier to ensure global+--     uniqueness+--+--     Identifiers created at different locations will not be the+--     same. The identifiers created at the same location will be the same.+--+--     >>> $$(withLocation "a") -- a sample result could be "a:[grisette-file-location <interactive> 18 (4 18)]"+--     a:[grisette-file-location <interactive>...]+data Identifier = Identifier {baseIdent :: T.Text, metadata :: SExpr}+  deriving (Eq, Ord, Generic, Lift)+  deriving anyclass (Hashable, NFData, Serial)++instance Cereal.Serialize Identifier where+  put = serialize+  get = deserialize++instance Binary.Binary Identifier where+  put = serialize+  get = deserialize++instance Show Identifier where+  showsPrec _ (Identifier i (List [])) = showString (T.unpack i)+  showsPrec _ (Identifier i metadata) =+    showString (T.unpack i)+      . showString ":"+      . showsSExprWithParens '[' ']' metadata++instance IsString Identifier where+  fromString i = Identifier (T.pack i) $ List []++-- | A type class for embedding a type into a metadata represented as an+-- S-expression.+class AsMetadata a where+  asMetadata :: a -> SExpr+  fromMetadata :: SExpr -> Maybe a++-- | A pattern for extracting a value from a metadata represented as an+-- S-expression.+pattern Metadata :: (AsMetadata a) => a -> SExpr+pattern Metadata m <- (fromMetadata -> Just m)+  where+    Metadata m = asMetadata m++instance AsMetadata SExpr where+  asMetadata = id+  fromMetadata = Just++-- | Simple identifier.+-- The same identifier refers to the same symbolic variable in the whole+-- program.+--+-- The user may need to use unique identifiers to avoid unintentional identifier+-- collision.+identifier :: T.Text -> Identifier+identifier = flip Identifier $ List []++-- | Identifier with extra metadata.+--+-- The same identifier with the same metadata refers to the same symbolic+-- variable in the whole program.+--+-- The user may need to use unique identifiers or additional metadata to+-- avoid unintentional identifier collision.+withMetadata :: (AsMetadata a) => T.Text -> a -> Identifier+withMetadata ident meta = Identifier ident (asMetadata meta)++-- | Identifier with the file location.+withLocation :: T.Text -> SpliceQ Identifier+withLocation nm = [||withMetadata nm $$fileLocation||]++-- | Modify the metadata of an identifier.+mapMetadata ::+  (AsMetadata a) => (SExpr -> a) -> Identifier -> Identifier+mapMetadata f (Identifier i m) = Identifier i (asMetadata $ f m)++identifierCount :: IORef Int+identifierCount = unsafePerformIO $ newIORef 0+{-# NOINLINE identifierCount #-}++-- | Get a globally unique identifier within the 'IO' monad.+uniqueIdentifier :: T.Text -> IO Identifier+uniqueIdentifier ident = do+  i <- atomicModifyIORef' identifierCount (\x -> (x + 1, x))+  return $+    withMetadata+      ident+      (List [Atom "grisette-unique", NumberAtom $ toInteger i])++-- | Symbol types for a symbolic variable.+--+-- The symbols can be indexed with an integer.+data Symbol where+  SimpleSymbol :: Identifier -> Symbol+  IndexedSymbol :: Identifier -> Int -> Symbol+  deriving (Eq, Ord, Generic, Lift, NFData, Serial)++instance Cereal.Serialize Symbol where+  put = serialize+  get = deserialize++instance Binary.Binary Symbol where+  put = serialize+  get = deserialize++instance Hashable Symbol where+  hashWithSalt s (SimpleSymbol i) = hashWithSalt s i+  hashWithSalt s (IndexedSymbol i idx) = s `hashWithSalt` i `hashWithSalt` idx+  {-# INLINE hashWithSalt #-}++-- | Get the identifier of a symbol.+symbolIdentifier :: Symbol -> Identifier+symbolIdentifier (SimpleSymbol i) = i+symbolIdentifier (IndexedSymbol i _) = i++-- | Modify the identifier of a symbol.+mapIdentifier :: (Identifier -> Identifier) -> Symbol -> Symbol+mapIdentifier f (SimpleSymbol i) = SimpleSymbol (f i)+mapIdentifier f (IndexedSymbol i idx) = IndexedSymbol (f i) idx++instance Show Symbol where+  show (SimpleSymbol i) = show i+  show (IndexedSymbol i idx) = show i ++ "@" ++ show idx++instance IsString Symbol where+  fromString = SimpleSymbol . fromString++-- | Create a simple symbol.+simple :: Identifier -> Symbol+simple = SimpleSymbol++-- | Create an indexed symbol.+indexed :: Identifier -> Int -> Symbol+indexed = IndexedSymbol
+ src/Grisette/Internal/Core/Data/UnionBase.hs view
@@ -0,0 +1,26 @@+-- |+-- 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 Grisette.Internal.Internal.Decl.Core.Data.UnionBase+  ( UnionBase (UnionIf, UnionSingle),+    fullReconstruct,+    ifWithLeftMost,+    ifWithStrategy,+  )+import Grisette.Internal.Internal.Impl.Core.Data.UnionBase ()
− src/Grisette/Internal/IR/SymPrim.hs 
@@ -1,195 +0,0 @@-{-# LANGUAGE PatternSynonyms #-}--- Disable this warning because we are re-exporting things.-{-# OPTIONS_GHC -Wno-missing-import-lists #-}---- |--- Module      :   Grisette.Internal.IR.SymPrim--- 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.IR.SymPrim-  ( -- Sym (..),-    UnaryOp (..),-    BinaryOp (..),-    TernaryOp (..),-    Term (..),-    showUntyped,-    withSymbolSupported,-    SomeTypedSymbol (..),-    someTypedSymbol,-    evaluateTerm,-    introSupportedPrimConstraint,-    SomeTerm (..),-    SupportedPrim (..),-    castTerm,-    identity,-    identityWithTypeRep,-    pformat,-    constructUnary,-    constructBinary,-    constructTernary,-    conTerm,-    symTerm,-    ssymTerm,-    isymTerm,-    sinfosymTerm,-    iinfosymTerm,-    termSize,-    termsSize,-    extractSymbolicsTerm,-    trueTerm,-    falseTerm,-    pattern BoolConTerm,-    pattern TrueTerm,-    pattern FalseTerm,-    pattern BoolTerm,-    pevalNotTerm,-    pevalEqvTerm,-    pevalNotEqvTerm,-    pevalOrTerm,-    pevalAndTerm,-    pevalITETerm,-    pevalImplyTerm,-    pevalXorTerm,-    unaryUnfoldOnce,-    binaryUnfoldOnce,-    pattern UnaryTermPatt,-    pattern BinaryTermPatt,-    pattern TernaryTermPatt,-    PartialFun,-    PartialRuleUnary,-    TotalRuleUnary,-    PartialRuleBinary,-    TotalRuleBinary,-    totalize,-    totalize2,-    UnaryPartialStrategy (..),-    unaryPartial,-    BinaryCommPartialStrategy (..),-    BinaryPartialStrategy (..),-    binaryPartial,-    pattern NumConTerm,-    pattern NumOrdConTerm,-    pevalAddNumTerm,-    pevalMinusNumTerm,-    pevalUMinusNumTerm,-    pevalAbsNumTerm,-    pevalSignumNumTerm,-    pevalTimesNumTerm,-    pevalLtNumTerm,-    pevalLeNumTerm,-    pevalGtNumTerm,-    pevalGeNumTerm,-    pevalTabularFunApplyTerm,-    pevalGeneralFunApplyTerm,-    pevalDivIntegralTerm,-    pevalModIntegralTerm,-    pevalQuotIntegralTerm,-    pevalRemIntegralTerm,-  )-where--import Grisette.IR.SymPrim.Data.Prim.Helpers-  ( pattern BinaryTermPatt,-    pattern TernaryTermPatt,-    pattern UnaryTermPatt,-  )-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors-  ( conTerm,-    constructBinary,-    constructTernary,-    constructUnary,-    iinfosymTerm,-    isymTerm,-    sinfosymTerm,-    ssymTerm,-    symTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.SomeTerm-  ( SomeTerm (..),-  )-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term-  ( BinaryOp (..),-    SomeTypedSymbol (..),-    SupportedPrim (..),-    Term (..),-    TernaryOp (..),-    UnaryOp (..),-    showUntyped,-    someTypedSymbol,-    withSymbolSupported,-  )-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermUtils-  ( castTerm,-    extractSymbolicsTerm,-    identity,-    identityWithTypeRep,-    introSupportedPrimConstraint,-    pformat,-    termSize,-    termsSize,-  )-import Grisette.IR.SymPrim.Data.Prim.Model (evaluateTerm)-import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool-  ( falseTerm,-    pevalAndTerm,-    pevalEqvTerm,-    pevalITETerm,-    pevalImplyTerm,-    pevalNotEqvTerm,-    pevalNotTerm,-    pevalOrTerm,-    pevalXorTerm,-    trueTerm,-    pattern BoolConTerm,-    pattern BoolTerm,-    pattern FalseTerm,-    pattern TrueTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.PartialEval.GeneralFun-  ( pevalGeneralFunApplyTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.PartialEval.Integral-  ( pevalDivIntegralTerm,-    pevalModIntegralTerm,-    pevalQuotIntegralTerm,-    pevalRemIntegralTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.PartialEval.Num-  ( pevalAbsNumTerm,-    pevalAddNumTerm,-    pevalGeNumTerm,-    pevalGtNumTerm,-    pevalLeNumTerm,-    pevalLtNumTerm,-    pevalMinusNumTerm,-    pevalSignumNumTerm,-    pevalTimesNumTerm,-    pevalUMinusNumTerm,-    pattern NumConTerm,-    pattern NumOrdConTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.PartialEval.PartialEval-  ( BinaryCommPartialStrategy (..),-    BinaryPartialStrategy (..),-    PartialFun,-    PartialRuleBinary,-    PartialRuleUnary,-    TotalRuleBinary,-    TotalRuleUnary,-    UnaryPartialStrategy (..),-    binaryPartial,-    totalize,-    totalize2,-    unaryPartial,-  )-import Grisette.IR.SymPrim.Data.Prim.PartialEval.TabularFun-  ( pevalTabularFunApplyTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.PartialEval.Unfold-  ( binaryUnfoldOnce,-    unaryUnfoldOnce,-  )
+ src/Grisette/Internal/Internal/Decl/Core/Control/Monad/Union.hs view
@@ -0,0 +1,285 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Use <&>" #-}++-- |+-- Module      :   Grisette.Internal.Internal.Decl.Core.Control.Monad.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.Internal.Decl.Core.Control.Monad.Union+  ( -- * Union and helpers+    Union (..),+    UnionKey,+    pattern UAny,+    pattern UMrg,+  )+where++import Data.String (IsString (fromString))+import Grisette.Internal.Core.Data.Class.AsKey (AsKey1)+import Grisette.Internal.Core.Data.Class.Solvable+  ( Solvable (con, conView, sym),+    pattern Con,+  )+import Grisette.Internal.Core.Data.Class.UnionView+  ( IfViewResult (IfViewResult),+    UnionView (ifView, singleView, toGuardedList),+  )+import Grisette.Internal.Internal.Decl.Core.Data.Class.Mergeable+  ( Mergeable (rootStrategy, sortIndices),+    Mergeable1 (liftRootStrategy),+    MergingStrategy (SimpleStrategy),+    resolveStrategy,+    rootStrategy1,+  )+import Grisette.Internal.Internal.Decl.Core.Data.Class.SimpleMergeable+  ( SimpleMergeable (mrgIte),+    SimpleMergeable1 (liftMrgIte),+    SymBranching (mrgIfPropagatedStrategy, mrgIfWithStrategy),+    mrgIf,+  )+import Grisette.Internal.Internal.Decl.Core.Data.Class.TryMerge+  ( TryMerge (tryMergeWithStrategy),+    mrgSingle,+    tryMerge,+  )+import Grisette.Internal.Internal.Decl.Core.Data.UnionBase+  ( UnionBase (UnionIf, UnionSingle),+    ifWithLeftMost,+  )++-- $setup+-- >>> import Grisette.Core+-- >>> import Grisette.SymPrim++-- | t'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 t'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, t'Union' that+-- would try to cache the merging strategy.+-- The t'Union' has a data constructor (hidden intentionally) that maintains+-- an optional 'MergingStrategy' and a 'UnionBase'.+-- When the optional 'MergingStrategy' presents (printed as @{...}@), the+-- 'UnionBase' must have already been merged. When the optional+-- 'MergingStrategy' is absent (printed as @<...>@), the t'UnionBase' does not+-- guarantee to be merged.+-- When used in monadic context, Grisette would try to use this cached merging+-- strategy to merge the result, as the '>>=' operator itself cannot resolve the+-- 'Mergeable' constraint.+--+-- __/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+-- <If a 1 (If b 1 2)>+--+-- 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 = Union+  { unionMergingStrategy :: Maybe (MergingStrategy a),+    unionBase :: UnionBase a+  }++-- | 'Union' with identity equality.+type UnionKey = AsKey1 Union++-- | Pattern synonym for Union with no MergingStrategy (backwards compatibility)+pattern UAny :: UnionBase a -> Union a+pattern UAny u <- Union Nothing u+  where+    UAny u = Union Nothing u++-- | Pattern synonym for Union with MergingStrategy (backwards compatibility)+pattern UMrg :: MergingStrategy a -> UnionBase a -> Union a+pattern UMrg s u <- Union (Just s) u+  where+    UMrg s u = Union (Just s) u++#if MIN_VERSION_base(4, 16, 4)+{-# COMPLETE UAny, UMrg #-}+#endif++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 (>>=) #-}++instance TryMerge Union where+  tryMergeWithStrategy _ m@(Union Just {} _) = m+  tryMergeWithStrategy s (Union Nothing u) =+    Union (Just s) $ tryMergeWithStrategy s u+  {-# INLINE tryMergeWithStrategy #-}++instance (IsString a, Mergeable a) => IsString (Union a) where+  fromString = mrgSingle . fromString++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 (Mergeable a) => Mergeable (Union a) where+  rootStrategy = rootStrategy1+  {-# INLINE rootStrategy #-}+  sortIndices = fst . resolveStrategy rootStrategy . snd . head . toGuardedList++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 SymBranching Union where+  mrgIfWithStrategy s (Con c) l r =+    if c then tryMergeWithStrategy s l else tryMergeWithStrategy s r+  mrgIfWithStrategy s cond l r =+    Union (Just s) $+      mrgIfWithStrategy+        s+        cond+        (unionBase l)+        (unionBase r)+  {-# INLINE mrgIfWithStrategy #-}+  mrgIfPropagatedStrategy cond (Union Nothing t) (Union Nothing f) =+    Union Nothing $ ifWithLeftMost False cond t f+  mrgIfPropagatedStrategy cond t@(Union (Just m) _) f = mrgIfWithStrategy m cond t f+  mrgIfPropagatedStrategy cond t f@(Union (Just m) _) = mrgIfWithStrategy m cond t f+  {-# INLINE mrgIfPropagatedStrategy #-}++instance UnionView Union where+  singleView = singleView . unionBase+  {-# INLINE singleView #-}+  ifView (Union Nothing u) = case ifView u of+    Just (IfViewResult c t f) ->+      Just (IfViewResult c (Union Nothing t) (Union Nothing f))+    Nothing -> Nothing+  ifView (Union (Just m) u) = case ifView u of+    Just (IfViewResult c t f) ->+      Just (IfViewResult c (Union (Just m) t) (Union (Just m) f))+    Nothing -> Nothing+  {-# INLINE ifView #-}
+ src/Grisette/Internal/Internal/Decl/Core/Data/Class/EvalSym.hs view
@@ -0,0 +1,269 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.Internal.Decl.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.Internal.Decl.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 Data.Kind (Type)+import Data.Maybe (fromJust)+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.Internal.Decl.Core.Data.Class.ToCon+  ( ToCon (toCon),+    ToCon1,+    ToCon2,+    toCon1,+    toCon2,+  )+import Grisette.Internal.SymPrim.Prim.Model (Model)+import Grisette.Internal.Utils.Derive (Arity0, Arity1)++-- $setup+-- >>> import Grisette.Core+-- >>> import Grisette.SymPrim+-- >>> import Data.Proxy++-- | 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 #-}
+ src/Grisette/Internal/Internal/Decl/Core/Data/Class/ExtractSym.hs view
@@ -0,0 +1,250 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.Internal.Decl.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.Internal.Decl.Core.Data.Class.ExtractSym+  ( -- * Extracting symbolic constant set from a value+    ExtractSym (..),+    ExtractSym1 (..),+    extractSymMaybe1,+    extractSym1,+    ExtractSym2 (..),+    extractSymMaybe2,+    extractSym2,++    -- * Generic 'ExtractSym'+    ExtractSymArgs (..),+    GExtractSym (..),+    genericExtractSymMaybe,+    genericLiftExtractSymMaybe,+  )+where++import Data.Kind (Type)+import Data.Maybe (fromJust)+import Generics.Deriving+  ( Default (unDefault),+    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.SymPrim.Prim.Model+  ( AnySymbolSet,+    SymbolSet,+  )+import Grisette.Internal.SymPrim.Prim.Term (IsSymbolKind, SymbolKind)+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 {a :: Bool}+--+-- >>> extractSym (mrgIf "a" (mrgReturn ["b"]) (mrgReturn ["c", "d"]) :: Union [SymBool])+-- 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 -> AnySymbolSet+  extractSym = fromJust . extractSymMaybe+  {-# INLINE extractSym #-}+  extractSymMaybe :: (IsSymbolKind knd) => a -> Maybe (SymbolSet knd)++-- | Lifting of 'ExtractSym' to unary type constructors.+class+  (forall a. (ExtractSym a) => ExtractSym (f a)) =>+  ExtractSym1 f+  where+  -- | Lifts the 'extractSymMaybe' function to unary type constructors.+  liftExtractSymMaybe ::+    (IsSymbolKind knd) =>+    (a -> Maybe (SymbolSet knd)) ->+    f a ->+    Maybe (SymbolSet knd)++-- | Lift the standard 'extractSym' to unary type constructors.+extractSym1 ::+  (ExtractSym1 f, ExtractSym a, IsSymbolKind knd) =>+  f a ->+  SymbolSet knd+extractSym1 = fromJust . liftExtractSymMaybe extractSymMaybe+{-# INLINE extractSym1 #-}++-- | Lift the standard 'extractSymMaybe' to unary type constructors.+extractSymMaybe1 ::+  (ExtractSym1 f, ExtractSym a, IsSymbolKind knd) =>+  f a ->+  Maybe (SymbolSet knd)+extractSymMaybe1 = liftExtractSymMaybe extractSymMaybe+{-# INLINE extractSymMaybe1 #-}++-- | Lifting of 'ExtractSym' to binary type constructors.+class+  (forall a. (ExtractSym a) => ExtractSym1 (f a)) =>+  ExtractSym2 f+  where+  -- | Lifts the 'extractSymMaybe' function to binary type constructors.+  liftExtractSymMaybe2 ::+    (IsSymbolKind knd) =>+    (a -> Maybe (SymbolSet knd)) ->+    (b -> Maybe (SymbolSet knd)) ->+    f a b ->+    Maybe (SymbolSet knd)++-- | Lift the standard 'extractSym' to binary type constructors.+extractSym2 ::+  (ExtractSym2 f, ExtractSym a, ExtractSym b, IsSymbolKind knd) =>+  f a b ->+  SymbolSet knd+extractSym2 = fromJust . liftExtractSymMaybe2 extractSymMaybe extractSymMaybe++-- | Lift the standard 'extractSymMaybe' to binary type constructors.+extractSymMaybe2 ::+  (ExtractSym2 f, ExtractSym a, ExtractSym b, IsSymbolKind knd) =>+  f a b ->+  Maybe (SymbolSet knd)+extractSymMaybe2 = liftExtractSymMaybe2 extractSymMaybe extractSymMaybe+{-# INLINE extractSymMaybe2 #-}++-- Derivations++-- | The arguments to the generic 'extractSym' function.+data family ExtractSymArgs arity (knd :: SymbolKind) a :: Type++data instance ExtractSymArgs Arity0 _ _ = ExtractSymArgs0++newtype instance ExtractSymArgs Arity1 knd a+  = ExtractSymArgs1 (a -> Maybe (SymbolSet knd))++-- | The class of types that can generically extract the symbols.+class GExtractSym arity f where+  gextractSymMaybe ::+    (IsSymbolKind knd) =>+    ExtractSymArgs arity knd a ->+    f a ->+    Maybe (SymbolSet knd)++instance GExtractSym arity V1 where+  gextractSymMaybe _ _ = Just mempty+  {-# INLINE gextractSymMaybe #-}++instance GExtractSym arity U1 where+  gextractSymMaybe _ _ = Just mempty+  {-# INLINE gextractSymMaybe #-}++instance (GExtractSym arity a) => GExtractSym arity (M1 i c a) where+  gextractSymMaybe args (M1 x) = gextractSymMaybe args x+  {-# INLINE gextractSymMaybe #-}++instance (ExtractSym a) => GExtractSym arity (K1 i a) where+  gextractSymMaybe _ (K1 x) = extractSymMaybe x+  {-# INLINE gextractSymMaybe #-}++instance+  (GExtractSym arity a, GExtractSym arity b) =>+  GExtractSym arity (a :+: b)+  where+  gextractSymMaybe args (L1 x) = gextractSymMaybe args x+  gextractSymMaybe args (R1 x) = gextractSymMaybe args x+  {-# INLINE gextractSymMaybe #-}++instance+  (GExtractSym arity a, GExtractSym arity b) =>+  GExtractSym arity (a :*: b)+  where+  gextractSymMaybe args (x :*: y) =+    gextractSymMaybe args x <> gextractSymMaybe args y+  {-# INLINE gextractSymMaybe #-}++instance GExtractSym Arity1 Par1 where+  gextractSymMaybe (ExtractSymArgs1 f) (Par1 x) = f x+  {-# INLINE gextractSymMaybe #-}++instance (ExtractSym1 a) => GExtractSym Arity1 (Rec1 a) where+  gextractSymMaybe (ExtractSymArgs1 f) (Rec1 x) =+    liftExtractSymMaybe f x+  {-# INLINE gextractSymMaybe #-}++instance+  (ExtractSym1 f, GExtractSym Arity1 g) =>+  GExtractSym Arity1 (f :.: g)+  where+  gextractSymMaybe targs (Comp1 x) =+    liftExtractSymMaybe (gextractSymMaybe targs) x+  {-# INLINE gextractSymMaybe #-}++-- | Generic 'extractSym' function.+genericExtractSymMaybe ::+  (Generic a, GExtractSym Arity0 (Rep a), IsSymbolKind knd) =>+  a ->+  Maybe (SymbolSet knd)+genericExtractSymMaybe = gextractSymMaybe ExtractSymArgs0 . from++-- | Generic 'liftExtractSymMaybe' function.+genericLiftExtractSymMaybe ::+  (Generic1 f, GExtractSym Arity1 (Rep1 f), IsSymbolKind knd) =>+  (a -> Maybe (SymbolSet knd)) ->+  f a ->+  Maybe (SymbolSet knd)+genericLiftExtractSymMaybe f =+  gextractSymMaybe (ExtractSymArgs1 f) . from1++instance+  (Generic a, GExtractSym Arity0 (Rep a)) =>+  ExtractSym (Default a)+  where+  extractSymMaybe = genericExtractSymMaybe . unDefault+  {-# INLINE extractSymMaybe #-}++instance+  (Generic1 f, GExtractSym Arity1 (Rep1 f), ExtractSym a) =>+  ExtractSym (Default1 f a)+  where+  extractSymMaybe = extractSymMaybe1+  {-# INLINE extractSymMaybe #-}++instance+  (Generic1 f, GExtractSym Arity1 (Rep1 f)) =>+  ExtractSym1 (Default1 f)+  where+  liftExtractSymMaybe f = genericLiftExtractSymMaybe f . unDefault1+  {-# INLINE liftExtractSymMaybe #-}
+ src/Grisette/Internal/Internal/Decl/Core/Data/Class/Mergeable.hs view
@@ -0,0 +1,547 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.Internal.Decl.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.Internal.Decl.Core.Data.Class.Mergeable+  ( -- * Merging strategy+    MergingStrategy (..),+    MergingIndex,++    -- * 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',+    resolveMergeable1,+  )+where++import Data.Functor.Classes+  ( Eq1,+    Ord1,+    compare1,+    eq1,+  )+import Data.Kind (Type)+import Data.Typeable+  ( Typeable,+    eqT,+    type (:~:) (Refl),+  )+import Generics.Deriving+  ( Default,+    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.Data.Class.AsKey (AsKey (AsKey, getAsKey), AsKey1 (AsKey1, getAsKey1))+import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp (symIte))+import Grisette.Internal.SymPrim.SymBool (SymBool)+import Grisette.Internal.Utils.Derive (Arity0, Arity1)+import Unsafe.Coerce (unsafeCoerce)++-- | For a type to be used as an index in a 'SortedStrategy', it must be both+-- 'Ord' and 'Typeable'.+type MergingIndex a = (Ord a, Typeable a)++-- | 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 ::+    (MergingIndex 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++  sortIndices :: a -> [DynamicSortedIdx]+  sortIndices = fst . resolveStrategy rootStrategy++-- | 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 #-}++-- | Workaround as GHC prior to 9.6 doesn't support quantified constraints+-- reliably.+--+-- Similar to https://github.com/haskell/core-libraries-committee/issues/10,+-- which is only available with 9.6 or higher.+resolveMergeable1 ::+  forall f a r. (Mergeable1 f, Mergeable a) => ((Mergeable (f a)) => r) -> r+resolveMergeable1 v = v++-- | 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. (MergingIndex 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 _) = "DynamicSortedIdx"++-- | 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' #-}++-- | 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 Mergeable SymBool where+  rootStrategy = SimpleStrategy symIte++instance Mergeable Ordering where+  rootStrategy =+    let sub = SimpleStrategy $ \_ t _ -> t+     in SortedStrategy id $ const sub++instance (Mergeable a) => Mergeable (AsKey a) where+  rootStrategy = wrapStrategy (rootStrategy @a) AsKey getAsKey+  {-# INLINE rootStrategy #-}++instance (Mergeable (f a)) => Mergeable (AsKey1 f a) where+  rootStrategy = wrapStrategy (rootStrategy @(f a)) AsKey1 getAsKey1+  {-# INLINE rootStrategy #-}++instance (Mergeable1 f) => Mergeable1 (AsKey1 f) where+  liftRootStrategy (s :: MergingStrategy a) =+    wrapStrategy (liftRootStrategy s) AsKey1 getAsKey1+  {-# INLINE liftRootStrategy #-}
+ src/Grisette/Internal/Internal/Decl/Core/Data/Class/PPrint.hs view
@@ -0,0 +1,481 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-missing-import-lists #-}++-- |+-- Module      :   Grisette.Internal.Internal.Decl.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.Internal.Decl.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,+    pformatListLike,+    prettyPrintTuple,+    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 Data.Kind (Type)+import Data.String (IsString (fromString))+import qualified Data.Text as T+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 Generics.Deriving (Default (unDefault), Default1 (unDefault1))+import Grisette.Internal.SymPrim.Prim.Internal.Term ()+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 #-}++-- | Pretty print a list of documents with left and right delimiters.+pformatListLike :: Doc ann -> Doc ann -> [Doc ann] -> Doc ann+pformatListLike ldelim rdelim l+  | null l = ldelim <> rdelim+  | length l == 1 =+      align $ group $ vcat [ldelim <> flatAlt " " "" <> head l, rdelim]+  | otherwise =+      groupedEnclose ldelim rdelim . align . vcat $+        ((\v -> v <> flatAlt "," ", ") <$> init l) ++ [last l]++prettyPrintList :: [Doc ann] -> Doc ann+prettyPrintList = pformatListLike "[" "]"++-- | Pretty print a tuple.+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 t'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 t'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) ->+    ([a] -> Doc ann) ->+    (Int -> b -> 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) ->+    ([a] -> Doc ann) ->+    (Int -> b -> 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 pformatList pformatPrec 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 pformatList pformatPrec 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
+ src/Grisette/Internal/Internal/Decl/Core/Data/Class/SafeDiv.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.Internal.Decl.Core.Data.Class.SafeDiv+-- 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.Internal.Decl.Core.Data.Class.SafeDiv+  ( ArithException (..),+    SafeDiv (..),+    DivOr (..),+    divOrZero,+    modOrDividend,+    quotOrZero,+    remOrDividend,+    divModOrZeroDividend,+    quotRemOrZeroDividend,+  )+where++import Control.Exception (ArithException (DivideByZero, Overflow, Underflow))+import Control.Monad.Except (MonadError)+import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable)+import Grisette.Internal.Core.Data.Class.TryMerge+  ( TryMerge,+    mrgSingle,+  )+import Grisette.Lib.Data.Functor (mrgFmap)++-- $setup+-- >>> import Grisette.Core+-- >>> import Grisette.SymPrim+-- >>> import Control.Monad.Except+-- >>> import Control.Exception++-- | Safe division handling with default values returned on exception.+class DivOr a where+  -- | Safe 'div' with default value returned on exception.+  --+  -- >>> divOr "d" "a" "b" :: SymInteger+  -- (ite (= b 0) d (div a b))+  divOr :: a -> a -> a -> a++  -- | Safe 'mod' with default value returned on exception.+  --+  -- >>> modOr "d" "a" "b" :: SymInteger+  -- (ite (= b 0) d (mod a b))+  modOr :: a -> a -> a -> a++  -- | Safe 'divMod' with default value returned on exception.+  --+  -- >>> divModOr ("d", "m") "a" "b" :: (SymInteger, SymInteger)+  -- ((ite (= b 0) d (div a b)),(ite (= b 0) m (mod a b)))+  divModOr :: (a, a) -> a -> a -> (a, a)++  -- | Safe 'quot' with default value returned on exception.+  quotOr :: a -> a -> a -> a++  -- | Safe 'rem' with default value returned on exception.+  remOr :: a -> a -> a -> a++  -- | Safe 'quotRem' with default value returned on exception.+  quotRemOr :: (a, a) -> a -> a -> (a, a)++-- | Safe 'div' with 0 returned on exception.+divOrZero :: (DivOr a, Num a) => a -> a -> a+divOrZero l = divOr (l - l) l+{-# INLINE divOrZero #-}++-- | Safe 'mod' with dividend returned on exception.+modOrDividend :: (DivOr a, Num a) => a -> a -> a+modOrDividend l = modOr l l+{-# INLINE modOrDividend #-}++-- | Safe 'quot' with 0 returned on exception.+quotOrZero :: (DivOr a, Num a) => a -> a -> a+quotOrZero l = quotOr (l - l) l+{-# INLINE quotOrZero #-}++-- | Safe 'rem' with dividend returned on exception.+remOrDividend :: (DivOr a, Num a) => a -> a -> a+remOrDividend l = remOr l l+{-# INLINE remOrDividend #-}++-- | Safe 'divMod' with 0 returned on exception.+divModOrZeroDividend :: (DivOr a, Num a) => a -> a -> (a, a)+divModOrZeroDividend l = divModOr (l - l, l) l+{-# INLINE divModOrZeroDividend #-}++-- | Safe 'quotRem' with 0 returned on exception.+quotRemOrZeroDividend :: (DivOr a, Num a) => a -> a -> (a, a)+quotRemOrZeroDividend l = quotRemOr (l - l, l) l+{-# INLINE quotRemOrZeroDividend #-}++-- | Safe division with monadic error handling in multi-path+-- execution. These procedures throw an exception when the+-- divisor is zero. The result should be able to handle errors with+-- `MonadError`.+class (MonadError e m, TryMerge m, Mergeable a, DivOr a) => SafeDiv e a m where+  -- | Safe 'div' with monadic error handling in multi-path execution.+  --+  -- >>> safeDiv "a" "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+  {-# INLINE safeDiv #-}++  -- | Safe 'mod' with monadic error handling in multi-path execution.+  --+  -- >>> safeMod "a" "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+  {-# INLINE safeMod #-}++  -- | Safe 'divMod' with monadic error handling in multi-path execution.+  --+  -- >>> safeDivMod "a" "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+    mrgSingle (d, m)+  {-# INLINE safeDivMod #-}++  -- | Safe 'quot' with monadic error handling in multi-path execution.+  safeQuot :: a -> a -> m a+  safeQuot l r = mrgFmap fst $ safeQuotRem l r+  {-# INLINE safeQuot #-}++  -- | Safe 'rem' with monadic error handling in multi-path execution.+  safeRem :: a -> a -> m a+  safeRem l r = mrgFmap snd $ safeQuotRem l r+  {-# INLINE safeRem #-}++  -- | Safe 'quotRem' with monadic error handling in multi-path execution.+  safeQuotRem :: a -> a -> m (a, a)+  safeQuotRem l r = do+    q <- safeQuot l r+    m <- safeRem l r+    mrgSingle (q, m)+  {-# INLINE safeQuotRem #-}++  {-# MINIMAL+    ((safeDiv, safeMod) | safeDivMod),+    ((safeQuot, safeRem) | safeQuotRem)+    #-}
+ src/Grisette/Internal/Internal/Decl/Core/Data/Class/SimpleMergeable.hs view
@@ -0,0 +1,336 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.Internal.Decl.Core.Data.Class.SimpleMergeable+-- 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.Internal.Decl.Core.Data.Class.SimpleMergeable+  ( -- * Simple mergeable types+    SimpleMergeable (..),+    SimpleMergeable1 (..),+    mrgIte1,+    SimpleMergeable2 (..),+    mrgIte2,++    -- * Generic 'SimpleMergeable'+    SimpleMergeableArgs (..),+    GSimpleMergeable (..),+    genericMrgIte,+    genericLiftMrgIte,++    -- * Symbolic branching+    SymBranching (..),+    mrgIf,+    mergeWithStrategy,+    merge,+  )+where++import Data.Kind (Type)+import GHC.Generics+  ( Generic (Rep, from, to),+    Generic1 (Rep1, from1, to1),+    K1 (K1),+    M1 (M1),+    Par1 (Par1),+    Rec1 (Rec1),+    U1,+    V1,+    (:.:) (Comp1),+    type (:*:) ((:*:)),+  )+import Generics.Deriving (Default (Default), Default1 (Default1))+import Grisette.Internal.Core.Data.Class.AsKey (AsKey (AsKey), AsKey1 (AsKey1))+import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp (symIte))+import Grisette.Internal.Internal.Decl.Core.Data.Class.Mergeable+  ( GMergeable,+    Mergeable (rootStrategy),+    Mergeable1,+    Mergeable2,+    MergingStrategy,+  )+import Grisette.Internal.Internal.Decl.Core.Data.Class.TryMerge+  ( TryMerge (tryMergeWithStrategy),+  )+import Grisette.Internal.SymPrim.Prim.Internal.Term (SupportedPrim (pevalITETerm))+import Grisette.Internal.SymPrim.SymBool (SymBool (SymBool))+import Grisette.Internal.Utils.Derive (Arity0, Arity1)++-- $setup+-- >>> import Grisette.Core+-- >>> import Grisette.SymPrim+-- >>> import Control.Monad.Identity++-- | This class indicates that a type has a simple root merge strategy.+--+-- __Note:__ This type class can be derived for algebraic data types.+-- You may need the @DerivingVia@ and @DerivingStrategies@ extensions.+--+-- > data X = ...+-- >   deriving Generic+-- >   deriving (Mergeable, SimpleMergeable) via (Default X)+class (Mergeable a) => SimpleMergeable a where+  -- | Performs if-then-else with the simple root merge strategy.+  --+  -- >>> mrgIte "a" "b" "c" :: SymInteger+  -- (ite a b c)+  mrgIte :: SymBool -> a -> a -> a++-- | Lifting of the 'SimpleMergeable' class to unary type constructors.+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+  -- Identity (ite a b c)+  liftMrgIte :: (SymBool -> a -> a -> a) -> SymBool -> u a -> u a -> u a++-- | Lift the standard 'mrgIte' function through the type constructor.+--+-- >>> 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 = liftMrgIte mrgIte+{-# INLINE mrgIte1 #-}++-- | Lifting of the 'SimpleMergeable' class to binary type constructors.+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++-- | 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 = 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,+    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") :: 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.+  --+  -- 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++-- | 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 :: (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.+--+-- Equivalent to @'mrgIfWithStrategy' 'rootStrategy'@.+--+-- >>> mrgIf "a" (return "b") (return "c") :: Union SymInteger+-- {(ite a b c)}+mrgIf :: (SymBranching u, Mergeable a) => SymBool -> u a -> u a -> u a+mrgIf = mrgIfWithStrategy rootStrategy+{-# INLINE mrgIf #-}++instance SimpleMergeable SymBool where+  mrgIte (SymBool c) (SymBool t) (SymBool f) = SymBool $ pevalITETerm c t f+  {-# INLINE mrgIte #-}++instance {-# OVERLAPPABLE #-} (SimpleMergeable a) => ITEOp a where+  symIte = mrgIte+  {-# INLINE symIte #-}++instance (SimpleMergeable a) => SimpleMergeable (AsKey a) where+  mrgIte c (AsKey t) (AsKey f) = AsKey $ mrgIte c t f+  {-# INLINE mrgIte #-}++instance (SimpleMergeable (f a)) => SimpleMergeable (AsKey1 f a) where+  mrgIte c (AsKey1 t) (AsKey1 f) = AsKey1 $ mrgIte c t f+  {-# INLINE mrgIte #-}++instance+  (SimpleMergeable1 f) =>+  SimpleMergeable1 (AsKey1 f)+  where+  liftMrgIte m c (AsKey1 t) (AsKey1 f) = AsKey1 $ liftMrgIte m c t f+  {-# INLINE liftMrgIte #-}++#if MIN_VERSION_base(4,16,0)+instance (SymBranching f) => SymBranching (AsKey1 f) where+  mrgIfWithStrategy strategy cond (AsKey1 t) (AsKey1 f) =+    AsKey1 $ mrgIfWithStrategy strategy cond t f+  mrgIfPropagatedStrategy cond (AsKey1 t) (AsKey1 f) =+    AsKey1 $ mrgIfPropagatedStrategy cond t f+  {-# INLINE mrgIfWithStrategy #-}+  {-# INLINE mrgIfPropagatedStrategy #-}+#endif
+ src/Grisette/Internal/Internal/Decl/Core/Data/Class/Solver.hs view
@@ -0,0 +1,414 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.Internal.Decl.Core.Data.Class.Solver+-- 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.Internal.Decl.Core.Data.Class.Solver+  ( -- * Note for the examples++    --++    -- | The examples assumes that the [z3](https://github.com/Z3Prover/z3)+    -- solver is available in @PATH@.++    -- * Solver interfaces+    SolvingFailure (..),+    MonadicSolver (..),+    monadicSolverSolve,+    SolverCommand (..),+    ConfigurableSolver (..),+    Solver (..),+    solverSolve,+    withSolver,+    solve,+    solverSolveMulti,+    solveMulti,++    -- * Union with exceptions+    UnionWithExcept (..),+    solverSolveExcept,+    solveExcept,+    solverSolveMultiExcept,+    solveMultiExcept,+  )+where++import Control.DeepSeq (NFData)+import Control.Exception (mask, onException)+import Control.Monad.Except (ExceptT, runExceptT)+import qualified Data.HashSet as S+import Data.Hashable (Hashable)+import Data.Maybe (fromJust)+import qualified Data.Text as T+import GHC.Generics (Generic)+import Grisette.Internal.Core.Data.Class.ExtractSym+  ( ExtractSym (extractSym),+  )+import Grisette.Internal.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.||)))+import Grisette.Internal.Core.Data.Class.Solvable (Solvable (con))+import Grisette.Internal.Core.Data.Class.UnionView+  ( UnionView,+    simpleMerge,+  )+import Grisette.Internal.SymPrim.Prim.Model+  ( AnySymbolSet,+    Model,+    SymbolSet (unSymbolSet),+    equation,+  )+import Grisette.Internal.SymPrim.Prim.Term+  ( SomeTypedSymbol (SomeTypedSymbol),+  )+import Grisette.Internal.SymPrim.SymBool (SymBool (SymBool))+import Language.Haskell.TH.Syntax (Lift)++data SolveInternal = SolveInternal+  deriving (Eq, Show, Ord, Generic, Hashable, Lift, NFData)++-- $setup+-- >>> import Grisette+-- >>> import Grisette.Core+-- >>> import Grisette.SymPrim+-- >>> import Grisette.Backend++-- | The current failures that can be returned by the solver.+data SolvingFailure+  = -- | Unsatisfiable: No model is available.+    Unsat+  | -- | Unknown: The solver cannot determine whether the formula is+    -- satisfiable.+    Unk+  | -- | The solver has reached the maximum number of models to return.+    ResultNumLimitReached+  | -- | The solver has encountered an error.+    SolvingError T.Text+  | -- | The solver has been terminated.+    Terminated+  deriving (Lift)++-- | A monadic solver interface.+--+-- This interface abstract the monadic interface of a solver. All the operations+-- performed in the monad are using a single solver instance. The solver+-- instance is management by the monad's @run@ function.+class (Monad m) => MonadicSolver m where+  monadicSolverPush :: Int -> m ()+  monadicSolverPop :: Int -> m ()+  monadicSolverResetAssertions :: m ()+  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+  monadicSolverAssert formula+  monadicSolverCheckSat++-- | The commands that can be sent to a solver.+data SolverCommand+  = SolverAssert !SymBool+  | SolverCheckSat+  | SolverPush Int+  | SolverPop Int+  | SolverResetAssertions+  | SolverTerminate++-- | A class that abstracts the solver interface.+class Solver handle where+  -- | Run a solver command.+  solverRunCommand ::+    (handle -> IO (Either SolvingFailure a)) ->+    handle ->+    SolverCommand ->+    IO (Either SolvingFailure a)++  -- | Assert a formula.+  solverAssert :: handle -> SymBool -> IO (Either SolvingFailure ())+  solverAssert handle formula =+    solverRunCommand (const $ return $ Right ()) handle $ SolverAssert formula++  -- | Solve a formula.+  solverCheckSat :: handle -> IO (Either SolvingFailure Model)++  -- | Push @n@ levels.+  solverPush :: handle -> Int -> IO (Either SolvingFailure ())+  solverPush handle n =+    solverRunCommand (const $ return $ Right ()) handle $ SolverPush n++  -- | Pop @n@ levels.+  solverPop :: handle -> Int -> IO (Either SolvingFailure ())+  solverPop handle n =+    solverRunCommand (const $ return $ Right ()) handle $ SolverPop n++  -- | Reset all assertions in the solver.+  --+  -- The solver keeps all the assertions used in the previous commands:+  --+  -- >>> solver <- newSolver z3+  -- >>> solverSolve solver "a"+  -- Right (Model {a -> true :: Bool})+  -- >>> solverSolve solver $ symNot "a"+  -- Left Unsat+  --+  -- You can clear the assertions using @solverResetAssertions@:+  --+  -- >>> solverResetAssertions solver+  -- Right ()+  -- >>> solverSolve solver $ symNot "a"+  -- Right (Model {a -> false :: Bool})+  solverResetAssertions :: handle -> IO (Either SolvingFailure ())+  solverResetAssertions handle =+    solverRunCommand (const $ return $ Right ()) handle SolverResetAssertions++  -- | Terminate the solver, wait until the last command is finished.+  solverTerminate :: handle -> IO ()++  -- | 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+  res <- solverAssert solver formula+  case res of+    Left err -> return $ Left err+    Right _ -> solverCheckSat solver++-- | Solve a single formula while returning multiple models to make it true.+-- The maximum number of desired models are given.+solverSolveMulti ::+  (Solver handle) =>+  -- | solver handle+  handle ->+  -- | maximum number of models to return+  Int ->+  -- | formula to solve, the solver will try to make it true+  SymBool ->+  IO ([Model], SolvingFailure)+solverSolveMulti solver numOfModelRequested formula = do+  firstModel <- solverSolve solver formula+  case firstModel of+    Left err -> return ([], err)+    Right model -> do+      (models, err) <- go solver model numOfModelRequested+      return (model : models, err)+  where+    allSymbols = extractSym formula :: AnySymbolSet+    go solver prevModel n+      | n <= 1 = return ([], ResultNumLimitReached)+      | otherwise = do+          let newFormula =+                S.foldl'+                  ( \acc (SomeTypedSymbol v) ->+                      acc+                        .|| (symNot (SymBool $ fromJust $ equation v prevModel))+                  )+                  (con False)+                  (unSymbolSet allSymbols)+          res <- solverSolve solver newFormula+          case res of+            Left err -> return ([], err)+            Right model -> do+              (models, err) <- go solver model (n - 1)+              return (model : models, err)++-- |+-- Solver procedure for programs with error handling.+solverSolveExcept ::+  ( UnionWithExcept t u e v,+    UnionView u,+    Functor u,+    Solver handle+  ) =>+  -- | solver handle+  handle ->+  -- | mapping the results to symbolic boolean formulas, the solver would try to+  -- find a model to make the formula true+  (Either e v -> SymBool) ->+  -- | the program to be solved, should be a union of exception and values+  t ->+  IO (Either SolvingFailure Model)+solverSolveExcept solver f v =+  solverSolve solver (simpleMerge $ f <$> extractUnionExcept v)++-- |+-- Solver procedure for programs with error handling. Would return multiple+-- models if possible.+solverSolveMultiExcept ::+  ( UnionWithExcept t u e v,+    UnionView u,+    Functor u,+    Solver handle+  ) =>+  -- | solver configuration+  handle ->+  -- | maximum number of models to return+  Int ->+  -- | mapping the results to symbolic boolean formulas, the solver would try to+  -- find a model to make the formula true+  (Either e v -> SymBool) ->+  -- | the program to be solved, should be a union of exception and values+  t ->+  IO ([Model], SolvingFailure)+solverSolveMultiExcept handle n f v =+  solverSolveMulti handle n (simpleMerge $ f <$> extractUnionExcept v)++-- | A class that abstracts the creation of a solver instance based on a+-- configuration.+--+-- The solver instance will need to be terminated by the user, with the solver+-- interface.+class+  (Solver handle) =>+  ConfigurableSolver config handle+    | config -> handle+  where+  newSolver :: config -> IO handle++-- | Start a solver, run a computation with the solver, and terminate the+-- solver after the computation finishes.+--+-- When an exception happens, this will forcibly terminate the solver.+--+-- Note: if Grisette is compiled with sbv < 10.10, the solver likely won't be+-- really terminated until it has finished the last action, and this will+-- result in long-running or zombie solver instances.+--+-- This was due to a bug in sbv, which is fixed in+-- https://github.com/LeventErkok/sbv/pull/695.+withSolver ::+  (ConfigurableSolver config handle) =>+  config ->+  (handle -> IO a) ->+  IO a+withSolver config action =+  mask $ \restore -> do+    handle <- newSolver config+    r <- restore (action handle) `onException` solverForceTerminate handle+    solverTerminate handle+    return r++-- | Solve a single formula. Find an assignment to it to make it true.+--+-- >>> solve z3 ("a" .&& ("b" :: SymInteger) .== 1)+-- Right (Model {a -> true :: Bool, b -> 1 :: Integer})+-- >>> solve z3 ("a" .&& symNot "a")+-- Left Unsat+solve ::+  (ConfigurableSolver config handle) =>+  -- | solver configuration+  config ->+  -- | formula to solve, the solver will try to make it true+  SymBool ->+  IO (Either SolvingFailure Model)+solve config formula = withSolver config (`solverSolve` formula)++-- | Solve a single formula while returning multiple models to make it true.+-- The maximum number of desired models are given.+--+-- > >>> 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) =>+  -- | solver configuration+  config ->+  -- | maximum number of models to return+  Int ->+  -- | formula to solve, the solver will try to make it true+  SymBool ->+  IO ([Model], SolvingFailure)+solveMulti config numOfModelRequested formula =+  withSolver config $+    \solver -> solverSolveMulti solver numOfModelRequested formula++-- | A class that abstracts the union-like structures that contains exceptions.+class UnionWithExcept t u e v | t -> u e v where+  -- | Extract a union of exceptions and values from the structure.+  extractUnionExcept :: t -> u (Either e v)++instance UnionWithExcept (ExceptT e u v) u e v where+  extractUnionExcept = runExceptT++-- |+-- Solver procedure for programs with error handling.+--+-- >>> import Control.Monad.Except+-- >>> let x = "x" :: SymInteger+-- >>> :{+--   res :: ExceptT AssertionError Union ()+--   res = do+--     symAssert $ x .> 0       -- constrain that x is positive+--     symAssert $ x .< 2       -- constrain that x is less than 2+-- :}+--+-- >>> :{+--   translate (Left _) = con False -- errors are not desirable+--   translate _ = con True         -- non-errors are desirable+-- :}+--+-- >>> solveExcept z3 translate res+-- Right (Model {x -> 1 :: Integer})+solveExcept ::+  ( UnionWithExcept t u e v,+    UnionView u,+    Functor u,+    ConfigurableSolver config handle+  ) =>+  -- | solver configuration+  config ->+  -- | mapping the results to symbolic boolean formulas, the solver would try to+  -- find a model to make the formula true+  (Either e v -> SymBool) ->+  -- | the program to be solved, should be a union of exception and values+  t ->+  IO (Either SolvingFailure Model)+solveExcept config f v =+  withSolver config $+    \solver -> solverSolveExcept solver f v++-- |+-- Solver procedure for programs with error handling. Would return multiple+-- models if possible.+solveMultiExcept ::+  ( UnionWithExcept t u e v,+    UnionView u,+    Functor u,+    ConfigurableSolver config handle+  ) =>+  -- | solver configuration+  config ->+  -- | maximum number of models to return+  Int ->+  -- | mapping the results to symbolic boolean formulas, the solver would try to+  -- find a model to make the formula true+  (Either e v -> SymBool) ->+  -- | the program to be solved, should be a union of exception and values+  t ->+  IO ([Model], SolvingFailure)+solveMultiExcept config n f v =+  withSolver config $+    \solver -> solverSolveMultiExcept solver n f v
+ src/Grisette/Internal/Internal/Decl/Core/Data/Class/SubstSym.hs view
@@ -0,0 +1,245 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.Internal.Decl.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.Internal.Decl.Core.Data.Class.SubstSym+  ( -- * Substituting symbolic constants+    SubstSym (..),+    SubstSym1 (..),+    substSym1,+    SubstSym2 (..),+    substSym2,++    -- * Generic 'SubstSym'+    SubstSymArgs (..),+    GSubstSym (..),+    genericSubstSym,+    genericLiftSubstSym,+  )+where++import Data.Kind (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.SymPrim.Prim.Term+  ( IsSymbolKind,+    LinkedRep,+    SymbolKind,+    TypedSymbol,+  )+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" :: TypedAnySymbol 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, IsSymbolKind knd) =>+    TypedSymbol knd 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, IsSymbolKind knd) =>+    (TypedSymbol knd cb -> sb -> a -> a) ->+    TypedSymbol knd cb ->+    sb ->+    f a ->+    f a++-- | Lifting the standard 'substSym' to unary type constructors.+substSym1 ::+  (SubstSym1 f, SubstSym a, LinkedRep cb sb, IsSymbolKind knd) =>+  TypedSymbol knd 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, IsSymbolKind knd) =>+    (TypedSymbol knd cb -> sb -> a -> a) ->+    (TypedSymbol knd cb -> sb -> b -> b) ->+    TypedSymbol knd 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, IsSymbolKind knd) =>+  TypedSymbol knd cb ->+  sb ->+  f a b ->+  f a b+substSym2 = liftSubstSym2 substSym substSym++-- Derivations++-- | The arguments to the generic 'substSym' function.+data family SubstSymArgs arity (knd :: SymbolKind) a cb sb :: Type++data instance SubstSymArgs Arity0 _ _ _ _ = SubstSymArgs0++newtype instance SubstSymArgs Arity1 knd a cb sb+  = SubstSymArgs1 (TypedSymbol knd 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, IsSymbolKind knd) =>+    SubstSymArgs arity knd a cb sb ->+    TypedSymbol knd 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, IsSymbolKind knd) =>+  TypedSymbol knd 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, IsSymbolKind knd) =>+  (TypedSymbol knd cb -> sb -> a -> a) ->+  TypedSymbol knd 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 #-}
+ src/Grisette/Internal/Internal/Decl/Core/Data/Class/SymEq.hs view
@@ -0,0 +1,253 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.Internal.Decl.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.Internal.Decl.Core.Data.Class.SymEq+  ( -- * Symbolic equality+    SymEq (..),+    SymEq1 (..),+    symEq1,+    SymEq2 (..),+    symEq2,+    pairwiseSymDistinct,++    -- * More 'Eq' helper+    distinct,++    -- * Generic 'SymEq'+    SymEqArgs (..),+    GSymEq (..),+    genericSymEq,+    genericLiftSymEq,+  )+where++import Data.Kind (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.Data.Class.LogicalOp (LogicalOp (symNot, (.&&)))+import Grisette.Internal.Core.Data.Class.Solvable (Solvable (con))+import Grisette.Internal.SymPrim.SymBool (SymBool)+import Grisette.Internal.Utils.Derive (Arity0, Arity1)++-- | Check if all elements in a list are distinct.+--+-- Note that empty or singleton lists are always distinct.+--+-- >>> distinct []+-- True+-- >>> distinct [1]+-- True+-- >>> distinct [1, 2, 3]+-- True+-- >>> distinct [1, 2, 2]+-- False+distinct :: (Eq a) => [a] -> Bool+distinct [] = True+distinct [_] = True+distinct (x : xs) = go x xs && distinct xs+  where+    go _ [] = True+    go x' (y : ys) = x' /= y .&& go x' ys++-- $setup+-- >>> import Grisette.Core+-- >>> import Grisette.SymPrim++-- | 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 ./=++  -- | Check if all elements in a list are distinct, under the symbolic equality+  -- semantics.+  symDistinct :: [a] -> SymBool+  symDistinct = pairwiseSymDistinct++  {-# MINIMAL (.==) | (./=) #-}++-- | Default pairwise symbolic distinct implementation.+pairwiseSymDistinct :: (SymEq a) => [a] -> SymBool+pairwiseSymDistinct [] = con True+pairwiseSymDistinct [_] = con True+pairwiseSymDistinct (x : xs) = go x xs .&& pairwiseSymDistinct xs+  where+    go _ [] = con True+    go x' (y : ys) = x' ./= y .&& go x' ys++-- | 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 #-}
+ src/Grisette/Internal/Internal/Decl/Core/Data/Class/SymOrd.hs view
@@ -0,0 +1,327 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.Internal.Decl.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.Internal.Decl.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 Data.Kind (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.Data.Class.ITEOp (ITEOp, symIte)+import Grisette.Internal.Core.Data.Class.LogicalOp+  ( LogicalOp (symNot),+  )+import Grisette.Internal.Core.Data.Class.Solvable (Solvable (con))+import Grisette.Internal.Core.Data.Class.UnionView+  ( simpleMerge,+  )+import Grisette.Internal.Internal.Decl.Core.Control.Monad.Union (Union)+import Grisette.Internal.Internal.Decl.Core.Data.Class.Mergeable+  ( Mergeable,+  )+import Grisette.Internal.Internal.Decl.Core.Data.Class.SimpleMergeable+  ( SymBranching,+    mrgIf,+  )+import Grisette.Internal.Internal.Decl.Core.Data.Class.SymEq+  ( GSymEq,+    SymEq ((.==)),+    SymEq1,+    SymEq2,+  )+import Grisette.Internal.Internal.Decl.Core.Data.Class.TryMerge+  ( mrgSingle,+  )+import Grisette.Internal.SymPrim.SymBool (SymBool)+import Grisette.Internal.Utils.Derive (Arity0, Arity1)++-- $setup+-- >>> import Grisette.Core+-- >>> import Grisette.SymPrim++-- | 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 #-}
+ src/Grisette/Internal/Internal/Decl/Core/Data/Class/ToCon.hs view
@@ -0,0 +1,208 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.Internal.Decl.Core.Data.Class.ToCon+-- 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.Internal.Decl.Core.Data.Class.ToCon+  ( -- * Converting to concrete values+    ToCon (..),+    ToCon1 (..),+    toCon1,+    ToCon2 (..),+    toCon2,++    -- * Generic 'ToCon'+    ToConArgs (..),+    GToCon (..),+    genericToCon,+    genericLiftToCon,+  )+where++import Data.Kind (Type)+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 Generics.Deriving (Default (Default), Default1 (Default1))+import Generics.Deriving.Instances ()+import Grisette.Internal.Core.Data.Class.Solvable (Solvable (conView))+import Grisette.Internal.SymPrim.SymBool (SymBool)+import Grisette.Internal.Utils.Derive (Arity0, Arity1)++-- $setup+-- >>> import Grisette.Core+-- >>> import Grisette.SymPrim++-- | Convert a symbolic value to concrete value if possible.+class ToCon a b where+  -- | Convert a symbolic value to concrete value if possible.+  -- If the symbolic value cannot be converted to concrete, the result will be 'Nothing'.+  --+  -- >>> toCon (ssym "a" :: SymInteger) :: Maybe Integer+  -- Nothing+  --+  -- >>> toCon (con 1 :: SymInteger) :: Maybe Integer+  -- Just 1+  --+  -- 'toCon' works on complex types too.+  --+  -- >>> toCon ([con 1, con 2] :: [SymInteger]) :: Maybe [Integer]+  -- Just [1,2]+  --+  -- >>> toCon ([con 1, ssym "a"] :: [SymInteger]) :: Maybe [Integer]+  -- 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 #-}++instance ToCon SymBool Bool where+  toCon = conView
+ src/Grisette/Internal/Internal/Decl/Core/Data/Class/ToSym.hs view
@@ -0,0 +1,208 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.Internal.Decl.Core.Data.Class.ToSym+-- 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.Internal.Decl.Core.Data.Class.ToSym+  ( -- * Converting to symbolic values+    ToSym (..),+    ToSym1 (..),+    toSym1,+    ToSym2 (..),+    toSym2,++    -- * Generic 'ToSym'+    ToSymArgs (..),+    GToSym (..),+    genericToSym,+    genericLiftToSym,+  )+where++import Data.Kind (Type)+import Generics.Deriving+  ( Default (Default),+    Default1 (Default1),+    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 Grisette.Internal.Utils.Derive (Arity0, Arity1)++-- $setup+-- >>> import Grisette.SymPrim++-- | Convert a concrete value to symbolic value.+class ToSym a b where+  -- | Convert a concrete value to symbolic value.+  --+  -- >>> toSym False :: SymBool+  -- false+  --+  -- >>> toSym [False, True] :: [SymBool]+  -- [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++data instance ToSymArgs Arity1 _ _ where+  ToSymArgs1 :: (a -> b) -> ToSymArgs Arity1 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@ToSymArgs1 {} (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 #-}
+ src/Grisette/Internal/Internal/Decl/Core/Data/Class/TryMerge.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}++-- |+-- Module      :   Grisette.Internal.Internal.Decl.Core.Data.Class.TryMerge+-- 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.Internal.Decl.Core.Data.Class.TryMerge+  ( TryMerge (..),+    tryMerge,+    MonadTryMerge,+    mrgSingle,+    mrgSingleWithStrategy,+    mrgToSym,+    toUnionSym,+  )+where++import Control.Monad.Identity (Identity)+import Grisette.Internal.Core.Data.Class.AsKey (AsKey1 (AsKey1))+import Grisette.Internal.Internal.Decl.Core.Data.Class.Mergeable+  ( Mergeable (rootStrategy),+    MergingStrategy,+  )+import Grisette.Internal.Internal.Decl.Core.Data.Class.ToSym (ToSym (toSym))++-- $setup+-- >>> import Grisette.Core+-- >>> import Grisette.SymPrim++-- | A class for containers that may or may not be merged.+--+-- If the container is capable of multi-path execution, then the+-- `tryMergeWithStrategy` function should merge the paths according to the+-- supplied strategy.+--+-- If the container is not capable of multi-path execution, then the+-- `tryMergeWithStrategy` function should be equivalent to `id`.+--+-- Note that this will not necessarily do a recursive merge for the elements.+class TryMerge m where+  tryMergeWithStrategy :: MergingStrategy a -> m a -> m a++-- | Try to merge the container with the root strategy.+tryMerge :: (TryMerge m, Mergeable a) => m a -> m a+tryMerge = tryMergeWithStrategy rootStrategy+{-# INLINE tryMerge #-}++-- | Wrap a value in the applicative functor and capture the 'Mergeable'+-- knowledge.+--+-- >>> mrgSingleWithStrategy rootStrategy "a" :: Union SymInteger+-- {a}+--+-- __Note:__ Be careful to call this directly from 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.+--+-- 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+-- 'Grisette.Mergeable1'. In other cases,+-- 'Grisette.Lib.Control.Applicative.mrgPure' is usually a better alternative.+mrgSingleWithStrategy ::+  (TryMerge m, Applicative m) =>+  MergingStrategy a ->+  a ->+  m a+mrgSingleWithStrategy strategy = tryMergeWithStrategy strategy . pure+{-# INLINE mrgSingleWithStrategy #-}++-- | Wrap a value in the applicative functor and propagate the type's root merge+-- strategy.+--+-- Equivalent to @'mrgSingleWithStrategy' 'rootStrategy'@.+--+-- >>> mrgSingle "a" :: Union SymInteger+-- {a}+mrgSingle :: (TryMerge m, Applicative m, Mergeable a) => a -> m a+mrgSingle = mrgSingleWithStrategy rootStrategy+{-# INLINE mrgSingle #-}++-- | Alias for a monad type that has 'TryMerge'.+type MonadTryMerge f = (TryMerge f, Monad f)++-- | Convert a value to symbolic value and wrap it with a mergeable container.+--+-- This is a synonym for 'toUnionSym'.+mrgToSym ::+  (ToSym a b, Mergeable b, TryMerge m, Applicative m) =>+  a ->+  m b+mrgToSym = toUnionSym+{-# INLINE mrgToSym #-}++-- | Convert a value to symbolic value and wrap it with a mergeable container.+--+-- This is a synonym for 'toUnionSym'.+toUnionSym ::+  (ToSym a b, Mergeable b, TryMerge m, Applicative m) =>+  a ->+  m b+toUnionSym = tryMerge . pure . toSym+{-# INLINE toUnionSym #-}++instance (TryMerge m) => TryMerge (AsKey1 m) where+  tryMergeWithStrategy strategy (AsKey1 t) =+    AsKey1 $ tryMergeWithStrategy strategy t+  {-# INLINE tryMergeWithStrategy #-}++instance TryMerge Identity where+  tryMergeWithStrategy _ = id+  {-# INLINE tryMergeWithStrategy #-}
+ src/Grisette/Internal/Internal/Decl/Core/Data/UnionBase.hs view
@@ -0,0 +1,288 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeFamilies #-}++-- |+-- Module      :   Grisette.Internal.Internal.Decl.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.Internal.Decl.Core.Data.UnionBase+  ( -- * The union data structure.++    -- | Please consider using 'Grisette.Core.Union' instead.+    UnionBase (..),+    ifWithLeftMost,+    ifWithStrategy,+    fullReconstruct,+  )+where++import Control.Monad (ap)+import GHC.Generics (Generic, Generic1)+import Grisette.Internal.Core.Data.Class.AsKey (AsKey (AsKey), KeyEq (keyEq), KeyEq1 (liftKeyEq), shouldUseAsKeyHasSymbolicVersionError)+import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp (symIte))+import Grisette.Internal.Core.Data.Class.LogicalOp+  ( LogicalOp (symNot, (.&&), (.||)),+  )+import Grisette.Internal.Core.Data.Class.Solvable (pattern Con)+import Grisette.Internal.Core.Data.Class.UnionView+  ( IfViewResult (IfViewResult),+    UnionView (ifView, singleView),+  )+import Grisette.Internal.Internal.Decl.Core.Data.Class.Mergeable+  ( Mergeable (rootStrategy),+    Mergeable1 (liftRootStrategy),+    MergingStrategy (NoStrategy, SimpleStrategy, SortedStrategy),+  )+import Grisette.Internal.Internal.Decl.Core.Data.Class.SimpleMergeable+  ( SimpleMergeable (mrgIte),+    SimpleMergeable1 (liftMrgIte),+    SymBranching (mrgIfPropagatedStrategy, mrgIfWithStrategy),+    mrgIf,+  )+import Grisette.Internal.Internal.Decl.Core.Data.Class.TryMerge+  ( TryMerge (tryMergeWithStrategy),+  )+import Grisette.Internal.SymPrim.SymBool (SymBool)+import Language.Haskell.TH.Syntax (Lift)++-- | 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, Lift, Generic1)+  deriving (Functor)++instance (Eq a) => Eq (UnionBase a) where+  (==) = shouldUseAsKeyHasSymbolicVersionError "UnionBase" "(==)" "(.==)"++instance (Eq a) => KeyEq (UnionBase a) where+  keyEq = liftKeyEq (==)+  {-# INLINE keyEq #-}++instance KeyEq1 UnionBase where+  liftKeyEq f (UnionSingle l) (UnionSingle r) = f l r+  liftKeyEq f (UnionIf _ _ c l r) (UnionIf _ _ c' l' r') =+    keyEq c c' && liftKeyEq f l l' && liftKeyEq f r r'+  liftKeyEq _ _ _ = False+  {-# INLINE liftKeyEq #-}++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 TryMerge UnionBase where+  tryMergeWithStrategy = fullReconstruct+  {-# INLINE tryMergeWithStrategy #-}++-- | 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 #-}++leftMost :: UnionBase a -> a+leftMost (UnionSingle a) = a+leftMost (UnionIf a _ _ _ _) = a+{-# INLINE leftMost #-}++-- | 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 #-}++-- | 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+  | AsKey cond == AsKey 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)+  | AsKey cond == AsKey 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 #-}++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 SymBranching UnionBase where+  mrgIfWithStrategy = ifWithStrategy+  {-# INLINE mrgIfWithStrategy #-}++  mrgIfPropagatedStrategy = ifWithLeftMost False+  {-# INLINE mrgIfPropagatedStrategy #-}++instance UnionView UnionBase where+  singleView (UnionSingle a) = Just a+  singleView _ = Nothing+  {-# INLINE singleView #-}+  ifView (UnionIf _ _ cond ifTrue ifFalse) =+    Just (IfViewResult cond ifTrue ifFalse)+  ifView _ = Nothing+  {-# INLINE ifView #-}
+ src/Grisette/Internal/Internal/Decl/SymPrim/AllSyms.hs view
@@ -0,0 +1,269 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.Internal.Decl.SymPrim.AllSyms+-- 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.Internal.Decl.SymPrim.AllSyms+  ( -- * Get all symbolic primitive values in a value+    SomeSym (..),+    AllSyms (..),+    AllSyms1 (..),+    allSymsS1,+    AllSyms2 (..),+    allSymsS2,+    allSymsSize,+    symSize,+    symsSize,++    -- * Generic 'AllSyms'+    AllSymsArgs (..),+    GAllSyms (..),+    genericAllSymsS,+    genericLiftAllSymsS,+  )+where++import Data.Kind (Type)+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 (unDefault),+    Default1 (unDefault1),+  )+import Grisette.Internal.Core.Data.Class.AsKey (AsKey (AsKey), AsKey1 (AsKey1))+import Grisette.Internal.SymPrim.Prim.SomeTerm+  ( SomeTerm (SomeTerm),+  )+import Grisette.Internal.SymPrim.Prim.Term+  ( LinkedRep (underlyingTerm),+    pformatTerm,+  )+import Grisette.Internal.SymPrim.Prim.TermUtils+  ( someTermsSize,+    termSize,+    termsSize,+  )+import Grisette.Internal.Utils.Derive (Arity0, Arity1)++-- $setup+-- >>> import Grisette.Core+-- >>> import Grisette.SymPrim+-- >>> import Grisette.Backend+-- >>> import Data.Proxy++-- | Some symbolic value with 'LinkedRep' constraint.+data SomeSym where+  SomeSym :: (LinkedRep con sym) => sym -> SomeSym++instance Show SomeSym where+  show (SomeSym s) = pformatTerm $ 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.+--+-- >>> symsSize [1, "a" :: SymInteger, "a" + 1 :: SymInteger]+-- 3+symsSize :: forall con sym. (LinkedRep con sym) => [sym] -> Int+symsSize = termsSize . fmap (underlyingTerm @con)+{-# INLINE symsSize #-}++-- | Get the size of a symbolic term.+-- Duplicate sub-terms are counted for only once.+--+-- >>> symSize (1 :: SymInteger)+-- 1+-- >>> symSize ("a" :: SymInteger)+-- 1+-- >>> symSize ("a" + 1 :: SymInteger)+-- 3+-- >>> symSize (("a" + 1) * ("a" + 1) :: SymInteger)+-- 4+symSize :: forall con sym. (LinkedRep con sym) => sym -> Int+symSize = termSize . underlyingTerm @con+{-# INLINE symSize #-}++someUnderlyingTerm :: SomeSym -> SomeTerm+someUnderlyingTerm (SomeSym s) = SomeTerm $ underlyingTerm s++someSymsSize :: [SomeSym] -> Int+someSymsSize = someTermsSize . fmap someUnderlyingTerm+{-# INLINE someSymsSize #-}++-- | 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++-- | 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]++-- | Lift the standard 'allSymsS' function to unary type constructors.+allSymsS1 :: (AllSyms1 f, AllSyms a) => f a -> [SomeSym] -> [SomeSym]+allSymsS1 = liftAllSymsS allSymsS+{-# INLINE allSymsS1 #-}++-- | 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]++-- | 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 #-}++-- Derivation++-- | The arguments to the generic 'AllSyms' function.+data family AllSymsArgs arity a :: Type++data instance AllSymsArgs Arity0 _ = AllSymsArgs0++newtype instance AllSymsArgs Arity1 a+  = AllSymsArgs1 (a -> [SomeSym] -> [SomeSym])++-- | 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 GAllSyms arity V1 where+  gallSymsS _ _ = id++instance GAllSyms arity U1 where+  gallSymsS _ _ = id++instance (AllSyms c) => GAllSyms arity (K1 i c) where+  gallSymsS _ (K1 x) = allSymsS x++instance (GAllSyms arity a) => GAllSyms arity (M1 i c a) where+  gallSymsS args (M1 x) = gallSymsS args x++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++instance (GAllSyms arity a, GAllSyms arity b) => GAllSyms arity (a :*: b) where+  gallSymsS args (a :*: b) = gallSymsS args a . gallSymsS args b++instance GAllSyms Arity1 Par1 where+  gallSymsS (AllSymsArgs1 f) (Par1 x) = f x++instance (AllSyms1 f) => GAllSyms Arity1 (Rec1 f) where+  gallSymsS (AllSymsArgs1 f) (Rec1 x) = liftAllSymsS f x++instance (AllSyms1 f, GAllSyms Arity1 g) => GAllSyms Arity1 (f :.: g) where+  gallSymsS targs (Comp1 x) = liftAllSymsS (gallSymsS targs) x++-- | Generic 'allSymsS' function.+genericAllSymsS ::+  (Generic a, GAllSyms Arity0 (Rep a)) =>+  a ->+  [SomeSym] ->+  [SomeSym]+genericAllSymsS x = gallSymsS AllSymsArgs0 (from x)+{-# INLINE genericAllSymsS #-}++-- | 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 #-}++instance (Generic a, GAllSyms Arity0 (Rep a)) => AllSyms (Default a) where+  allSymsS = genericAllSymsS . unDefault+  {-# INLINE allSymsS #-}++instance+  (Generic1 f, GAllSyms Arity1 (Rep1 f), AllSyms a) =>+  AllSyms (Default1 f a)+  where+  allSymsS = allSymsS1+  {-# INLINE allSymsS #-}++instance (Generic1 f, GAllSyms Arity1 (Rep1 f)) => AllSyms1 (Default1 f) where+  liftAllSymsS f = genericLiftAllSymsS f . unDefault1+  {-# INLINE liftAllSymsS #-}++instance (AllSyms a) => AllSyms (AsKey a) where+  allSymsS (AsKey a) = allSymsS a+  {-# INLINE allSymsS #-}++instance (AllSyms1 f) => AllSyms1 (AsKey1 f) where+  liftAllSymsS f (AsKey1 a) = liftAllSymsS f a+  {-# INLINE liftAllSymsS #-}++instance (AllSyms1 f, AllSyms a) => AllSyms (AsKey1 f a) where+  allSymsS (AsKey1 a) = allSymsS a+  {-# INLINE allSymsS #-}
+ src/Grisette/Internal/Internal/Decl/Unified/BVFPConversion.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.Internal.Decl.Unified.BVFPConversion+-- 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.Internal.Decl.Unified.BVFPConversion+  ( UnifiedBVFPConversion,+    UnifiedBVFPConversionImpl,+    SafeUnifiedBVFPConversion,+    SafeUnifiedBVFPConversionImpl,+    AllUnifiedBVFPConversion,+  )+where++import Control.Monad.Error.Class (MonadError)+import GHC.TypeLits (KnownNat, type (+), type (<=))+import Grisette.Internal.Core.Data.Class.BitCast+  ( BitCast,+    BitCastCanonical,+    BitCastOr,+  )+import Grisette.Internal.Core.Data.Class.IEEEFP+  ( IEEEFPConvertible,+  )+import Grisette.Internal.Internal.Decl.Unified.UnifiedBV+  ( UnifiedBVImpl (GetIntN, GetWordN),+  )+import Grisette.Internal.Internal.Decl.Unified.UnifiedFP+  ( UnifiedFPImpl (GetFP, GetFPRoundingMode),+  )+import Grisette.Internal.SymPrim.FP+  ( NotRepresentableFPError,+    ValidFP,+  )+import Grisette.Internal.Unified.Class.UnifiedFromIntegral (UnifiedFromIntegral)+import Grisette.Internal.Unified.Class.UnifiedSafeBitCast (UnifiedSafeBitCast)+import Grisette.Internal.Unified.Class.UnifiedSafeFromFP (UnifiedSafeFromFP)+import Grisette.Internal.Unified.Class.UnifiedSimpleMergeable (UnifiedBranching)+import Grisette.Internal.Unified.EvalModeTag (EvalModeTag)++-- | Implementation for 'UnifiedBVFPConversion'.+class+  ( UnifiedBVImpl mode wordn intn n word int,+    UnifiedFPImpl mode fpn eb sb fp fprd,+    BitCast word fp,+    BitCast int fp,+    BitCastOr fp word,+    BitCastOr fp int,+    BitCastCanonical fp word,+    BitCastCanonical fp int,+    UnifiedFromIntegral mode word fp,+    UnifiedFromIntegral mode int fp,+    IEEEFPConvertible int fp fprd,+    IEEEFPConvertible word fp fprd+  ) =>+  UnifiedBVFPConversionImpl+    (mode :: EvalModeTag)+    wordn+    intn+    fpn+    n+    eb+    sb+    word+    int+    fp+    fprd++-- | Implementation for 'SafeUnifiedBVFPConversion'.+class+  ( UnifiedBVFPConversionImpl mode wordn intn fpn n eb sb word int fp fprd,+    UnifiedSafeBitCast mode NotRepresentableFPError fp int m,+    UnifiedSafeBitCast mode NotRepresentableFPError fp word m,+    UnifiedSafeFromFP mode NotRepresentableFPError word fp fprd m+  ) =>+  SafeUnifiedBVFPConversionImpl mode wordn intn fpn n eb sb word int fp fprd m++-- | Unified constraints for safe conversion from bit-vectors to floating point+-- numbers.+class+  ( SafeUnifiedBVFPConversionImpl+      mode+      (GetWordN mode)+      (GetIntN mode)+      (GetFP mode)+      n+      eb+      sb+      (GetWordN mode n)+      (GetIntN mode n)+      (GetFP mode eb sb)+      (GetFPRoundingMode mode)+      m+  ) =>+  SafeUnifiedBVFPConversion mode n eb sb m++-- | Unified constraints for conversion from bit-vectors to floating point+-- numbers.+class+  ( UnifiedBVFPConversionImpl+      (mode :: EvalModeTag)+      (GetWordN mode)+      (GetIntN mode)+      (GetFP mode)+      n+      eb+      sb+      (GetWordN mode n)+      (GetIntN mode n)+      (GetFP mode eb sb)+      (GetFPRoundingMode mode)+  ) =>+  UnifiedBVFPConversion mode n eb sb++-- | Evaluation mode with unified conversion from bit-vectors to+-- floating-points.+class+  ( forall n eb sb.+    (ValidFP eb sb, KnownNat n, 1 <= n, n ~ (eb + sb)) =>+    UnifiedBVFPConversion mode n eb sb,+    forall n eb sb m.+    ( UnifiedBranching mode m,+      ValidFP eb sb,+      KnownNat n,+      1 <= n,+      n ~ (eb + sb),+      MonadError NotRepresentableFPError m+    ) =>+    SafeUnifiedBVFPConversion mode n eb sb m+  ) =>+  AllUnifiedBVFPConversion mode
+ src/Grisette/Internal/Internal/Decl/Unified/Class/UnifiedITEOp.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.Internal.Decl.Unified.Class.UnifiedITEOp+-- 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.Internal.Decl.Unified.Class.UnifiedITEOp+  ( UnifiedITEOp (..),+  )+where++import Data.Kind (Constraint)+import Data.Type.Bool (If)+import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp)+import Grisette.Internal.Unified.EvalModeTag (IsConMode)++-- | 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
+ src/Grisette/Internal/Internal/Decl/Unified/Class/UnifiedSimpleMergeable.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.Internal.Decl.Unified.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.Internal.Internal.Decl.Unified.Class.UnifiedSimpleMergeable+  ( UnifiedBranching (..),+    UnifiedSimpleMergeable (..),+    UnifiedSimpleMergeable1 (..),+    UnifiedSimpleMergeable2 (..),+  )+where++import Data.Kind (Constraint)+import Data.Type.Bool (If)+import Grisette.Internal.Internal.Decl.Core.Data.Class.Mergeable+  ( Mergeable,+  )+import Grisette.Internal.Internal.Decl.Core.Data.Class.SimpleMergeable+  ( SimpleMergeable,+    SimpleMergeable1,+    SimpleMergeable2,+    SymBranching,+  )+import Grisette.Internal.Internal.Decl.Core.Data.Class.TryMerge+  ( TryMerge,+  )+import Grisette.Internal.Unified.EvalModeTag (EvalModeTag, IsConMode)+import Grisette.Internal.Unified.Util (DecideEvalMode)++-- | A class that provides a unified simple merging.+--+-- We use this type class to help resolve the constraints for `SimpleMergeable`.+class (DecideEvalMode mode, Mergeable a) => 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 (DecideEvalMode mode) => 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 (DecideEvalMode mode) => 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+  (DecideEvalMode mode, TryMerge m) =>+  UnifiedBranching (mode :: EvalModeTag) m+  where+  withBaseBranching ::+    ((If (IsConMode mode) (TryMerge m) (SymBranching m)) => r) -> r
+ src/Grisette/Internal/Internal/Decl/Unified/Class/UnifiedSymEq.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Eta reduce" #-}++-- |+-- Module      :   Grisette.Internal.Internal.Decl.Unified.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.Internal.Internal.Decl.Unified.Class.UnifiedSymEq+  ( UnifiedSymEq (..),+    UnifiedSymEq1 (..),+    UnifiedSymEq2 (..),+  )+where++import Data.Functor.Classes (Eq1, Eq2)+import Data.Type.Bool (If)+import Grisette.Internal.Internal.Decl.Core.Data.Class.SymEq+  ( SymEq,+    SymEq1,+    SymEq2,+  )+import Grisette.Internal.Unified.EvalModeTag (IsConMode)++-- | 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
+ src/Grisette/Internal/Internal/Decl/Unified/Class/UnifiedSymOrd.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Eta reduce" #-}++-- |+-- Module      :   Grisette.Internal.Internal.Decl.Unified.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.Internal.Internal.Decl.Unified.Class.UnifiedSymOrd+  ( UnifiedSymOrd (..),+    UnifiedSymOrd1 (..),+    UnifiedSymOrd2 (..),+  )+where++import Data.Functor.Classes (Ord1, Ord2)+import Data.Type.Bool (If)+import Grisette.Internal.Internal.Decl.Core.Data.Class.SymOrd+  ( SymOrd,+    SymOrd1,+    SymOrd2,+  )+import Grisette.Internal.Unified.EvalModeTag (IsConMode)++-- | 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
+ src/Grisette/Internal/Internal/Decl/Unified/EvalMode.hs view
@@ -0,0 +1,291 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UndecidableSuperClasses #-}++-- |+-- Module      :   Grisette.Internal.Internal.Decl.Unified.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.Internal.Internal.Decl.Unified.EvalMode+  ( EvalModeBase,+    EvalModeInteger,+    EvalModeBV,+    EvalModeFP,+    EvalModeAlgReal,+    EvalModeAll,+    MonadEvalModeAll,+    genEvalMode,+  )+where++import Data.List (nub)+import Data.Maybe (mapMaybe)+import Grisette.Internal.Core.Data.Class.TryMerge (TryMerge)+import Grisette.Internal.Internal.Decl.Unified.BVFPConversion+  ( AllUnifiedBVFPConversion,+  )+import Grisette.Internal.Internal.Decl.Unified.FPFPConversion+  ( AllUnifiedFPFPConversion,+  )+import Grisette.Internal.Internal.Decl.Unified.UnifiedBV (AllUnifiedBV)+import Grisette.Internal.Internal.Decl.Unified.UnifiedBool+  ( UnifiedBool (GetBool),+  )+import Grisette.Internal.Internal.Decl.Unified.UnifiedFP (AllUnifiedFP)+import Grisette.Internal.Unified.BVBVConversion (AllUnifiedBVBVConversion)+import Grisette.Internal.Unified.Class.UnifiedSimpleMergeable (UnifiedBranching)+import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C, S))+import Grisette.Internal.Unified.Theories+  ( TheoryToUnify (UAlgReal, UFP, UFun, UIntN, UInteger, UWordN),+    isUFun,+  )+import Grisette.Internal.Unified.UnifiedAlgReal (UnifiedAlgReal)+import Grisette.Internal.Unified.UnifiedData (AllUnifiedData, UnifiedDataBase)+import Grisette.Internal.Unified.UnifiedFun+  ( genUnifiedFunInstance,+    unifiedFunInstanceName,+  )+import Grisette.Internal.Unified.UnifiedInteger (UnifiedInteger)+import Grisette.Internal.Unified.UnifiedPrim (UnifiedBasicPrim)+import Grisette.Internal.Unified.Util (DecideEvalMode)+import Language.Haskell.TH+  ( DecsQ,+    Type (AppT, ArrowT, ConT, StarT, VarT),+    appT,+    classD,+    conT,+    instanceD,+    kindedTV,+    mkName,+    newName,+    promotedT,+    tySynD,+    varT,+  )++-- | Provide the constraint that the mode is a valid evaluation mode, and+-- provides the support for 'GetBool' and 'Grisette.Internal.Unified.GetData'.+--+-- For compilers prior to GHC 9.2.1, see the notes for 'EvalModeAll'.+class+  ( DecideEvalMode mode,+    UnifiedBool mode,+    UnifiedBasicPrim mode (GetBool mode),+    AllUnifiedData mode,+    UnifiedDataBase mode+  ) =>+  EvalModeBase mode++-- | Provide the support for 'Grisette.Internal.Unified.GetIntN',+-- 'Grisette.Internal.Unified.GetWordN', 'Grisette.Internal.Unified.GetSomeIntN', and+-- 'Grisette.Internal.Unified.GetSomeWordN'.+--+-- For compilers prior to GHC 9.2.1, see the notes for 'EvalModeAll'.+class (AllUnifiedBV mode, AllUnifiedBVBVConversion mode) => EvalModeBV mode++-- | Provide the support for 'Grisette.Internal.Unified.GetInteger'.+--+-- For compilers prior to GHC 9.2.1, see the notes for 'EvalModeAll'.+type EvalModeInteger = UnifiedInteger++-- | Provide the support for 'Grisette.Internal.Unified.GetFP' and+-- 'Grisette.Internal.Unified.GetFPRoundingMode'.+--+-- For compilers prior to GHC 9.2.1, see the notes for 'EvalModeAll'.+class+  ( AllUnifiedFP mode,+    AllUnifiedFPFPConversion mode,+    AllUnifiedBVFPConversion mode+  ) =>+  EvalModeFP mode++-- | Provide the support for 'Grisette.Internal.Unified.GetAlgReal'.+--+-- For compilers prior to GHC 9.2.1, see the notes for 'EvalModeAll'.+type EvalModeAlgReal = UnifiedAlgReal++-- | 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.Internal.Unified.UnifiedBV.UnifiedBV`,+-- `Grisette.Internal.Unified.UnifiedBV.SafeUnifiedBV`,+-- `Grisette.Internal.Unified.UnifiedBV.SafeUnifiedSomeBV`, and+-- `Grisette.Internal.Unified.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+  ( EvalModeBase mode,+    EvalModeInteger mode,+    EvalModeAlgReal mode,+    EvalModeBV mode,+    EvalModeFP mode+  ) =>+  EvalModeAll mode++-- | 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.Internal.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 'EvalModeAll'.+type MonadEvalModeAll mode m =+  ( EvalModeAll mode,+    Monad m,+    TryMerge m,+    UnifiedBranching mode m+  )++-- | This template haskell function generates an EvalMode constraint on demand.+--+-- For example, if in your system, you are only working on bit-vectors and+-- booleans, but not floating points, integers, or real numbers, you can use+-- this function to generate a constraint that only includes the necessary+-- constraints:+--+-- > genEvalMode "MyEvalMode" [UWordN, UIntN, UBool]+-- > f :: MyEvalMode mode => GetBool mode -> GetWordN mode 8 -> GetWordN mode 8+-- > f = ...+--+-- This may help with faster compilation times.+--+-- Another usage of this custom constraint is to working with uninterpreted+-- functions. The uninterpreted functions aren't available even with+-- 'EvalModeAll', and is only available with the constraint generated by this+-- function. Note that you need to explicitly list all the uninterpreted+-- function types you need in your system.+--+-- > genEvalMode "MyEvalModeUF" [UFun [UWordN, UIntN], UFun [UBool, UBool, UWordN]]+--+-- This will give us a constraint that allows us to work with booleans and+-- bit-vectors, and also the uninterpreted functions that+--+-- * maps an unsigned bit-vector (any bitwidth) to an unsigned integer (any+--   bitwidth), and+-- * maps two booleans to an unsigned bit-vector (any bitwidth).+--+-- You can then use them in your code like this:+--+-- > f :: MyEvalModeUF mode => GetFun mode (GetWordN mode 8) (GetIntN mode 8) -> GetIntN mode 8+-- > f fun = f # 1+--+-- The function will also provide the constraint @MonadMyEvalModeUF@, which+-- includes the constraints for the monad and the unified branching, similar to+-- 'MonadEvalModeAll'.+--+-- For compilers older than GHC 9.2.1, see the notes for 'EvalModeAll'. This+-- function will also generate constraints like @MyEvalModeUFFunUWordNUIntN@,+-- which can be used to resolve the constraints for older compilers.+--+-- The naming conversion is the concatenation of the three parts:+--+-- * The base name provided by the user (i.e., @MyEvalModeUF@),+-- * @Fun@,+-- * The concatenation of all the types in the uninterpreted function (i.e.,+--   @UWordNUIntN@).+--+-- The arguments to the type class is as follows:+--+-- * The first argument is the mode,+-- * The second to the end arguments are the natural number arguments for all+--   the types. Here the second argument is the bitwidth of the unsigned+--   bit-vector argument, and the third argument is the bitwidth of the signed+--   bit-vector result.+genEvalMode :: String -> [TheoryToUnify] -> DecsQ+genEvalMode nm theories = do+  modeName <- newName "mode"+  let modeType = VarT modeName+  baseConstraint <- [t|EvalModeBase $(return modeType)|]+  basicConstraints <- concat <$> traverse (nonFuncConstraint modeType) nonFuncs+  funcInstances <- concat <$> traverse (genUnifiedFunInstance nm) funcs+  let instanceNames = ("All" ++) . unifiedFunInstanceName nm <$> funcs+  funcConstraints <- traverse (genFunConstraint (return modeType)) instanceNames+  r <-+    classD+      (return $ baseConstraint : basicConstraints ++ funcConstraints)+      (mkName nm)+      [kindedTV modeName (ConT ''EvalModeTag)]+      []+      []+  rc <- instanceD (return []) (appT (conT $ mkName nm) (promotedT 'C)) []+  rs <- instanceD (return []) (appT (conT $ mkName nm) (promotedT 'S)) []+  m <- newName "m"+  let mType = varT m+  monad <-+    tySynD+      (mkName $ "Monad" ++ nm)+      [ kindedTV modeName (ConT ''EvalModeTag),+        kindedTV m (AppT (AppT ArrowT StarT) StarT)+      ]+      [t|+        ( $(appT (conT $ mkName nm) (return modeType)),+          Monad $mType,+          TryMerge $mType,+          UnifiedBranching $(return modeType) $mType+        )+        |]+  return $ funcInstances ++ [r, rc, rs, monad]+  where+    nonFuncs =+      nub $+        (\x -> if x == UIntN then UWordN else x)+          <$> filter (not . isUFun) (theories ++ concat funcs)+    funcs =+      nub $+        mapMaybe+          ( \case+              UFun x -> Just x+              _ -> Nothing+          )+          theories+    nonFuncConstraint mode UInteger =+      (: []) <$> [t|EvalModeInteger $(return mode)|]+    nonFuncConstraint mode UAlgReal =+      (: []) <$> [t|EvalModeAlgReal $(return mode)|]+    nonFuncConstraint mode UWordN =+      (: []) <$> [t|EvalModeBV $(return mode)|]+    nonFuncConstraint mode UFP = (: []) <$> [t|EvalModeFP $(return mode)|]+    nonFuncConstraint _ _ = return []+    genFunConstraint mode name = appT (conT (mkName name)) mode
+ src/Grisette/Internal/Internal/Decl/Unified/FPFPConversion.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.Internal.Decl.Unified.FPFPConversion+-- 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.Internal.Decl.Unified.FPFPConversion+  ( UnifiedFPFPConversionImpl,+    UnifiedFPFPConversion,+    AllUnifiedFPFPConversion,+  )+where++import Grisette.Internal.Core.Data.Class.IEEEFP (IEEEFPConvertible)+import Grisette.Internal.Internal.Decl.Unified.UnifiedFP+  ( UnifiedFPImpl (GetFP, GetFPRoundingMode),+  )+import Grisette.Internal.SymPrim.FP (ValidFP)+import Grisette.Internal.Unified.EvalModeTag (EvalModeTag)++-- | Implementation for 'UnifiedFPFPConversion'.+class+  ( UnifiedFPImpl mode fpn eb0 sb0 fp0 fprd,+    UnifiedFPImpl mode fpn eb1 sb1 fp1 fprd,+    IEEEFPConvertible fp0 fp1 fprd+  ) =>+  UnifiedFPFPConversionImpl+    (mode :: EvalModeTag)+    fpn+    eb0+    sb0+    eb1+    sb1+    fp0+    fp1+    fprd++-- | Unified constraints for conversion from floating point numbers to floating+-- point numbers.+class+  ( UnifiedFPFPConversionImpl+      (mode :: EvalModeTag)+      (GetFP mode)+      eb0+      sb0+      eb1+      sb1+      (GetFP mode eb0 sb0)+      (GetFP mode eb1 sb1)+      (GetFPRoundingMode mode)+  ) =>+  UnifiedFPFPConversion mode eb0 sb0 eb1 sb1++-- | Evaluation mode with unified conversion from floating-points to+-- floating-points.+class+  ( forall eb0 sb0 eb1 sb1.+    (ValidFP eb0 sb0, ValidFP eb1 sb1) =>+    UnifiedFPFPConversion+      mode+      eb0+      sb0+      eb1+      sb1+  ) =>+  AllUnifiedFPFPConversion mode
+ src/Grisette/Internal/Internal/Decl/Unified/UnifiedBV.hs view
@@ -0,0 +1,257 @@+{-# 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.Internal.Internal.Decl.Unified.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.Internal.Internal.Decl.Unified.UnifiedBV+  ( SomeBVPair,+    UnifiedBVImpl (GetIntN, GetWordN),+    SafeUnifiedBVImpl,+    SafeUnifiedSomeBVImpl,+    SafeUnifiedSomeBV,+    UnifiedBV,+    GetSomeWordN,+    GetSomeIntN,+    SafeUnifiedBV,+    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.BitCast (BitCast)+import Grisette.Internal.Core.Data.Class.BitVector (BV, SizedBV)+import Grisette.Internal.Core.Data.Class.SafeDiv (DivOr)+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+  ( IntN,+    WordN,+  )+import Grisette.Internal.SymPrim.SomeBV+  ( SomeBV,+    SomeBVException,+    SomeIntN,+    SomeSymIntN,+    SomeSymWordN,+    SomeWordN,+  )+import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN)+import Grisette.Internal.Unified.BaseConstraint (ConSymConversion)+import Grisette.Internal.Unified.Class.UnifiedFiniteBits+  ( UnifiedFiniteBits,+  )+import Grisette.Internal.Unified.Class.UnifiedFromIntegral (UnifiedFromIntegral)+import Grisette.Internal.Unified.Class.UnifiedRep+  ( UnifiedConRep (ConType),+    UnifiedSymRep (SymType),+  )+import Grisette.Internal.Unified.Class.UnifiedSafeDiv (UnifiedSafeDiv)+import Grisette.Internal.Unified.Class.UnifiedSafeLinearArith+  ( UnifiedSafeLinearArith,+  )+import Grisette.Internal.Unified.Class.UnifiedSafeSymRotate+  ( UnifiedSafeSymRotate,+  )+import Grisette.Internal.Unified.Class.UnifiedSafeSymShift (UnifiedSafeSymShift)+import Grisette.Internal.Unified.Class.UnifiedSimpleMergeable+  ( UnifiedBranching,+  )+import Grisette.Internal.Unified.EvalModeTag (EvalModeTag)+import Grisette.Internal.Unified.UnifiedAlgReal (GetAlgReal)+import Grisette.Internal.Unified.UnifiedInteger (GetInteger)+import Grisette.Internal.Unified.UnifiedPrim (UnifiedBasicPrim, UnifiedPrim)++type BVConstraint mode word int =+  ( Num word,+    Num int,+    Bits word,+    Bits int,+    FiniteBits word,+    FiniteBits int,+    SymShift word,+    SymShift int,+    SymRotate word,+    SymRotate int,+    SignConversion word int,+    UnifiedFiniteBits mode word,+    UnifiedFiniteBits mode int+  ) ::+    Constraint++-- | Constraints for a pair of non-sized-tagged bit vector types.+type SomeBVPair mode word int =+  ( UnifiedPrim mode word,+    UnifiedPrim mode int,+    BVConstraint mode word int,+    BV word,+    BV int,+    DivOr word,+    DivOr int,+    ConSymConversion SomeWordN SomeSymWordN word,+    ConSymConversion SomeIntN SomeSymIntN int+  ) ::+    Constraint++-- | Implementation for 'UnifiedBV'.+class+  ( UnifiedConRep word,+    UnifiedSymRep int,+    ConType word ~ WordN n,+    SymType word ~ SymWordN n,+    ConType int ~ IntN n,+    SymType int ~ SymIntN n,+    UnifiedBasicPrim mode word,+    UnifiedBasicPrim mode int,+    BVConstraint mode word int,+    wordn ~ GetWordN mode,+    intn ~ GetIntN mode,+    word ~ wordn n,+    int ~ intn n,+    BitCast word int,+    BitCast int word,+    DivOr word,+    DivOr int,+    UnifiedFromIntegral mode (GetInteger mode) word,+    UnifiedFromIntegral mode (GetInteger mode) int,+    UnifiedFromIntegral mode word (GetInteger mode),+    UnifiedFromIntegral mode word (GetAlgReal mode),+    UnifiedFromIntegral mode int (GetInteger mode),+    UnifiedFromIntegral mode int (GetAlgReal mode),+    ConSymConversion (WordN n) (SymWordN n) word,+    ConSymConversion (IntN n) (SymIntN n) int+  ) =>+  UnifiedBVImpl (mode :: EvalModeTag) wordn intn n word int+    | wordn -> intn,+      intn -> wordn,+      wordn n -> word,+      word -> wordn n,+      intn n -> int,+      int -> intn n+  where+  -- | Get a unified unsigned size-tagged bit vector type. Resolves to 'WordN'+  -- in 'Grisette.Unified.C' mode, and 'SymWordN' in 'Grisette.Unified.S' mode.+  type GetWordN mode = (w :: Nat -> Type) | w -> mode++  -- | Get a unified signed size-tagged bit vector type. Resolves to 'IntN'+  -- in 'Grisette.Unified.C' mode, and 'SymIntN' in 'Grisette.Unified.S' mode.+  type GetIntN mode = (i :: Nat -> Type) | i -> mode++-- | Get a unified unsigned dynamic bit width bit vector type. Resolves to+-- 'SomeWordN' in 'Grisette.Unified.C' mode, and 'SomeSymWordN' in+-- 'Grisette.Unified.S' 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 'Grisette.Unified.C' mode, and 'SomeSymIntN' in+-- 'Grisette.Unified.S' 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.Internal.Unified.EvalMode.EvalMode'.+class+  ( UnifiedBVImpl+      mode+      (GetWordN mode)+      (GetIntN mode)+      n+      (GetWordN mode n)+      (GetIntN mode n)+  ) =>+  UnifiedBV mode n++-- | Implementation for 'SafeUnifiedBV'.+class+  ( UnifiedSafeDiv mode ArithException word m,+    UnifiedSafeLinearArith mode ArithException word m,+    UnifiedSafeSymShift mode ArithException word m,+    UnifiedSafeSymRotate mode ArithException word m,+    UnifiedSafeDiv 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++-- | This class is needed as constraint in user code prior to GHC 9.2.1.+-- See the notes in 'Grisette.Internal.Unified.EvalMode.EvalMode'.+class+  ( SafeUnifiedBVImpl+      mode+      (GetWordN mode)+      (GetIntN mode)+      n+      (GetWordN mode n)+      (GetIntN mode n)+      m+  ) =>+  SafeUnifiedBV mode n m++-- | Implementation for 'SafeUnifiedSomeBV'.+class+  ( SomeBVPair mode word int,+    UnifiedSafeDiv mode (Either SomeBVException ArithException) word m,+    UnifiedSafeLinearArith mode (Either SomeBVException ArithException) word m,+    UnifiedSafeSymRotate mode (Either SomeBVException ArithException) word m,+    UnifiedSafeSymShift mode (Either SomeBVException ArithException) word m,+    UnifiedSafeDiv mode (Either SomeBVException ArithException) int m,+    UnifiedSafeLinearArith mode (Either SomeBVException ArithException) int m,+    UnifiedSafeSymRotate mode (Either SomeBVException ArithException) int m,+    UnifiedSafeSymShift mode (Either SomeBVException 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.Internal.Unified.EvalMode.EvalMode'.+class+  ( 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 SomeBVException ArithException) m+    ) =>+    SafeUnifiedSomeBV mode m,+    forall n. (KnownNat n, 1 <= n) => UnifiedBV mode n,+    SomeBVPair mode (GetSomeWordN mode) (GetSomeIntN mode),+    SizedBV (GetWordN mode),+    SizedBV (GetIntN mode)+  ) =>+  AllUnifiedBV mode
+ src/Grisette/Internal/Internal/Decl/Unified/UnifiedBool.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators #-}++-- |+-- Module      :   Grisette.Internal.Internal.Decl.Unified.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.Internal.Internal.Decl.Unified.UnifiedBool+  ( UnifiedBool (..),+  )+where++import Grisette.Internal.Core.Data.Class.LogicalOp (LogicalOp)+import Grisette.Internal.SymPrim.SymBool (SymBool)+import Grisette.Internal.SymPrim.SymPrim (Prim)+import Grisette.Internal.Unified.BaseConstraint+  ( ConSymConversion,+  )+import Grisette.Internal.Unified.Class.UnifiedRep+  ( UnifiedConRep (ConType),+    UnifiedSymRep (SymType),+  )+import Grisette.Internal.Unified.EvalModeTag (EvalModeTag)++-- | Evaluation mode with unified 'Bool' type.+class+  ( Prim (GetBool mode),+    UnifiedConRep (GetBool mode),+    UnifiedSymRep (GetBool mode),+    ConType (GetBool mode) ~ Bool,+    SymType (GetBool mode) ~ SymBool,+    ConSymConversion Bool SymBool (GetBool mode),+    LogicalOp (GetBool mode)+  ) =>+  UnifiedBool (mode :: EvalModeTag)+  where+  -- | Get a unified Boolean type. Resolves to 'Bool' in 'Grisette.Unified.C'+  -- mode, and 'SymBool' in 'Grisette.Unified.S' mode.+  type GetBool mode = bool | bool -> mode
+ src/Grisette/Internal/Internal/Decl/Unified/UnifiedFP.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.Internal.Decl.Unified.UnifiedFP+-- 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.Internal.Decl.Unified.UnifiedFP+  ( UnifiedFP,+    SafeUnifiedFP,+    AllUnifiedFP,+    UnifiedFPImpl (GetFP, GetFPRoundingMode),+    SafeUnifiedFPImpl,+  )+where++import Control.Monad.Error.Class (MonadError)+import Data.Kind (Type)+import GHC.TypeNats (Nat)+import Grisette.Internal.Core.Data.Class.IEEEFP+  ( IEEEFPConstants,+    IEEEFPConvertible,+    IEEEFPOp,+    IEEEFPRoundingOp,+    IEEEFPToAlgReal,+  )+import Grisette.Internal.Core.Data.Class.SymIEEEFP (SymIEEEFPTraits)+import Grisette.Internal.SymPrim.FP (FP, NotRepresentableFPError, ValidFP)+import Grisette.Internal.SymPrim.SymFP (SymFP)+import Grisette.Internal.Unified.BaseConstraint (ConSymConversion)+import Grisette.Internal.Unified.Class.UnifiedFromIntegral (UnifiedFromIntegral)+import Grisette.Internal.Unified.Class.UnifiedRep+  ( UnifiedConRep (ConType),+    UnifiedSymRep (SymType),+  )+import Grisette.Internal.Unified.Class.UnifiedSafeFromFP (UnifiedSafeFromFP)+import Grisette.Internal.Unified.Class.UnifiedSimpleMergeable (UnifiedBranching)+import Grisette.Internal.Unified.EvalModeTag (EvalModeTag)+import Grisette.Internal.Unified.UnifiedAlgReal (GetAlgReal)+import Grisette.Internal.Unified.UnifiedInteger (GetInteger)+import Grisette.Internal.Unified.UnifiedPrim (UnifiedBasicPrim)++-- | Implementation for 'UnifiedFP'.+class+  ( UnifiedConRep fp,+    UnifiedSymRep fp,+    ConType fp ~ FP eb sb,+    SymType fp ~ SymFP eb sb,+    UnifiedBasicPrim mode fp,+    Floating fp,+    SymIEEEFPTraits fp,+    IEEEFPConstants fp,+    IEEEFPOp fp,+    IEEEFPRoundingOp fp rd,+    UnifiedFromIntegral mode (GetInteger mode) fp,+    IEEEFPToAlgReal (GetAlgReal mode) fp rd,+    IEEEFPConvertible (GetInteger mode) fp rd,+    ConSymConversion (FP eb sb) (SymFP eb sb) fp,+    fpn ~ GetFP mode,+    fp ~ fpn eb sb,+    rd ~ GetFPRoundingMode mode+  ) =>+  UnifiedFPImpl (mode :: EvalModeTag) fpn eb sb fp rd+    | fpn eb sb -> fp rd,+      fp -> fpn eb sb rd,+      rd -> fpn,+      rd eb sb -> fp+  where+  -- | Get a unified floating point type. Resolves to 'FP' in+  -- 'Grisette.Unified.C' mode, and 'SymFP' in 'Grisette.Unified.S' mode.+  type GetFP mode = (f :: Nat -> Nat -> Type) | f -> mode++  -- | Get a unified floating point rounding mode type. Resolves to+  -- 'Grisette.FPRoundingMode' in 'Grisette.Unified.C' mode, and+  -- 'Grisette.SymFPRoundingMode' in 'Grisette.Unified.S' mode.+  type GetFPRoundingMode mode = r | r -> mode++-- | Evaluation mode with unified 'FP' type.+class+  ( UnifiedFPImpl+      mode+      (GetFP mode)+      eb+      sb+      (GetFP mode eb sb)+      (GetFPRoundingMode mode)+  ) =>+  UnifiedFP mode eb sb++-- | Implementation for 'SafeUnifiedFP'.+class+  (UnifiedFPImpl mode fpn eb sb fp rd) =>+  SafeUnifiedFPImpl mode fpn eb sb fp rd (m :: Type -> Type)++-- | This class is needed as constraint in user code prior to GHC 9.2.1.+-- See the notes in 'Grisette.Internal.Unified.EvalMode.EvalMode'.+class+  ( SafeUnifiedFPImpl+      mode+      (GetFP mode)+      eb+      sb+      (GetFP mode eb sb)+      (GetFPRoundingMode mode)+      m,+    UnifiedSafeFromFP+      mode+      NotRepresentableFPError+      (GetInteger mode)+      (GetFP mode eb sb)+      (GetFPRoundingMode mode)+      m+  ) =>+  SafeUnifiedFP mode eb sb m++-- | Evaluation mode with unified floating point type.+class+  ( forall eb sb. (ValidFP eb sb) => UnifiedFP mode eb sb,+    forall eb sb m.+    ( ValidFP eb sb,+      UnifiedBranching mode m,+      MonadError NotRepresentableFPError m+    ) =>+    SafeUnifiedFP mode eb sb m+  ) =>+  AllUnifiedFP mode
+ src/Grisette/Internal/Internal/Impl/Core/Control/Monad/Union.hs view
@@ -0,0 +1,478 @@+{-# 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.Internal.Impl.Core.Control.Monad.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.Internal.Impl.Core.Control.Monad.Union+  ( -- * Union and helpers+    unionUnaryOp,+    unionBinOp,+    isMerged,+    unionSize,+  )+where++#if MIN_VERSION_base(4,16,0)+import Grisette.Internal.Core.Data.Class.AsKey+  ( KeyEq (keyEq),+    KeyEq1 (liftKeyEq),+    KeyHashable (keyHashWithSalt),+    KeyHashable1 (liftKeyHashWithSalt),+    shouldUseAsKeyHasSymbolicVersionError,+  )+import Grisette.Internal.Core.Data.Class.UnionView (simpleMerge)+#else+import Grisette.Internal.Core.Data.Class.AsKey+  ( AsKey1 (AsKey1),+    KeyEq (keyEq),+    KeyEq1 (liftKeyEq),+    KeyHashable (keyHashWithSalt),+    KeyHashable1 (liftKeyHashWithSalt),+    shouldUseAsKeyHasSymbolicVersionError,+  )+import Grisette.Internal.Core.Data.Class.UnionView+  ( UnionView (ifView, overestimateUnionValues, singleView, toGuardedList),+    IfViewResult (IfViewResult),+    simpleMerge,+  )+#endif++import Control.Applicative (Alternative ((<|>)))+import Control.DeepSeq (NFData (rnf), NFData1 (liftRnf), rnf1)+import Control.Monad.Identity (Identity (Identity, runIdentity))+import qualified Data.Binary as Binary+import Data.Bytes.Serial (Serial (deserialize, serialize))+import Data.Functor.Classes+  ( Eq1 (liftEq),+    Show1 (liftShowsPrec),+    showsPrec1,+  )+import Data.Hashable (Hashable (hashWithSalt))+import qualified Data.Serialize as Cereal+import GHC.TypeNats (KnownNat, type (<=))+import Grisette.Internal.Core.Data.Class.EvalSym+  ( EvalSym (evalSym),+    EvalSym1 (liftEvalSym),+    evalSym1,+  )+import Grisette.Internal.Core.Data.Class.ExtractSym+  ( ExtractSym (extractSymMaybe),+    ExtractSym1 (liftExtractSymMaybe),+    extractSymMaybe1,+  )+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),+  )+import Grisette.Internal.Core.Data.Class.PPrint+  ( PPrint (pformatPrec),+    PPrint1 (liftPFormatPrec),+    groupedEnclose,+    pformatPrec1,+  )+import Grisette.Internal.Core.Data.Class.SimpleMergeable+  ( SymBranching (mrgIfPropagatedStrategy, mrgIfWithStrategy),+    mrgIf,+  )+import Grisette.Internal.Core.Data.Class.Solvable+  ( Solvable (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.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+  ( mrgSingle,+    mrgSingleWithStrategy,+    tryMerge,+  )+import Grisette.Internal.Internal.Decl.Core.Control.Monad.Union+  ( Union (Union, unionBase, unionMergingStrategy),+  )+import Grisette.Internal.Internal.Decl.Core.Data.Class.SymEq+  ( SymEq ((.==)),+    SymEq1 (liftSymEq),+    symEq1,+  )+import Grisette.Internal.Internal.Decl.Core.Data.UnionBase+  ( UnionBase (UnionIf, UnionSingle),+  )+import Grisette.Internal.Internal.Impl.Core.Data.UnionBase ()+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,+    SupportedNonFuncPrim,+    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++instance (Mergeable a, Serial a) => Serial (Union a) where+  serialize = serialize . unionBase+  deserialize = Union (Just rootStrategy) <$> deserialize++instance (Mergeable a, Serial a) => Cereal.Serialize (Union a) where+  put = serialize+  get = deserialize++instance (Mergeable a, Serial a) => Binary.Binary (Union a) where+  put = serialize+  get = deserialize++instance (NFData a) => NFData (Union a) where+  rnf = rnf1++instance NFData1 Union where+  liftRnf _a (Union _ m) = liftRnf _a m++instance (Lift a) => Lift (Union a) where+  liftTyped (Union Nothing v) = [||Union Nothing v||]+  liftTyped (Union (Just _) v) = [||Union Nothing 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 _ (Union Nothing a) =+    wrapBracket '<' '>'+      . liftShowsPrecUnion sp sl 0+      $ a+  liftShowsPrec sp sl _ (Union Just {} a) =+    wrapBracket '{' '}'+      . liftShowsPrecUnion sp sl 0+      $ a++instance (PPrint a) => PPrint (Union a) where+  pformatPrec = pformatPrec1++instance PPrint1 Union where+  liftPFormatPrec fa fl _ = \case+    (Union Nothing a) -> groupedEnclose "<" ">" $ liftPFormatPrec fa fl 0 a+    (Union (Just _) a) -> groupedEnclose "{" "}" $ liftPFormatPrec fa fl 0 a++-- | Check if a 'Union' is already merged.+isMerged :: Union a -> Bool+isMerged (Union Nothing _) = False+isMerged (Union Just {} _) = True+{-# INLINE isMerged #-}++-- | 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 (SymEq a) => SymEq (Union a) where+  (.==) = symEq1+  {-# INLINE (.==) #-}++instance SymEq1 Union where+  liftSymEq f x y = simpleMerge $ f <$> x <*> y+  {-# INLINE liftSymEq #-}++instance (ToSym a b) => ToSym (Union a) (Union b) where+  toSym = toSym1++instance ToSym1 Union Union where+  liftToSym = fmap++instance (ToSym a b) => ToSym (Identity a) (Union b) where+  toSym = toSym1++instance ToSym1 Identity Union where+  liftToSym f v = return $ runIdentity $ fmap f v++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),+    SupportedNonFuncPrim ca,+    LinkedRep ca sa,+    LinkedRep cb sb+  ) =>+  ToSym (Union ((=->) ca cb)) ((=~>) sa sb)+  where+  toSym = simpleMerge . fmap con++instance+  ( SupportedPrim ((-->) ca cb),+    SupportedNonFuncPrim ca,+    LinkedRep ca sa,+    LinkedRep cb sb+  ) =>+  ToSym (Union ((-->) ca cb)) ((-~>) sa sb)+  where+  toSym = simpleMerge . fmap con++instance (ToCon a b) => ToCon (Union a) (Identity b) where+  toCon = toCon1++instance ToCon1 Union Identity where+  liftToCon f v = go $ unionBase v+    where+      go (UnionSingle x) = Identity <$> f x+      go (UnionIf _ _ c t f) =+        case toCon c of+          Nothing -> Nothing+          Just True -> go t+          Just False -> go f++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+  extractSymMaybe = extractSymMaybe1++instance ExtractSym1 Union where+  liftExtractSymMaybe e v = go $ unionBase v+    where+      go (UnionSingle x) = e x+      go (UnionIf _ _ cond t f) = extractSymMaybe cond <> go t <> go f++instance (Eq a, Hashable a) => KeyHashable (Union a) where+  keyHashWithSalt = liftKeyHashWithSalt hashWithSalt+  {-# INLINE keyHashWithSalt #-}++instance KeyHashable1 Union where+  liftKeyHashWithSalt f s (Union Nothing a) =+    liftKeyHashWithSalt f s a `hashWithSalt` (0 :: Int)+  liftKeyHashWithSalt f s (Union (Just _) a) =+    liftKeyHashWithSalt f s a `hashWithSalt` (1 :: Int)++instance (Eq a) => KeyEq (Union a) where+  keyEq = liftKeyEq (==)++instance KeyEq1 Union where+  liftKeyEq f (Union Nothing l) (Union Nothing r) = liftKeyEq f l r+  liftKeyEq f (Union (Just _) l) (Union (Just _) r) = liftKeyEq f l r+  liftKeyEq _ _ _ = False++instance (Eq a) => Eq (Union a) where+  (==) = shouldUseAsKeyHasSymbolicVersionError "Union" "(==)" "(.==)"++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 = tryMerge . unionUnaryOp negate+  l + r = tryMerge $ unionBinOp (+) l r+  l * r = tryMerge $ unionBinOp (*) l r+  l - r = tryMerge $ unionBinOp (-) l r+  abs = tryMerge . unionUnaryOp abs+  signum = tryMerge . unionUnaryOp signum++instance (Mergeable a) => ITEOp (Union a) where+  symIte = mrgIf++instance (LogicalOp a, Mergeable a) => LogicalOp (Union a) where+  true = mrgSingle true+  false = mrgSingle false+  l .|| r = tryMerge $ unionBinOp (.||) l r+  l .&& r = tryMerge $ unionBinOp (.&&) l r+  symNot = tryMerge . unionUnaryOp symNot+  symXor l r = tryMerge $ unionBinOp symXor l r+  symImplies l r = tryMerge $ unionBinOp symImplies l r++instance+  (Function f arg ret, Mergeable f, Mergeable ret) =>+  Function (Union f) arg (Union ret)+  where+  f # a = do+    f1 <- f+    mrgSingle $ f1 # a++-- AllSyms+instance (AllSyms a) => AllSyms (Union a) where+  allSymsS = allSymsS1++instance AllSyms1 Union where+  liftAllSymsS f = liftAllSymsS f . unionBase++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++#if !MIN_VERSION_base(4,16,0)+instance SymBranching (AsKey1 Union) where+  mrgIfWithStrategy strategy cond (AsKey1 t) (AsKey1 f) =+    AsKey1 $ mrgIfWithStrategy strategy cond t f+  mrgIfPropagatedStrategy cond (AsKey1 t) (AsKey1 f) =+    AsKey1 $ mrgIfPropagatedStrategy cond t f+  {-# INLINE mrgIfWithStrategy #-}+  {-# INLINE mrgIfPropagatedStrategy #-}++instance UnionView (AsKey1 Union) where+  singleView (AsKey1 u) = singleView u+  ifView (AsKey1 u) = case ifView u of+    Just (IfViewResult c l r) -> Just (IfViewResult c (AsKey1 l) (AsKey1 r))+    Nothing -> Nothing+  toGuardedList (AsKey1 u) = toGuardedList u+  overestimateUnionValues (AsKey1 u) = overestimateUnionValues u+#endif
+ src/Grisette/Internal/Internal/Impl/Core/Data/Class/EvalSym.hs view
@@ -0,0 +1,352 @@+{-# 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.Internal.Impl.Core.Data.Class.EvalSym () where++import Control.Exception (ArithException)+import Control.Monad.Except (ExceptT)+import Control.Monad.Identity+  ( Identity,+    IdentityT (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.Compose (Compose (Compose))+import Data.Functor.Const (Const)+import Data.Functor.Product (Product)+import Data.Functor.Sum (Sum)+import qualified Data.HashSet as HS+import Data.Int (Int16, Int32, Int64, Int8)+import Data.Monoid (Alt, Ap)+import Data.Ord (Down)+import Data.Proxy (Proxy)+import Data.Ratio (Ratio, denominator, numerator, (%))+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),+    K1 (K1),+    M1 (M1),+    Par1 (Par1),+    Rec1 (Rec1),+    U1,+    V1,+    (:.:) (Comp1),+    type (:*:),+    type (:+:),+  )+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.AsKey (AsKey (AsKey), AsKey1 (AsKey1))+import Grisette.Internal.Internal.Decl.Core.Data.Class.EvalSym+  ( EvalSym (evalSym),+    EvalSym1 (liftEvalSym),+    EvalSym2,+    evalSym1,+  )+import Grisette.Internal.SymPrim.AlgReal (AlgReal)+import Grisette.Internal.SymPrim.BV (IntN, WordN)+import Grisette.Internal.SymPrim.FP+  ( FP,+    FPRoundingMode,+    NotRepresentableFPError,+    ValidFP,+  )+import Grisette.Internal.SymPrim.GeneralFun (type (-->) (GeneralFun))+import Grisette.Internal.SymPrim.Prim.Model (evalTerm)+import Grisette.Internal.SymPrim.Prim.Term+  ( SymRep (SymType),+    someTypedSymbol,+  )+import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal (SymAlgReal))+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 (=->) (TabularFun))+import Grisette.Internal.TH.Derivation.Derive (derive)++#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)+CONCRETE_EVALUATESYM(AlgReal)+#endif++instance EvalSym (Proxy a) where+  evalSym _ _ = id+  {-# INLINE evalSym #-}++instance EvalSym1 Proxy where+  liftEvalSym _ _ _ = id+  {-# INLINE liftEvalSym #-}++instance (Integral a, EvalSym a) => EvalSym (Ratio a) where+  evalSym fillDefault model r =+    evalSym fillDefault model (numerator r)+      % evalSym fillDefault model (denominator r)++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 $ evalTerm fillDefault model HS.empty t++#define EVALUATE_SYM_BV(symtype) \+instance (KnownNat n, 1 <= n) => EvalSym (symtype n) where \+  evalSym fillDefault model (symtype t) = \+    symtype $ evalTerm fillDefault model HS.empty t++#define EVALUATE_SYM_FUN(cop, op, cons) \+instance EvalSym (op sa sb) where \+  evalSym fillDefault model (cons t) = \+    cons $ evalTerm fillDefault model HS.empty t++#if 1+EVALUATE_SYM_SIMPLE(SymBool)+EVALUATE_SYM_SIMPLE(SymInteger)+EVALUATE_SYM_SIMPLE(SymFPRoundingMode)+EVALUATE_SYM_SIMPLE(SymAlgReal)+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 $ evalTerm fillDefault model HS.empty t++derive+  [ ''(),+    ''AssertionError,+    ''VerificationConditions,+    ''NotRepresentableFPError,+    ''ArithException+  ]+  [''EvalSym]++derive+  [ ''Either,+    ''(,),+    ''(,,),+    ''(,,,),+    ''(,,,,),+    ''(,,,,,),+    ''(,,,,,,),+    ''(,,,,,,,),+    ''(,,,,,,,,),+    ''(,,,,,,,,,),+    ''(,,,,,,,,,,),+    ''(,,,,,,,,,,,),+    ''(,,,,,,,,,,,,),+    ''(,,,,,,,,,,,,,),+    ''(,,,,,,,,,,,,,,)+  ]+  [''EvalSym, ''EvalSym1, ''EvalSym2]++derive+  [ ''[],+    ''Maybe,+    ''Identity,+    ''Monoid.Dual,+    ''Monoid.First,+    ''Monoid.Last,+    ''Monoid.Sum,+    ''Monoid.Product,+    ''Down,+    ''ExceptT,+    ''MaybeT,+    ''WriterLazy.WriterT,+    ''WriterStrict.WriterT+  ]+  [''EvalSym, ''EvalSym1]++-- 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 (EvalSym a, EvalSym b) => EvalSym (a =-> b) where+  evalSym fillDefault model (TabularFun s t) =+    TabularFun+      (evalSym fillDefault model s)+      (evalSym fillDefault model t)++instance (EvalSym (SymType b)) => EvalSym (a --> b) where+  evalSym fillDefault model (GeneralFun s t) =+    GeneralFun s $+      evalTerm fillDefault model (HS.singleton $ someTypedSymbol s) t++instance (EvalSym a) => EvalSym (AsKey a) where+  evalSym fillDefault model (AsKey t) = AsKey $ evalSym fillDefault model t+  {-# INLINE evalSym #-}++instance (EvalSym1 f, EvalSym a) => EvalSym (AsKey1 f a) where+  evalSym fillDefault model (AsKey1 t) = AsKey1 $ evalSym fillDefault model t++instance (EvalSym1 a) => EvalSym1 (AsKey1 a) where+  liftEvalSym f fillDefault model (AsKey1 t) = AsKey1 $ liftEvalSym f fillDefault model t+  {-# INLINE liftEvalSym #-}
+ src/Grisette/Internal/Internal/Impl/Core/Data/Class/ExtractSym.hs view
@@ -0,0 +1,409 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- {-# OPTIONS_GHC -ddump-splices -ddump-to-file -ddump-file-prefix=extractsym #-}++-- |+-- Module      :   Grisette.Internal.Internal.Impl.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.Internal.Impl.Core.Data.Class.ExtractSym () where++import Control.Exception (ArithException)+import Control.Monad.Except (ExceptT)+import Control.Monad.Identity+  ( Identity,+    IdentityT (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.Compose (Compose (Compose))+import Data.Functor.Const (Const)+import Data.Functor.Product (Product)+import Data.Functor.Sum (Sum)+import qualified Data.HashSet as HS+import Data.Int (Int16, Int32, Int64, Int8)+import Data.Monoid (Alt, Ap)+import qualified Data.Monoid as Monoid+import Data.Ord (Down)+import Data.Ratio (Ratio, denominator, numerator)+import qualified Data.Text as T+import Data.Typeable (Proxy, type (:~~:) (HRefl))+import Data.Word (Word16, Word32, Word64, Word8)+import GHC.TypeNats (KnownNat, type (<=))+import Generics.Deriving+  ( Default (Default),+    Default1 (Default1),+    K1 (K1),+    M1 (M1),+    Par1 (Par1),+    Rec1 (Rec1),+    U1,+    V1,+    type (:*:),+    type (:+:),+    type (:.:) (Comp1),+  )+import Grisette.Internal.Core.Control.Exception+  ( AssertionError,+    VerificationConditions,+  )+import Grisette.Internal.Core.Data.Class.AsKey (AsKey (AsKey), AsKey1 (AsKey1))+import Grisette.Internal.Internal.Decl.Core.Data.Class.ExtractSym+  ( ExtractSym (extractSymMaybe),+    ExtractSym1 (liftExtractSymMaybe),+    ExtractSym2,+    extractSymMaybe1,+  )+import Grisette.Internal.SymPrim.AlgReal (AlgReal)+import Grisette.Internal.SymPrim.BV (IntN, WordN)+import Grisette.Internal.SymPrim.FP+  ( FP,+    FPRoundingMode,+    NotRepresentableFPError,+    ValidFP,+  )+import Grisette.Internal.SymPrim.GeneralFun (type (-->) (GeneralFun))+import Grisette.Internal.SymPrim.Prim.Model+  ( SymbolSet (SymbolSet),+  )+import Grisette.Internal.SymPrim.Prim.Term+  ( IsSymbolKind (decideSymbolKind),+    SymRep (SymType),+    someTypedSymbol,+  )+import Grisette.Internal.SymPrim.Prim.TermUtils (extractTerm)+import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal (SymAlgReal))+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 (=->) (TabularFun))+import Grisette.Internal.TH.Derivation.Derive (derive)++-- $setup+-- >>> import Grisette.Core+-- >>> import Grisette.SymPrim+-- >>> import Grisette.Lib.Base+-- >>> import Data.HashSet as HashSet+-- >>> import Data.List (sort)++#define CONCRETE_EXTRACT_SYMBOLICS(type) \+instance ExtractSym type where \+  extractSymMaybe _ = return mempty++#define CONCRETE_EXTRACT_SYMBOLICS_BV(type) \+instance (KnownNat n, 1 <= n) => ExtractSym (type n) where \+  extractSymMaybe _ = return 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)+CONCRETE_EXTRACT_SYMBOLICS(AlgReal)+#endif++instance ExtractSym (Proxy a) where+  extractSymMaybe _ = return mempty+  {-# INLINE extractSymMaybe #-}++instance ExtractSym1 Proxy where+  liftExtractSymMaybe _ _ = return mempty+  {-# INLINE liftExtractSymMaybe #-}++instance (ExtractSym a) => ExtractSym (Ratio a) where+  extractSymMaybe a =+    extractSymMaybe (numerator a) <> extractSymMaybe (denominator a)+  {-# INLINE extractSymMaybe #-}++instance (ValidFP eb sb) => ExtractSym (FP eb sb) where+  extractSymMaybe _ = return mempty++#define EXTRACT_SYMBOLICS_SIMPLE(symtype) \+instance ExtractSym symtype where \+  extractSymMaybe :: \+    forall knd. (IsSymbolKind knd) => symtype -> Maybe (SymbolSet knd); \+  extractSymMaybe (symtype t) = \+    case decideSymbolKind @knd of\+      Left HRefl -> SymbolSet <$> extractTerm HS.empty t; \+      Right HRefl -> SymbolSet <$> extractTerm HS.empty t++#define EXTRACT_SYMBOLICS_BV(symtype) \+instance (KnownNat n, 1 <= n) => ExtractSym (symtype n) where \+  extractSymMaybe :: \+    forall knd. (IsSymbolKind knd) => symtype n -> Maybe (SymbolSet knd); \+  extractSymMaybe (symtype t) = \+    case decideSymbolKind @knd of\+      Left HRefl -> SymbolSet <$> extractTerm HS.empty t; \+      Right HRefl -> SymbolSet <$> extractTerm HS.empty t++#define EXTRACT_SYMBOLICS_FUN(op, cons) \+instance ExtractSym (op sa sb) where \+  extractSymMaybe :: \+    forall knd. (IsSymbolKind knd) => op sa sb -> Maybe (SymbolSet knd); \+  extractSymMaybe (cons t) = \+    case decideSymbolKind @knd of \+      Left HRefl -> Nothing; \+      Right HRefl -> SymbolSet <$> extractTerm HS.empty t++#if 1+EXTRACT_SYMBOLICS_SIMPLE(SymBool)+EXTRACT_SYMBOLICS_SIMPLE(SymInteger)+EXTRACT_SYMBOLICS_SIMPLE(SymFPRoundingMode)+EXTRACT_SYMBOLICS_SIMPLE(SymAlgReal)+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+  extractSymMaybe ::+    forall knd. (IsSymbolKind knd) => SymFP eb fb -> Maybe (SymbolSet knd)+  extractSymMaybe (SymFP t) =+    case decideSymbolKind @knd of+      Left HRefl -> SymbolSet <$> extractTerm HS.empty t+      Right HRefl -> SymbolSet <$> extractTerm HS.empty t++derive+  [ ''(),+    ''AssertionError,+    ''VerificationConditions,+    ''NotRepresentableFPError,+    ''ArithException+  ]+  [''ExtractSym]++derive+  [ ''Either,+    ''(,),+    ''(,,),+    ''(,,,),+    ''(,,,,),+    ''(,,,,,),+    ''(,,,,,,),+    ''(,,,,,,,),+    ''(,,,,,,,,),+    ''(,,,,,,,,,),+    ''(,,,,,,,,,,),+    ''(,,,,,,,,,,,),+    ''(,,,,,,,,,,,,),+    ''(,,,,,,,,,,,,,),+    ''(,,,,,,,,,,,,,,)+  ]+  [''ExtractSym, ''ExtractSym1, ''ExtractSym2]++derive+  [ ''[],+    ''Maybe,+    ''Identity,+    ''Monoid.Dual,+    ''Monoid.First,+    ''Monoid.Last,+    ''Monoid.Sum,+    ''Monoid.Product,+    ''Down,+    ''ExceptT,+    ''MaybeT,+    ''WriterLazy.WriterT,+    ''WriterStrict.WriterT+  ]+  [''ExtractSym, ''ExtractSym1]++-- IdentityT+instance+  (ExtractSym1 m, ExtractSym a) =>+  ExtractSym (IdentityT m a)+  where+  extractSymMaybe = extractSymMaybe1+  {-# INLINE extractSymMaybe #-}++instance (ExtractSym1 m) => ExtractSym1 (IdentityT m) where+  liftExtractSymMaybe f (IdentityT v) = liftExtractSymMaybe f v+  {-# INLINE liftExtractSymMaybe #-}++-- 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+  liftExtractSymMaybe f (Compose l) =+    liftExtractSymMaybe (liftExtractSymMaybe f) l+  {-# INLINE liftExtractSymMaybe #-}++-- 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)++instance (ExtractSym a, ExtractSym b) => ExtractSym (a =-> b) where+  extractSymMaybe (TabularFun s t) =+    extractSymMaybe s <> extractSymMaybe t++instance (ExtractSym (SymType b)) => ExtractSym (a --> b) where+  extractSymMaybe :: forall knd. (IsSymbolKind knd) => (a --> b) -> Maybe (SymbolSet knd)+  extractSymMaybe (GeneralFun t f) =+    case decideSymbolKind @knd of+      Left HRefl -> Nothing+      Right HRefl -> SymbolSet <$> extractTerm (HS.singleton $ someTypedSymbol t) f++instance (ExtractSym a) => ExtractSym (AsKey a) where+  extractSymMaybe (AsKey t) = extractSymMaybe t+  {-# INLINE extractSymMaybe #-}++instance (ExtractSym1 f, ExtractSym a) => ExtractSym (AsKey1 f a) where+  extractSymMaybe (AsKey1 t) = extractSymMaybe1 t+  {-# INLINE extractSymMaybe #-}++instance (ExtractSym1 a) => ExtractSym1 (AsKey1 a) where+  liftExtractSymMaybe f (AsKey1 t) = liftExtractSymMaybe f t+  {-# INLINE liftExtractSymMaybe #-}
+ src/Grisette/Internal/Internal/Impl/Core/Data/Class/Mergeable.hs view
@@ -0,0 +1,518 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- {-# OPTIONS_GHC -ddump-splices -ddump-to-file -ddump-file-prefix=mergeable1 #-}++-- |+-- Module      :   Grisette.Internal.Internal.Impl.Core.Data.Class.Mergeable+-- 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.Internal.Impl.Core.Data.Class.Mergeable () where++import Control.Exception (ArithException)+import Control.Monad.Cont (ContT (ContT))+import Control.Monad.Except (ExceptT)+import Control.Monad.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)+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, 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.Monoid (Alt, Ap, Endo (Endo, appEndo))+import qualified Data.Monoid as Monoid+import Data.Ord (Down)+import Data.Ratio (Ratio)+import qualified Data.Text as T+import Data.Typeable (Proxy, Typeable)+import Data.Word (Word16, Word32, Word64, Word8)+import GHC.TypeNats (KnownNat, type (+), type (<=))+import Generics.Deriving+  ( Default (Default),+    Default1 (Default1),+    K1 (K1),+    M1 (M1),+    Par1 (Par1),+    Rec1 (Rec1),+    U1,+    V1,+    (:.:) (Comp1),+    type (:*:),+    type (:+:),+  )+import Grisette.Internal.Core.Control.Exception+  ( AssertionError,+    VerificationConditions,+  )+import Grisette.Internal.Core.Data.Class.BitCast (bitCastOrCanonical)+import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp (symIte))+import Grisette.Internal.Internal.Decl.Core.Data.Class.Mergeable+  ( Mergeable (rootStrategy),+    Mergeable1 (liftRootStrategy),+    Mergeable2 (liftRootStrategy2),+    Mergeable3 (liftRootStrategy3),+    MergingStrategy (NoStrategy, SimpleStrategy, SortedStrategy),+    StrategyList (StrategyList),+    buildStrategyList,+    rootStrategy1,+    wrapStrategy,+  )+import Grisette.Internal.SymPrim.AlgReal (AlgReal, AlgRealPoly, RealPoint)+import Grisette.Internal.SymPrim.BV+  ( IntN,+    WordN,+  )+import Grisette.Internal.SymPrim.FP+  ( FP,+    FPRoundingMode,+    NotRepresentableFPError,+    ValidFP,+    withValidFPProofs,+  )+import Grisette.Internal.SymPrim.GeneralFun (type (-->))+import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal)+import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN)+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.Derivation.Derive (derive)+import Unsafe.Coerce (unsafeCoerce)++#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_BV(WordN)+CONCRETE_ORD_MERGEABLE_BV(IntN)+#endif++instance Mergeable (Proxy a) where+  rootStrategy = SimpleStrategy $ \_ t _ -> t++instance Mergeable1 Proxy where+  liftRootStrategy _ = SimpleStrategy $ \_ t _ -> t+  {-# INLINE liftRootStrategy #-}++instance (Integral a, Typeable a) => Mergeable (Ratio a) where+  rootStrategy =+    let sub = SimpleStrategy $ \_ t _ -> t+     in SortedStrategy id $ const sub++instance (ValidFP eb sb) => Mergeable (FP eb sb) where+  rootStrategy =+    let sub = SimpleStrategy $ \_ t _ -> t+     in withValidFPProofs @eb @sb+          $ SortedStrategy+            (\fp -> (bitCastOrCanonical fp :: WordN (eb + sb)))+          $ const sub++instance Mergeable (a =-> b) where+  rootStrategy = NoStrategy++instance Mergeable (a --> b) where+  rootStrategy = SimpleStrategy symIte++#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, consop) \+instance Mergeable (op sa sb) where \+  rootStrategy = SimpleStrategy symIte++#if 1+MERGEABLE_SIMPLE(SymInteger)+MERGEABLE_SIMPLE(SymFPRoundingMode)+MERGEABLE_SIMPLE(SymAlgReal)+MERGEABLE_BV(SymIntN)+MERGEABLE_BV(SymWordN)+MERGEABLE_FUN((=->), (=~>), SymTabularFun)+MERGEABLE_FUN((-->), (-~>), SymGeneralFun)+#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 #-}++-- 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 #-}++instance Mergeable () where+  rootStrategy = SimpleStrategy $ \_ t _ -> t++derive+  [ ''Either,+    ''(,)+  ]+  [''Mergeable, ''Mergeable1, ''Mergeable2]++derive+  [ ''(,,),+    ''(,,,),+    ''(,,,,),+    ''(,,,,,),+    ''(,,,,,,),+    ''(,,,,,,,),+    ''(,,,,,,,,),+    ''(,,,,,,,,,),+    ''(,,,,,,,,,,),+    ''(,,,,,,,,,,,),+    ''(,,,,,,,,,,,,),+    ''(,,,,,,,,,,,,,),+    ''(,,,,,,,,,,,,,,)+  ]+  [''Mergeable, ''Mergeable1, ''Mergeable2, ''Mergeable3]++derive+  [ ''Maybe,+    ''Identity,+    ''Monoid.Dual,+    ''Monoid.Sum,+    ''Monoid.Product,+    ''Monoid.First,+    ''Monoid.Last,+    ''Down,+    ''MaybeT,+    ''ExceptT,+    ''WriterLazy.WriterT,+    ''WriterStrict.WriterT,+    ''StateLazy.StateT,+    ''StateStrict.StateT+  ]+  [''Mergeable, ''Mergeable1]++derive+  [ ''AssertionError,+    ''VerificationConditions,+    ''ArithException,+    ''NotRepresentableFPError,+    ''AlgRealPoly,+    ''RealPoint,+    ''AlgReal+  ]+  [''Mergeable]++-- Reader -- separately implemented as we don't need Mergeable s+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 -- separately implemented as we don't need Mergeable a+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 -- separately implemented as we don't need Mergeable r+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)
+ src/Grisette/Internal/Internal/Impl/Core/Data/Class/PPrint.hs view
@@ -0,0 +1,424 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.Internal.Impl.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.Internal.Impl.Core.Data.Class.PPrint () where++import Control.Exception (ArithException)+import Control.Monad.Except (ExceptT)+import Control.Monad.Identity+  ( Identity (Identity),+    IdentityT (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 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.Monoid (Alt, Ap)+import qualified Data.Monoid as Monoid+import Data.Ord (Down)+import Data.Proxy (Proxy)+import Data.Ratio (Ratio, denominator, numerator)+import qualified Data.Text as T+import Data.Word (Word16, Word32, Word64, Word8)+import GHC.Generics+  ( K1 (K1),+    M1 (M1),+    Par1 (Par1),+    Rec1 (Rec1),+    V1,+    (:.:) (Comp1),+    type (:*:),+  )+import GHC.Real (ratioPrec, ratioPrec1)+import GHC.TypeLits (KnownNat, type (<=))+import Generics.Deriving+  ( Default (Default),+    Default1 (Default1),+    U1,+    (:+:),+  )+import Grisette.Internal.Core.Control.Exception+  ( AssertionError,+    VerificationConditions,+  )+import Grisette.Internal.Core.Data.Class.AsKey (AsKey (AsKey), AsKey1 (AsKey1))+import Grisette.Internal.Core.Data.Symbol (Identifier, Symbol)+import Grisette.Internal.Internal.Decl.Core.Data.Class.PPrint+  ( Doc,+    PPrint (pformat, pformatList, pformatPrec),+    PPrint1 (liftPFormatList, liftPFormatPrec),+    PPrint2 (liftPFormatList2, liftPFormatPrec2),+    Pretty (pretty),+    condEnclose,+    pformatListLike,+    pformatPrec1,+    pformatWithConstructor,+    viaShow,+    viaShowsPrec,+  )+import Grisette.Internal.SymPrim.AlgReal (AlgReal)+import Grisette.Internal.SymPrim.BV (IntN, WordN)+import Grisette.Internal.SymPrim.FP+  ( FP,+    FPRoundingMode,+    NotRepresentableFPError,+    ValidFP,+  )+import Grisette.Internal.SymPrim.GeneralFun (type (-->))+import Grisette.Internal.SymPrim.Prim.Internal.Term (Term)+import Grisette.Internal.SymPrim.Prim.Model+  ( Model (Model),+    SymbolSet (SymbolSet),+  )+import Grisette.Internal.SymPrim.Prim.SomeTerm (SomeTerm (SomeTerm))+import Grisette.Internal.SymPrim.Prim.Term+  ( ModelValue,+    SomeTypedSymbol (SomeTypedSymbol),+    TypedSymbol (unTypedSymbol),+    prettyPrintTerm,+  )+import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal (SymAlgReal))+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.Derivation.Derive (derive)++#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)+FORMAT_SIMPLE(AlgReal)+#endif++instance PPrint (Proxy a) where+  pformatPrec _ _ = "Proxy"+  {-# INLINE pformatPrec #-}++instance PPrint1 Proxy where+  liftPFormatPrec _ _ _ _ = "Proxy"+  {-# INLINE liftPFormatPrec #-}++instance (PPrint a) => PPrint (Ratio a) where+  pformatPrec p r =+    condEnclose (p > ratioPrec) "(" ")" $+      pformatPrec ratioPrec1 (numerator r)+        <> "%"+        <> pformatPrec ratioPrec1 (denominator r)++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++instance (Show a, Show b) => PPrint (a =-> b) where+  pformat = viaShow++instance PPrint (a --> b) where+  pformat = viaShow++instance PPrint (Term t) where+  pformat = prettyPrintTerm++instance PPrint SomeTerm where+  pformat (SomeTerm t) = prettyPrintTerm t++-- 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 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_SIMPLE(SymAlgReal)+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++derive+  [ ''(),+    ''AssertionError,+    ''VerificationConditions,+    ''NotRepresentableFPError,+    ''ArithException+  ]+  [''PPrint]++derive+  [ ''Either,+    ''(,),+    ''(,,),+    ''(,,,),+    ''(,,,,),+    ''(,,,,,),+    ''(,,,,,,),+    ''(,,,,,,,),+    ''(,,,,,,,,),+    ''(,,,,,,,,,),+    ''(,,,,,,,,,,),+    ''(,,,,,,,,,,,),+    ''(,,,,,,,,,,,,),+    ''(,,,,,,,,,,,,,),+    ''(,,,,,,,,,,,,,,)+  ]+  [''PPrint, ''PPrint1, ''PPrint2]++derive+  [ ''Maybe,+    ''Monoid.Dual,+    ''Monoid.First,+    ''Monoid.Last,+    ''Monoid.Sum,+    ''Monoid.Product,+    ''Down,+    ''MaybeT,+    ''ExceptT,+    ''WriterLazy.WriterT,+    ''WriterStrict.WriterT+  ]+  [''PPrint, ''PPrint1]++-- Identity+instance (PPrint a) => PPrint (Identity a) where+  pformatPrec = pformatPrec1++instance PPrint1 Identity where+  liftPFormatPrec f _ n (Identity a) = f n 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)++instance (PPrint a) => PPrint (HS.HashSet a) where+  pformatPrec = pformatPrec1++instance PPrint1 HS.HashSet where+  liftPFormatPrec p l n s =+    pformatWithConstructor n "HashSet" [liftPFormatPrec p l 11 $ HS.toList s]++instance (PPrint k, PPrint v) => PPrint (HM.HashMap k v) where+  pformatPrec = pformatPrec1++instance (PPrint k) => PPrint1 (HM.HashMap k) where+  liftPFormatPrec = liftPFormatPrec2 pformatPrec pformatList++instance PPrint2 HM.HashMap where+  liftPFormatPrec2 pk lk pv lv n s =+    pformatWithConstructor+      n+      "HashMap"+      [ liftPFormatPrec+          (liftPFormatPrec2 pk lk pv lv)+          (liftPFormatList2 pk lk pv lv)+          11+          $ HM.toList s+      ]++instance PPrint Identifier where+  pformat = viaShow++instance PPrint Symbol where+  pformat = viaShow++instance PPrint (TypedSymbol knd t) where+  pformat = viaShow++instance PPrint (SomeTypedSymbol knd) where+  pformat = viaShow++instance PPrint ModelValue where+  pformat = viaShow++instance PPrint Model where+  pformatPrec n (Model m) =+    pformatWithConstructor n "Model" [bodyFormatted]+    where+      pformatSymbolWithoutType :: SomeTypedSymbol knd -> Doc ann+      pformatSymbolWithoutType (SomeTypedSymbol s) = pformat $ unTypedSymbol s+      pformatPair :: (SomeTypedSymbol knd, ModelValue) -> Doc ann+      pformatPair (s, v) = pformatSymbolWithoutType s <> " -> " <> pformat v+      bodyFormatted = pformatListLike "{" "}" $ pformatPair <$> HM.toList m++instance PPrint (SymbolSet knd) where+  pformatPrec n (SymbolSet s) =+    pformatWithConstructor+      n+      "SymbolSet"+      [pformatListLike "{" "}" $ pformat <$> HS.toList s]++instance (PPrint a) => PPrint (AsKey a) where+  pformatPrec p (AsKey t) = pformatPrec p t++instance (PPrint1 f, PPrint a) => PPrint (AsKey1 f a) where+  pformatPrec p (AsKey1 t) = pformatPrec p t++instance (PPrint1 f) => PPrint1 (AsKey1 f) where+  liftPFormatPrec f l n (AsKey1 t) = liftPFormatPrec f l n t
+ src/Grisette/Internal/Internal/Impl/Core/Data/Class/SafeDiv.hs view
@@ -0,0 +1,340 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.Internal.Impl.Core.Data.Class.SafeDiv+-- 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.Internal.Impl.Core.Data.Class.SafeDiv () where++import Control.Exception (ArithException (DivideByZero, Overflow))+import Control.Monad.Except (MonadError (throwError))+import Data.Bifunctor (Bifunctor (bimap))+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.Class.Union (MonadUnion)+import Grisette.Internal.Core.Data.Class.AsKey (AsKey (AsKey))+import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp (symIte))+import Grisette.Internal.Core.Data.Class.LogicalOp (LogicalOp ((.&&)))+import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable)+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.Internal.Decl.Core.Data.Class.SafeDiv+  ( DivOr (divModOr, divOr, modOr, quotOr, quotRemOr, remOr),+    SafeDiv (safeDiv, safeDivMod, safeMod, safeQuot, safeQuotRem, safeRem),+  )+import Grisette.Internal.SymPrim.BV (IntN, WordN)+import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN)+import Grisette.Internal.SymPrim.SymInteger (SymInteger)++concreteDivOrHelper ::+  (Integral a) =>+  (a -> a -> r) ->+  r ->+  a ->+  a ->+  r+concreteDivOrHelper f d l r+  | r == 0 = d+  | otherwise = f l r++concreteSafeDivHelper ::+  (MonadError ArithException m, TryMerge m, Integral a, Mergeable r) =>+  (a -> a -> r) ->+  a ->+  a ->+  m r+concreteSafeDivHelper f l r+  | r == 0 = tryMerge $ throwError DivideByZero+  | otherwise = mrgSingle $ f l r++concreteSignedBoundedDivOrHelper ::+  ( Integral a,+    Bounded a,+    Mergeable r+  ) =>+  (a -> a -> r) ->+  r ->+  a ->+  a ->+  r+concreteSignedBoundedDivOrHelper f d l r+  | r == 0 = d+  | l == minBound && r == -1 = d+  | otherwise = f l r++concreteSignedBoundedSafeDivHelper ::+  ( MonadError ArithException m,+    TryMerge m,+    Integral a,+    Bounded a,+    Mergeable r+  ) =>+  (a -> a -> r) ->+  a ->+  a ->+  m r+concreteSignedBoundedSafeDivHelper 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+#define QRIGHT(a) QID(a)'++#define QRIGHTT(a) QID(a)' t'+#define QRIGHTU(a) QID(a)' _'++#define DIVISION_OR_CONCRETE(type) \+instance DivOr type where \+  divOr = concreteDivOrHelper div; \+  modOr = concreteDivOrHelper mod; \+  divModOr = concreteDivOrHelper divMod; \+  quotOr = concreteDivOrHelper quot; \+  remOr = concreteDivOrHelper rem; \+  quotRemOr = concreteDivOrHelper quotRem++#define SAFE_DIVISION_CONCRETE(type) \+instance (MonadError ArithException m, TryMerge m) => \+  SafeDiv ArithException type m where \+  safeDiv = concreteSafeDivHelper div; \+  safeMod = concreteSafeDivHelper mod; \+  safeDivMod = concreteSafeDivHelper divMod; \+  safeQuot = concreteSafeDivHelper quot; \+  safeRem = concreteSafeDivHelper rem; \+  safeQuotRem = concreteSafeDivHelper quotRem++#define DIVISION_OR_CONCRETE_SIGNED_BOUNDED(type) \+instance DivOr type where \+  divOr = concreteSignedBoundedDivOrHelper div; \+  modOr = concreteDivOrHelper mod; \+  divModOr = concreteSignedBoundedDivOrHelper divMod; \+  quotOr = concreteSignedBoundedDivOrHelper quot; \+  remOr = concreteDivOrHelper rem; \+  quotRemOr = concreteSignedBoundedDivOrHelper quotRem++#define SAFE_DIVISION_CONCRETE_SIGNED_BOUNDED(type) \+instance (MonadError ArithException m, TryMerge m) => \+  SafeDiv ArithException type m where \+  safeDiv = concreteSignedBoundedSafeDivHelper div; \+  safeMod = concreteSafeDivHelper mod; \+  safeDivMod = concreteSignedBoundedSafeDivHelper divMod; \+  safeQuot = concreteSignedBoundedSafeDivHelper quot; \+  safeRem = concreteSafeDivHelper rem; \+  safeQuotRem = concreteSignedBoundedSafeDivHelper quotRem++#if 1+DIVISION_OR_CONCRETE(Integer)+SAFE_DIVISION_CONCRETE(Integer)+DIVISION_OR_CONCRETE_SIGNED_BOUNDED(Int8)+SAFE_DIVISION_CONCRETE_SIGNED_BOUNDED(Int8)+DIVISION_OR_CONCRETE_SIGNED_BOUNDED(Int16)+SAFE_DIVISION_CONCRETE_SIGNED_BOUNDED(Int16)+DIVISION_OR_CONCRETE_SIGNED_BOUNDED(Int32)+SAFE_DIVISION_CONCRETE_SIGNED_BOUNDED(Int32)+DIVISION_OR_CONCRETE_SIGNED_BOUNDED(Int64)+SAFE_DIVISION_CONCRETE_SIGNED_BOUNDED(Int64)+DIVISION_OR_CONCRETE_SIGNED_BOUNDED(Int)+SAFE_DIVISION_CONCRETE_SIGNED_BOUNDED(Int)+DIVISION_OR_CONCRETE(Word8)+SAFE_DIVISION_CONCRETE(Word8)+DIVISION_OR_CONCRETE(Word16)+SAFE_DIVISION_CONCRETE(Word16)+DIVISION_OR_CONCRETE(Word32)+SAFE_DIVISION_CONCRETE(Word32)+DIVISION_OR_CONCRETE(Word64)+SAFE_DIVISION_CONCRETE(Word64)+DIVISION_OR_CONCRETE(Word)+SAFE_DIVISION_CONCRETE(Word)+++#endif++instance (KnownNat n, 1 <= n) => DivOr (IntN n) where+  divOr = concreteSignedBoundedDivOrHelper div+  modOr = concreteDivOrHelper mod+  divModOr = concreteSignedBoundedDivOrHelper divMod+  quotOr = concreteSignedBoundedDivOrHelper quot+  remOr = concreteDivOrHelper rem+  quotRemOr = concreteSignedBoundedDivOrHelper quotRem++instance+  (MonadError ArithException m, TryMerge m, KnownNat n, 1 <= n) =>+  SafeDiv ArithException (IntN n) m+  where+  safeDiv = concreteSignedBoundedSafeDivHelper div+  safeMod = concreteSafeDivHelper mod+  safeDivMod = concreteSignedBoundedSafeDivHelper divMod+  safeQuot = concreteSignedBoundedSafeDivHelper quot+  safeRem = concreteSafeDivHelper rem+  safeQuotRem = concreteSignedBoundedSafeDivHelper quotRem++instance (KnownNat n, 1 <= n) => DivOr (WordN n) where+  divOr = concreteDivOrHelper div+  modOr = concreteDivOrHelper mod+  divModOr = concreteDivOrHelper divMod+  quotOr = concreteDivOrHelper quot+  remOr = concreteDivOrHelper rem+  quotRemOr = concreteDivOrHelper quotRem++instance+  (MonadError ArithException m, TryMerge m, KnownNat n, 1 <= n) =>+  SafeDiv ArithException (WordN n) m+  where+  safeDiv = concreteSafeDivHelper div+  safeMod = concreteSafeDivHelper mod+  safeDivMod = concreteSafeDivHelper divMod+  safeQuot = concreteSafeDivHelper quot+  safeRem = concreteSafeDivHelper rem+  safeQuotRem = concreteSafeDivHelper quotRem++#define DIVISION_OR_SYMBOLIC_FUNC(name, op) \+name d l r = symIte (r .== con 0) d (op l r)++#define DIVISION_OR_SYMBOLIC_FUNC2(name, op1, op2) \+name (dd, dm) l r = \+  (symIte (r .== con 0) dd (op1 l r), symIte (r .== con 0) dm (op2 l r))++#define SAFE_DIVISION_SYMBOLIC_FUNC(name, op) \+name l r = mrgIf (r .== con 0) (throwError DivideByZero) (mrgSingle $ op l r)++#define SAFE_DIVISION_SYMBOLIC_FUNC2(name, op1, op2) \+name l r = mrgIf (r .== con 0) (throwError DivideByZero) (mrgSingle (op1 l r, op2 l r))++#if 1+instance DivOr SymInteger where+  DIVISION_OR_SYMBOLIC_FUNC(divOr, div)+  DIVISION_OR_SYMBOLIC_FUNC(modOr, mod)+  DIVISION_OR_SYMBOLIC_FUNC(quotOr, quot)+  DIVISION_OR_SYMBOLIC_FUNC(remOr, rem)+  DIVISION_OR_SYMBOLIC_FUNC2(divModOr, div, mod)+  DIVISION_OR_SYMBOLIC_FUNC2(quotRemOr, quot, rem)+instance+  (MonadUnion m, MonadError ArithException m) =>+  SafeDiv ArithException SymInteger m where+  SAFE_DIVISION_SYMBOLIC_FUNC(safeDiv, div)+  SAFE_DIVISION_SYMBOLIC_FUNC(safeMod, mod)+  SAFE_DIVISION_SYMBOLIC_FUNC(safeQuot, quot)+  SAFE_DIVISION_SYMBOLIC_FUNC(safeRem, rem)+  SAFE_DIVISION_SYMBOLIC_FUNC2(safeDivMod, div, mod)+  SAFE_DIVISION_SYMBOLIC_FUNC2(safeQuotRem, quot, rem)+#endif++#define DIVISION_OR_SYMBOLIC_FUNC_BOUNDED_SIGNED(name, op) \+name d l r = \+  symIte (r .== con 0) d $ \+    symIte (r .== con (-1) .&& l .== con minBound) d (op l r)++#define DIVISION_OR_SYMBOLIC_FUNC2_BOUNDED_SIGNED(name, op1, op2) \+name (dd, dr) l r = \+  ( symIte (r .== con 0) dd $ \+      symIte (r .== con (-1) .&& l .== con minBound) dd (op1 l r), \+    symIte (r .== con 0) dr $ \+      symIte (r .== con (-1) .&& l .== con minBound) dr (op2 l r) \+  )++#define SAFE_DIVISION_SYMBOLIC_FUNC_BOUNDED_SIGNED(name, op) \+name l r = \+  mrgIf (r .== con 0) (throwError DivideByZero) $ \+    mrgIf (r .== con (-1) .&& l .== con minBound) \+      (throwError Overflow) \+      (mrgSingle $ op l r)++#define SAFE_DIVISION_SYMBOLIC_FUNC2_BOUNDED_SIGNED(name, op1, op2) \+name l r = \+  mrgIf (r .== con 0) (throwError DivideByZero) $ \+    mrgIf (r .== con (-1) .&& l .== con minBound) \+      (throwError Overflow) \+      (mrgSingle (op1 l r, op2 l r))++#if 1+instance (KnownNat n, 1 <= n) => DivOr (SymIntN n) where+  DIVISION_OR_SYMBOLIC_FUNC_BOUNDED_SIGNED(divOr, div)+  DIVISION_OR_SYMBOLIC_FUNC(modOr, mod)+  DIVISION_OR_SYMBOLIC_FUNC_BOUNDED_SIGNED(quotOr, quot)+  DIVISION_OR_SYMBOLIC_FUNC(remOr, rem)+  DIVISION_OR_SYMBOLIC_FUNC2_BOUNDED_SIGNED(divModOr, div, mod)+  DIVISION_OR_SYMBOLIC_FUNC2_BOUNDED_SIGNED(quotRemOr, quot, rem)+instance+  (MonadError ArithException m, MonadUnion m, KnownNat n, 1 <= n) =>+  SafeDiv ArithException (SymIntN n) m where+  SAFE_DIVISION_SYMBOLIC_FUNC_BOUNDED_SIGNED(safeDiv, div)+  SAFE_DIVISION_SYMBOLIC_FUNC(safeMod, mod)+  SAFE_DIVISION_SYMBOLIC_FUNC_BOUNDED_SIGNED(safeQuot, quot)+  SAFE_DIVISION_SYMBOLIC_FUNC(safeRem, rem)+  SAFE_DIVISION_SYMBOLIC_FUNC2_BOUNDED_SIGNED(safeDivMod, div, mod)+  SAFE_DIVISION_SYMBOLIC_FUNC2_BOUNDED_SIGNED(safeQuotRem, quot, rem)+#endif++#if 1+instance (KnownNat n, 1 <= n) => DivOr (SymWordN n) where+  DIVISION_OR_SYMBOLIC_FUNC(divOr, div)+  DIVISION_OR_SYMBOLIC_FUNC(modOr, mod)+  DIVISION_OR_SYMBOLIC_FUNC(quotOr, quot)+  DIVISION_OR_SYMBOLIC_FUNC(remOr, rem)+  DIVISION_OR_SYMBOLIC_FUNC2(divModOr, div, mod)+  DIVISION_OR_SYMBOLIC_FUNC2(quotRemOr, quot, rem)+instance+  (MonadError ArithException m, MonadUnion m, KnownNat n, 1 <= n) =>+  SafeDiv ArithException (SymWordN n) m where+  SAFE_DIVISION_SYMBOLIC_FUNC(safeDiv, div)+  SAFE_DIVISION_SYMBOLIC_FUNC(safeMod, mod)+  SAFE_DIVISION_SYMBOLIC_FUNC(safeQuot, quot)+  SAFE_DIVISION_SYMBOLIC_FUNC(safeRem, rem)+  SAFE_DIVISION_SYMBOLIC_FUNC2(safeDivMod, div, mod)+  SAFE_DIVISION_SYMBOLIC_FUNC2(safeQuotRem, quot, rem)+#endif++instance (DivOr a) => DivOr (AsKey a) where+  divOr (AsKey def) (AsKey n) (AsKey d) = AsKey $ divOr def n d+  modOr (AsKey def) (AsKey n) (AsKey d) = AsKey $ modOr def n d+  divModOr (AsKey defDiv, AsKey defMod) (AsKey n) (AsKey d) =+    bimap AsKey AsKey $ divModOr (defDiv, defMod) n d+  quotOr (AsKey def) (AsKey n) (AsKey d) = AsKey $ quotOr def n d+  remOr (AsKey def) (AsKey n) (AsKey d) = AsKey $ remOr def n d+  quotRemOr (AsKey defDiv, AsKey defRem) (AsKey n) (AsKey d) =+    bimap AsKey AsKey $ quotRemOr (defDiv, defRem) n d++instance (SafeDiv e a m) => SafeDiv e (AsKey a) m where+  safeDiv (AsKey n) (AsKey d) = do+    r <- safeDiv n d+    mrgSingle $ AsKey r+  safeMod (AsKey n) (AsKey d) = do+    r <- safeMod n d+    mrgSingle $ AsKey r+  safeDivMod (AsKey n) (AsKey d) = do+    (rd, rm) <- safeDivMod n d+    mrgSingle (AsKey rd, AsKey rm)+  safeQuot (AsKey n) (AsKey d) = do+    r <- safeQuot n d+    mrgSingle $ AsKey r+  safeRem (AsKey n) (AsKey d) = do+    r <- safeRem n d+    mrgSingle $ AsKey r+  safeQuotRem (AsKey n) (AsKey d) = do+    (rq, rr) <- safeQuotRem n d+    mrgSingle (AsKey rq, AsKey rr)
+ src/Grisette/Internal/Internal/Impl/Core/Data/Class/SimpleMergeable.hs view
@@ -0,0 +1,579 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.Internal.Impl.Core.Data.Class.SimpleMergeable+-- 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.Internal.Impl.Core.Data.Class.SimpleMergeable () where++import Control.Monad.Except (ExceptT (ExceptT))+import Control.Monad.Identity+  ( Identity,+    IdentityT (IdentityT),+  )+import qualified Control.Monad.RWS.Lazy as RWSLazy+import qualified Control.Monad.RWS.Strict as RWSStrict+import Control.Monad.Reader (ReaderT (ReaderT))+import qualified Control.Monad.State.Lazy as StateLazy+import qualified Control.Monad.State.Strict as StateStrict+import Control.Monad.Trans.Cont (ContT (ContT))+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 qualified Data.HashSet as HS+import Data.Monoid (Alt, Ap, Endo (Endo))+import qualified Data.Monoid as Monoid+import Data.Ord (Down)+import Data.Proxy (Proxy)+import GHC.Generics+  ( K1 (K1),+    M1 (M1),+    Par1 (Par1),+    Rec1 (Rec1),+    U1,+    V1,+    (:.:) (Comp1),+    type (:*:),+  )+import GHC.TypeNats (KnownNat, type (<=))+import Generics.Deriving (Default (Default), Default1 (Default1))+import Grisette.Internal.Core.Control.Exception (AssertionError)+import Grisette.Internal.Core.Data.Class.Mergeable+  ( Mergeable (rootStrategy),+    Mergeable1 (liftRootStrategy),+    Mergeable2 (liftRootStrategy2),+    Mergeable3 (liftRootStrategy3),+    MergingStrategy (SimpleStrategy),+  )+import Grisette.Internal.Internal.Decl.Core.Data.Class.SimpleMergeable+  ( SimpleMergeable (mrgIte),+    SimpleMergeable1 (liftMrgIte),+    SimpleMergeable2 (liftMrgIte2),+    SymBranching (mrgIfPropagatedStrategy, mrgIfWithStrategy),+    mrgIf,+    mrgIte1,+  )+import Grisette.Internal.Internal.Impl.Core.Data.Class.TryMerge ()+import Grisette.Internal.SymPrim.FP (ValidFP)+import Grisette.Internal.SymPrim.GeneralFun (freshArgSymbol, substTerm, type (-->) (GeneralFun))+import Grisette.Internal.SymPrim.Prim.Internal.Term (SupportedPrim (pevalITETerm), symTerm)+import Grisette.Internal.SymPrim.Prim.SomeTerm (SomeTerm (SomeTerm))+import Grisette.Internal.SymPrim.Prim.Term (TypedConstantSymbol)+import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal (SymAlgReal))+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.Derivation.Derive (derive)++-- $setup+-- >>> import Grisette.Core+-- >>> import Grisette.SymPrim+-- >>> import Control.Monad.Identity++derive+  [ ''(,),+    ''(,,),+    ''(,,,),+    ''(,,,,),+    ''(,,,,,),+    ''(,,,,,,),+    ''(,,,,,,,),+    ''(,,,,,,,,),+    ''(,,,,,,,,,),+    ''(,,,,,,,,,,),+    ''(,,,,,,,,,,,),+    ''(,,,,,,,,,,,,),+    ''(,,,,,,,,,,,,,),+    ''(,,,,,,,,,,,,,,)+  ]+  [''SimpleMergeable, ''SimpleMergeable1, ''SimpleMergeable2]++derive+  [ ''Identity,+    ''Monoid.Dual,+    ''Monoid.Sum,+    ''Monoid.Product,+    ''Down+  ]+  [''SimpleMergeable, ''SimpleMergeable1]++derive+  [''(), ''AssertionError]+  [''SimpleMergeable]++instance SimpleMergeable (Proxy a) where+  mrgIte _ l _ = l+  {-# INLINE mrgIte #-}++instance SimpleMergeable1 Proxy where+  liftMrgIte _ _ l _ = l+  {-# INLINE liftMrgIte #-}++instance (SimpleMergeable b) => SimpleMergeable (a -> b) where+  mrgIte = mrgIte1+  {-# INLINE mrgIte #-}++instance SimpleMergeable1 ((->) a) where+  liftMrgIte ms cond t f v = ms cond (t v) (f v)+  {-# INLINE liftMrgIte #-}++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 (SymBranching m) => SimpleMergeable1 (MaybeT m) where+  liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m)+  {-# INLINE liftMrgIte #-}++instance (SymBranching m) => SymBranching (MaybeT m) where+  mrgIfWithStrategy strategy cond (MaybeT l) (MaybeT r) =+    MaybeT $ mrgIfWithStrategy (liftRootStrategy strategy) cond l r+  {-# INLINE mrgIfWithStrategy #-}+  mrgIfPropagatedStrategy cond (MaybeT l) (MaybeT r) =+    MaybeT $ mrgIfPropagatedStrategy cond l r+  {-# INLINE mrgIfPropagatedStrategy #-}++-- ExceptT+instance+  (SymBranching m, Mergeable e, Mergeable a) =>+  SimpleMergeable (ExceptT e m a)+  where+  mrgIte = mrgIf+  {-# INLINE mrgIte #-}++instance+  (SymBranching m, Mergeable e) =>+  SimpleMergeable1 (ExceptT e m)+  where+  liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m)+  {-# INLINE liftMrgIte #-}++instance+  (SymBranching m, Mergeable e) =>+  SymBranching (ExceptT e m)+  where+  mrgIfWithStrategy s cond (ExceptT t) (ExceptT f) =+    ExceptT $ mrgIfWithStrategy (liftRootStrategy s) cond t f+  {-# INLINE mrgIfWithStrategy #-}+  mrgIfPropagatedStrategy cond (ExceptT t) (ExceptT f) =+    ExceptT $ mrgIfPropagatedStrategy cond t f+  {-# INLINE mrgIfPropagatedStrategy #-}++-- StateT+instance+  (Mergeable s, Mergeable a, SymBranching m) =>+  SimpleMergeable (StateLazy.StateT s m a)+  where+  mrgIte = mrgIf+  {-# INLINE mrgIte #-}++instance+  (Mergeable s, SymBranching m) =>+  SimpleMergeable1 (StateLazy.StateT s m)+  where+  liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m)+  {-# INLINE liftMrgIte #-}++instance+  (Mergeable s, SymBranching m) =>+  SymBranching (StateLazy.StateT s m)+  where+  mrgIfWithStrategy s cond (StateLazy.StateT t) (StateLazy.StateT f) =+    StateLazy.StateT $ \v ->+      mrgIfWithStrategy+        (liftRootStrategy2 s rootStrategy)+        cond+        (t v)+        (f v)+  {-# INLINE mrgIfWithStrategy #-}+  mrgIfPropagatedStrategy cond (StateLazy.StateT t) (StateLazy.StateT f) =+    StateLazy.StateT $ \v -> mrgIfPropagatedStrategy cond (t v) (f v)+  {-# INLINE mrgIfPropagatedStrategy #-}++instance+  (Mergeable s, Mergeable a, SymBranching m) =>+  SimpleMergeable (StateStrict.StateT s m a)+  where+  mrgIte = mrgIf+  {-# INLINE mrgIte #-}++instance+  (Mergeable s, SymBranching m) =>+  SimpleMergeable1 (StateStrict.StateT s m)+  where+  liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m)+  {-# INLINE liftMrgIte #-}++instance+  (Mergeable s, SymBranching m) =>+  SymBranching (StateStrict.StateT s m)+  where+  mrgIfWithStrategy s cond (StateStrict.StateT t) (StateStrict.StateT f) =+    StateStrict.StateT $+      \v ->+        mrgIfWithStrategy (liftRootStrategy2 s rootStrategy) cond (t v) (f v)+  {-# INLINE mrgIfWithStrategy #-}+  mrgIfPropagatedStrategy cond (StateStrict.StateT t) (StateStrict.StateT f) =+    StateStrict.StateT $ \v -> mrgIfPropagatedStrategy cond (t v) (f v)+  {-# INLINE mrgIfPropagatedStrategy #-}++-- WriterT+instance+  (Mergeable s, Mergeable a, SymBranching m, Monoid s) =>+  SimpleMergeable (WriterLazy.WriterT s m a)+  where+  mrgIte = mrgIf+  {-# INLINE mrgIte #-}++instance+  (Mergeable s, SymBranching m, Monoid s) =>+  SimpleMergeable1 (WriterLazy.WriterT s m)+  where+  liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m)+  {-# INLINE liftMrgIte #-}++instance+  (Mergeable s, SymBranching m, Monoid s) =>+  SymBranching (WriterLazy.WriterT s m)+  where+  mrgIfWithStrategy s cond (WriterLazy.WriterT t) (WriterLazy.WriterT f) =+    WriterLazy.WriterT $+      mrgIfWithStrategy (liftRootStrategy2 s rootStrategy) cond t f+  {-# INLINE mrgIfWithStrategy #-}+  mrgIfPropagatedStrategy cond (WriterLazy.WriterT t) (WriterLazy.WriterT f) =+    WriterLazy.WriterT $ mrgIfPropagatedStrategy cond t f+  {-# INLINE mrgIfPropagatedStrategy #-}++instance+  (Mergeable s, Mergeable a, SymBranching m, Monoid s) =>+  SimpleMergeable (WriterStrict.WriterT s m a)+  where+  mrgIte = mrgIf+  {-# INLINE mrgIte #-}++instance+  (Mergeable s, SymBranching m, Monoid s) =>+  SimpleMergeable1 (WriterStrict.WriterT s m)+  where+  liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m)+  {-# INLINE liftMrgIte #-}++instance+  (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+  {-# INLINE mrgIfPropagatedStrategy #-}++-- ReaderT+instance+  (Mergeable a, SymBranching m) =>+  SimpleMergeable (ReaderT s m a)+  where+  mrgIte = mrgIf+  {-# INLINE mrgIte #-}++instance+  (SymBranching m) =>+  SimpleMergeable1 (ReaderT s m)+  where+  liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m)+  {-# INLINE liftMrgIte #-}++instance+  (SymBranching m) =>+  SymBranching (ReaderT s m)+  where+  mrgIfWithStrategy s cond (ReaderT t) (ReaderT f) =+    ReaderT $ \v -> mrgIfWithStrategy s cond (t v) (f v)+  {-# INLINE mrgIfWithStrategy #-}+  mrgIfPropagatedStrategy cond (ReaderT t) (ReaderT f) =+    ReaderT $ \v -> mrgIfPropagatedStrategy cond (t v) (f v)+  {-# INLINE mrgIfPropagatedStrategy #-}++-- IdentityT+instance+  (SymBranching m, Mergeable a) =>+  SimpleMergeable (IdentityT m a)+  where+  mrgIte = mrgIf+  {-# INLINE mrgIte #-}++instance (SymBranching m) => SimpleMergeable1 (IdentityT m) where+  liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m)+  {-# INLINE liftMrgIte #-}++instance (SymBranching m) => SymBranching (IdentityT m) where+  mrgIfWithStrategy s cond (IdentityT l) (IdentityT r) =+    IdentityT $ mrgIfWithStrategy s cond l r+  {-# INLINE mrgIfWithStrategy #-}+  mrgIfPropagatedStrategy cond (IdentityT l) (IdentityT r) =+    IdentityT $ mrgIfPropagatedStrategy cond l r+  {-# INLINE mrgIfPropagatedStrategy #-}++-- 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 (SymBranching m, Mergeable r) => SimpleMergeable1 (ContT r m) where+  liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m)+  {-# INLINE liftMrgIte #-}++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 #-}+  mrgIfPropagatedStrategy cond (ContT l) (ContT r) =+    ContT $ \c -> mrgIfPropagatedStrategy cond (l c) (r c)+  {-# INLINE mrgIfPropagatedStrategy #-}++-- RWST+instance+  (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, SymBranching m) =>+  SimpleMergeable1 (RWSLazy.RWST r w s m)+  where+  liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m)+  {-# INLINE liftMrgIte #-}++instance+  (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 ->+      mrgIfWithStrategy+        (liftRootStrategy3 ms rootStrategy rootStrategy)+        cond+        (t r s)+        (f r s)+  {-# INLINE mrgIfWithStrategy #-}+  mrgIfPropagatedStrategy cond (RWSLazy.RWST t) (RWSLazy.RWST f) =+    RWSLazy.RWST $ \r s -> mrgIfPropagatedStrategy cond (t r s) (f r s)+  {-# INLINE mrgIfPropagatedStrategy #-}++instance+  (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, SymBranching m) =>+  SimpleMergeable1 (RWSStrict.RWST r w s m)+  where+  liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m)+  {-# INLINE liftMrgIte #-}++instance+  (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 ->+      mrgIfWithStrategy+        (liftRootStrategy3 ms rootStrategy rootStrategy)+        cond+        (t r s)+        (f r s)+  {-# INLINE mrgIfWithStrategy #-}+  mrgIfPropagatedStrategy cond (RWSStrict.RWST t) (RWSStrict.RWST f) =+    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 (SymBool c) (symtype t) (symtype f) = symtype $ pevalITETerm c t f; \+  {-# INLINE mrgIte #-}++#define SIMPLE_MERGEABLE_BV(symtype) \+instance (KnownNat n, 1 <= n) => SimpleMergeable (symtype n) where \+  mrgIte (SymBool c) (symtype t) (symtype f) = symtype $ pevalITETerm c t f; \+  {-# INLINE mrgIte #-}++#define SIMPLE_MERGEABLE_FUN(cop, op, cons) \+instance SimpleMergeable (op sa sb) where \+  mrgIte (SymBool c) (cons t) (cons f) = cons $ pevalITETerm c t f; \+  {-# INLINE mrgIte #-}++#if 1+SIMPLE_MERGEABLE_SIMPLE(SymInteger)+SIMPLE_MERGEABLE_SIMPLE(SymFPRoundingMode)+SIMPLE_MERGEABLE_SIMPLE(SymAlgReal)+SIMPLE_MERGEABLE_BV(SymIntN)+SIMPLE_MERGEABLE_BV(SymWordN)+SIMPLE_MERGEABLE_FUN((=->), (=~>), SymTabularFun)+SIMPLE_MERGEABLE_FUN((-->), (-~>), SymGeneralFun)+#endif++instance SimpleMergeable (a --> b) where+  mrgIte+    (SymBool c)+    (GeneralFun (ta :: TypedConstantSymbol a) a)+    (GeneralFun tb b) =+      GeneralFun argSymbol $+        pevalITETerm+          c+          (substTerm ta (symTerm argSymbol) HS.empty a)+          (substTerm tb (symTerm argSymbol) HS.empty b)+      where+        argSymbol :: TypedConstantSymbol a+        argSymbol = freshArgSymbol [SomeTerm a, SomeTerm b]+  {-# INLINE mrgIte #-}++instance (ValidFP eb sb) => SimpleMergeable (SymFP eb sb) where+  mrgIte (SymBool c) (SymFP t) (SymFP f) = SymFP $ pevalITETerm c t f+  {-# INLINE mrgIte #-}
+ src/Grisette/Internal/Internal/Impl/Core/Data/Class/Solver.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.Internal.Impl.Core.Data.Class.Solver+-- 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.Internal.Impl.Core.Data.Class.Solver () where++import Control.DeepSeq (NFData)+import qualified Data.Binary as Binary+import Data.Bytes.Serial (Serial (deserialize, serialize))+import Data.Hashable (Hashable)+import qualified Data.Serialize as Cereal+import Grisette.Internal.Internal.Decl.Core.Data.Class.PPrint (PPrint)+import Grisette.Internal.Internal.Decl.Core.Data.Class.Solver (SolvingFailure)+import Grisette.Internal.Internal.Impl.Core.Data.Class.PPrint ()+import Grisette.Internal.TH.Derivation.Derive (derive)++-- $setup+-- >>> import Grisette+-- >>> import Grisette.Core+-- >>> import Grisette.SymPrim+-- >>> import Grisette.Backend++derive+  [''SolvingFailure]+  [ ''Show,+    ''Eq,+    ''PPrint,+    ''NFData,+    ''Hashable,+    ''Serial+  ]++instance Cereal.Serialize SolvingFailure where+  put = serialize+  get = deserialize++instance Binary.Binary SolvingFailure where+  put = serialize+  get = deserialize
+ src/Grisette/Internal/Internal/Impl/Core/Data/Class/SubstSym.hs view
@@ -0,0 +1,374 @@+{-# 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.Internal.Impl.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.Internal.Impl.Core.Data.Class.SubstSym () where++import Control.Exception (ArithException)+import Control.Monad.Except (ExceptT)+import Control.Monad.Identity+  ( Identity,+    IdentityT (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.Compose (Compose (Compose))+import Data.Functor.Const (Const)+import Data.Functor.Product (Product)+import Data.Functor.Sum (Sum)+import qualified Data.HashSet as HS+import Data.Int (Int16, Int32, Int64, Int8)+import Data.Monoid (Alt, Ap)+import qualified Data.Monoid as Monoid+import Data.Ord (Down)+import Data.Proxy (Proxy)+import Data.Ratio (Ratio, denominator, numerator, (%))+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),+    K1 (K1),+    M1 (M1),+    Par1 (Par1),+    Rec1 (Rec1),+    U1,+    V1,+    (:.:) (Comp1),+    type (:*:),+    type (:+:),+  )+import Generics.Deriving.Instances ()+import Grisette.Internal.Core.Control.Exception+  ( AssertionError,+    VerificationConditions,+  )+import Grisette.Internal.Core.Data.Class.AsKey (AsKey (AsKey), AsKey1 (AsKey1))+import Grisette.Internal.Internal.Decl.Core.Data.Class.SubstSym+  ( SubstSym (substSym),+    SubstSym1 (liftSubstSym),+    SubstSym2,+    substSym1,+  )+import Grisette.Internal.SymPrim.AlgReal (AlgReal)+import Grisette.Internal.SymPrim.BV (IntN, WordN)+import Grisette.Internal.SymPrim.FP+  ( FP,+    FPRoundingMode,+    NotRepresentableFPError,+    ValidFP,+  )+import Grisette.Internal.SymPrim.GeneralFun (substTerm, type (-->) (GeneralFun))+import Grisette.Internal.SymPrim.Prim.Term+  ( LinkedRep (underlyingTerm),+    SymRep (SymType),+    someTypedSymbol,+  )+import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal (SymAlgReal))+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 (=->) (TabularFun))+import Grisette.Internal.TH.Derivation.Derive (derive)++#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)+CONCRETE_SUBSTITUTESYM(AlgReal)+#endif++instance SubstSym (Proxy a) where+  substSym _ _ = id+  {-# INLINE substSym #-}++instance SubstSym1 Proxy where+  liftSubstSym _ _ _ = id+  {-# INLINE liftSubstSym #-}++instance (Integral a, SubstSym a) => SubstSym (Ratio a) where+  substSym sym val a =+    substSym sym val (numerator a) % substSym sym val (denominator a)+  {-# INLINE substSym #-}++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) HS.empty 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) HS.empty t++#define SUBSTITUTE_SYM_FUN(op, cons) \+instance SubstSym (op sa sb) where \+  substSym sym v (cons t) = \+    cons $ substTerm sym (underlyingTerm v) HS.empty t++#if 1+SUBSTITUTE_SYM_SIMPLE(SymBool)+SUBSTITUTE_SYM_SIMPLE(SymInteger)+SUBSTITUTE_SYM_SIMPLE(SymAlgReal)+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) HS.empty t++derive+  [ ''(),+    ''AssertionError,+    ''VerificationConditions,+    ''NotRepresentableFPError,+    ''ArithException+  ]+  [''SubstSym]++derive+  [ ''Either,+    ''(,),+    ''(,,),+    ''(,,,),+    ''(,,,,),+    ''(,,,,,),+    ''(,,,,,,),+    ''(,,,,,,,),+    ''(,,,,,,,,),+    ''(,,,,,,,,,),+    ''(,,,,,,,,,,),+    ''(,,,,,,,,,,,),+    ''(,,,,,,,,,,,,),+    ''(,,,,,,,,,,,,,),+    ''(,,,,,,,,,,,,,,)+  ]+  [''SubstSym, ''SubstSym1, ''SubstSym2]++derive+  [ ''[],+    ''Maybe,+    ''Identity,+    ''Monoid.Dual,+    ''Monoid.First,+    ''Monoid.Last,+    ''Monoid.Sum,+    ''Monoid.Product,+    ''Down,+    ''ExceptT,+    ''MaybeT,+    ''WriterLazy.WriterT,+    ''WriterStrict.WriterT+  ]+  [''SubstSym, ''SubstSym1]++-- 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)++instance (SubstSym a, SubstSym b) => SubstSym (a =-> b) where+  substSym sym val (TabularFun f d) =+    TabularFun (substSym sym val f) (substSym sym val d)+  {-# INLINE substSym #-}++instance (SubstSym (SymType b)) => SubstSym (a --> b) where+  substSym sym val (GeneralFun s t) =+    GeneralFun s $+      substTerm sym (underlyingTerm val) (HS.singleton $ someTypedSymbol s) t+  {-# INLINE substSym #-}++instance (SubstSym a) => SubstSym (AsKey a) where+  substSym sym val (AsKey t) = AsKey $ substSym sym val t+  {-# INLINE substSym #-}++instance (SubstSym1 f, SubstSym a) => SubstSym (AsKey1 f a) where+  substSym sym val (AsKey1 t) = AsKey1 $ substSym sym val t+  {-# INLINE substSym #-}++instance (SubstSym1 f) => SubstSym1 (AsKey1 f) where+  liftSubstSym f sym val (AsKey1 t) = AsKey1 $ liftSubstSym f sym val t+  {-# INLINE liftSubstSym #-}
+ src/Grisette/Internal/Internal/Impl/Core/Data/Class/SymEq.hs view
@@ -0,0 +1,338 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- {-# OPTIONS_GHC -ddump-splices -ddump-to-file -ddump-file-prefix=symeq #-}++-- |+-- Module      :   Grisette.Internal.Internal.Impl.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.Internal.Impl.Core.Data.Class.SymEq () where++import Control.Exception (ArithException)+import Control.Monad.Except (ExceptT)+import Control.Monad.Identity+  ( Identity,+    IdentityT (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.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.List.NonEmpty (NonEmpty ((:|)))+import Data.Monoid (Alt, Ap)+import qualified Data.Monoid as Monoid+import Data.Ord (Down)+import Data.Proxy (Proxy)+import Data.Ratio (Ratio, denominator, numerator)+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),+    K1 (K1),+    M1 (M1),+    Par1 (Par1),+    Rec1 (Rec1),+    U1,+    V1,+    (:.:) (Comp1),+    type (:*:),+    type (:+:),+  )+import Grisette.Internal.Core.Control.Exception+  ( AssertionError,+    VerificationConditions,+  )+import Grisette.Internal.Core.Data.Class.AsKey (AsKey (AsKey), AsKey1 (AsKey1))+import Grisette.Internal.Core.Data.Class.LogicalOp (LogicalOp ((.&&)))+import Grisette.Internal.Core.Data.Class.Solvable (Solvable (con))+import Grisette.Internal.Internal.Decl.Core.Data.Class.SymEq+  ( SymEq (symDistinct, (./=), (.==)),+    SymEq1 (liftSymEq),+    SymEq2,+    symEq1,+  )+import Grisette.Internal.SymPrim.AlgReal (AlgReal)+import Grisette.Internal.SymPrim.BV (IntN, WordN)+import Grisette.Internal.SymPrim.FP+  ( FP,+    FPRoundingMode,+    NotRepresentableFPError,+    ValidFP,+  )+import Grisette.Internal.SymPrim.Prim.Term+  ( SupportedPrim (pevalDistinctTerm),+    pevalEqTerm,+    underlyingTerm,+  )+import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal (SymAlgReal))+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.Derivation.Derive (derive)++#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)+CONCRETE_SEQ(AlgReal)+#endif++instance SymEq (Proxy a) where+  _ .== _ = con True+  {-# INLINE (.==) #-}++instance SymEq1 Proxy where+  liftSymEq _ _ _ = con True+  {-# INLINE liftSymEq #-}++instance (SymEq a) => SymEq (Ratio a) where+  a .== b = numerator a .== numerator b .&& denominator a .== denominator b+  {-# INLINE (.==) #-}++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 (.==) #-}; \+  l ./= r = symDistinct [l, r]; \+  {-# INLINE (./=) #-}; \+  symDistinct [] = con True; \+  symDistinct [_] = con True; \+  symDistinct (l:ls) = SymBool $ \+    pevalDistinctTerm (underlyingTerm l :| (underlyingTerm <$> ls))++#define SEQ_BV(symtype) \+instance (KnownNat n, 1 <= n) => SymEq (symtype n) where \+  (symtype l) .== (symtype r) = SymBool $ pevalEqTerm l r; \+  {-# INLINE (.==) #-}; \+  l ./= r = symDistinct [l, r]; \+  {-# INLINE (./=) #-}; \+  symDistinct [] = con True; \+  symDistinct [_] = con True; \+  symDistinct (l:ls) = SymBool $ \+    pevalDistinctTerm (underlyingTerm l :| (underlyingTerm <$> ls))++#if 1+SEQ_SIMPLE(SymBool)+SEQ_SIMPLE(SymInteger)+SEQ_SIMPLE(SymFPRoundingMode)+SEQ_SIMPLE(SymAlgReal)+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 (.==) #-}++derive+  [ ''(),+    ''AssertionError,+    ''VerificationConditions,+    ''NotRepresentableFPError,+    ''ArithException+  ]+  [''SymEq]++derive+  [ ''Either,+    ''(,),+    ''(,,),+    ''(,,,),+    ''(,,,,),+    ''(,,,,,),+    ''(,,,,,,),+    ''(,,,,,,,),+    ''(,,,,,,,,),+    ''(,,,,,,,,,),+    ''(,,,,,,,,,,),+    ''(,,,,,,,,,,,),+    ''(,,,,,,,,,,,,),+    ''(,,,,,,,,,,,,,),+    ''(,,,,,,,,,,,,,,)+  ]+  [''SymEq, ''SymEq1, ''SymEq2]++derive+  [ ''[],+    ''Maybe,+    ''Identity,+    ''Monoid.Dual,+    ''Monoid.First,+    ''Monoid.Last,+    ''Monoid.Sum,+    ''Monoid.Product,+    ''Down,+    ''ExceptT,+    ''MaybeT,+    ''WriterLazy.WriterT,+    ''WriterStrict.WriterT+  ]+  [''SymEq, ''SymEq1]++-- 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 (SymEq a) => SymEq (AsKey a) where+  (AsKey l) .== (AsKey r) = l .== r+  {-# INLINE (.==) #-}++instance (SymEq1 f) => SymEq1 (AsKey1 f) where+  liftSymEq f (AsKey1 l) (AsKey1 r) = liftSymEq f l r+  {-# INLINE liftSymEq #-}++instance (SymEq1 f, SymEq a) => SymEq (AsKey1 f a) where+  (.==) = symEq1+  {-# INLINE (.==) #-}
+ src/Grisette/Internal/Internal/Impl/Core/Data/Class/SymOrd.hs view
@@ -0,0 +1,492 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.Internal.Impl.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.Internal.Impl.Core.Data.Class.SymOrd () where++import Control.Exception (ArithException)+import Control.Monad.Except (ExceptT)+import Control.Monad.Identity+  ( Identity,+    IdentityT (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.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.Monoid (Alt, Ap)+import qualified Data.Monoid as Monoid+import Data.Ord (Down (Down))+import Data.Proxy (Proxy)+import Data.Ratio (Ratio, denominator, numerator)+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),+    K1 (K1),+    M1 (M1),+    Par1 (Par1),+    Rec1 (Rec1),+    U1,+    V1,+    (:.:) (Comp1),+    type (:*:),+    type (:+:),+  )+import Grisette.Internal.Core.Control.Exception+  ( AssertionError,+    VerificationConditions,+  )+import Grisette.Internal.Core.Control.Monad.Union (Union)+import Grisette.Internal.Core.Data.Class.AsKey (AsKey (AsKey), AsKey1 (AsKey1))+import Grisette.Internal.Core.Data.Class.LogicalOp+  ( LogicalOp (symNot, (.&&), (.||)),+  )+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+  ( mrgSingle,+    tryMerge,+  )+import Grisette.Internal.Core.Data.Class.UnionView+  ( simpleMerge,+  )+import Grisette.Internal.Internal.Decl.Core.Data.Class.SymOrd+  ( SymOrd (symCompare, (.<), (.<=), (.>), (.>=)),+    SymOrd1 (liftSymCompare),+    SymOrd2,+    symCompare1,+  )+import Grisette.Internal.SymPrim.AlgReal (AlgReal)+import Grisette.Internal.SymPrim.BV (IntN, WordN)+import Grisette.Internal.SymPrim.FP (FP, FPRoundingMode, NotRepresentableFPError, ValidFP)+import Grisette.Internal.SymPrim.Prim.Term+  ( PEvalOrdTerm+      ( pevalLeOrdTerm,+        pevalLtOrdTerm+      ),+    pevalGeOrdTerm,+    pevalGtOrdTerm,+  )+import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal (SymAlgReal))+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.Derivation.Derive (derive)++#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)+CONCRETE_SORD(AlgReal)+#endif++instance SymOrd (Proxy a) where+  _ .<= _ = con True+  {-# INLINE (.<=) #-}+  _ .< _ = con False+  {-# INLINE (.<) #-}+  _ .>= _ = con True+  {-# INLINE (.>=) #-}+  _ .> _ = con False+  {-# INLINE (.>) #-}+  symCompare _ _ = mrgSingle EQ+  {-# INLINE symCompare #-}++instance SymOrd1 Proxy where+  liftSymCompare _ _ _ = mrgSingle EQ+  {-# INLINE liftSymCompare #-}++instance (SymOrd a, Integral a) => SymOrd (Ratio a) where+  a .<= b = numerator a * denominator b .<= numerator b * denominator a+  {-# INLINE (.<=) #-}+  a .< b = numerator a * denominator b .< numerator b * denominator a+  {-# INLINE (.<) #-}++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(SymAlgReal)+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++derive+  [ ''(),+    ''AssertionError,+    ''VerificationConditions,+    ''NotRepresentableFPError,+    ''ArithException+  ]+  [''SymOrd]++derive+  [ ''Either,+    ''(,),+    ''(,,),+    ''(,,,),+    ''(,,,,),+    ''(,,,,,),+    ''(,,,,,,),+    ''(,,,,,,,),+    ''(,,,,,,,,),+    ''(,,,,,,,,,),+    ''(,,,,,,,,,,),+    ''(,,,,,,,,,,,),+    ''(,,,,,,,,,,,,),+    ''(,,,,,,,,,,,,,),+    ''(,,,,,,,,,,,,,,)+  ]+  [''SymOrd, ''SymOrd1, ''SymOrd2]++derive+  [ ''Maybe,+    ''Identity,+    ''Monoid.Dual,+    ''Monoid.First,+    ''Monoid.Last,+    ''Monoid.Sum,+    ''Monoid.Product,+    ''ExceptT,+    ''MaybeT,+    ''WriterLazy.WriterT,+    ''WriterStrict.WriterT+  ]+  [''SymOrd, ''SymOrd1]++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 #-}++-- 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 (SymOrd a) => SymOrd (AsKey a) where+  symCompare (AsKey l) (AsKey r) = symCompare l r+  {-# INLINE symCompare #-}++instance (SymOrd1 f, SymOrd a) => SymOrd (AsKey1 f a) where+  symCompare = symCompare1+  {-# INLINE symCompare #-}++instance (SymOrd1 f) => SymOrd1 (AsKey1 f) where+  liftSymCompare f (AsKey1 l) (AsKey1 r) = liftSymCompare f l r+  {-# INLINE liftSymCompare #-}
+ src/Grisette/Internal/Internal/Impl/Core/Data/Class/ToCon.hs view
@@ -0,0 +1,459 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.Internal.Impl.Core.Data.Class.ToCon+-- 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.Internal.Impl.Core.Data.Class.ToCon () where++import Control.Exception (ArithException)+import Control.Monad.Except (ExceptT (ExceptT))+import Control.Monad.Identity+  ( Identity (Identity, runIdentity),+    IdentityT (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.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.Monoid (Alt, Ap)+import qualified Data.Monoid as Monoid+import Data.Ord (Down)+import Data.Ratio (Ratio, denominator, numerator, (%))+import qualified Data.Text as T+import Data.Word (Word16, Word32, Word64, Word8)+import GHC.Generics+  ( K1 (K1),+    M1 (M1),+    Par1 (Par1),+    Rec1 (Rec1),+    U1,+    V1,+    (:.:) (Comp1),+    type (:*:),+    type (:+:),+  )+import GHC.TypeNats (KnownNat, type (<=))+import Generics.Deriving (Default (Default), Default1 (Default1))+import Generics.Deriving.Instances ()+import Grisette.Internal.Core.Control.Exception+  ( AssertionError,+    VerificationConditions,+  )+import Grisette.Internal.Core.Data.Class.AsKey (AsKey (AsKey), AsKey1 (AsKey1))+import Grisette.Internal.Core.Data.Class.BitCast (bitCastOrCanonical)+import Grisette.Internal.Core.Data.Class.Solvable+  ( Solvable (conView),+    pattern Con,+  )+import Grisette.Internal.Internal.Decl.Core.Data.Class.ToCon+  ( ToCon (toCon),+    ToCon1 (liftToCon),+    ToCon2,+    toCon1,+  )+import Grisette.Internal.SymPrim.AlgReal (AlgReal (AlgExactRational))+import Grisette.Internal.SymPrim.BV+  ( IntN (IntN),+    WordN (WordN),+  )+import Grisette.Internal.SymPrim.FP+  ( FP,+    FP32,+    FP64,+    FPRoundingMode,+    NotRepresentableFPError,+    ValidFP,+  )+import Grisette.Internal.SymPrim.GeneralFun (type (-->))+import Grisette.Internal.SymPrim.IntBitwidth (intBitwidthQ)+import Grisette.Internal.SymPrim.Prim.Term (LinkedRep)+import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal)+import Grisette.Internal.SymPrim.SymBV+  ( SymIntN,+    SymWordN,+  )+import Grisette.Internal.SymPrim.SymBool (SymBool)+import Grisette.Internal.SymPrim.SymFP+  ( SymFP,+    SymFP32,+    SymFP64,+    SymFPRoundingMode,+  )+import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>) (SymGeneralFun))+import Grisette.Internal.SymPrim.SymInteger (SymInteger)+import Grisette.Internal.SymPrim.SymTabularFun (type (=~>) (SymTabularFun))+import Grisette.Internal.SymPrim.TabularFun (type (=->))+import Grisette.Internal.TH.Derivation.Derive (derive)++-- $setup+-- >>> import Grisette.Core+-- >>> import Grisette.SymPrim++#define CONCRETE_TOCON(type) \+instance ToCon type type where \+  toCon = Just++#define CONCRETE_TOCON_BV(type) \+instance (KnownNat n, 1 <= n) => ToCon (type n) (type n) where \+  toCon = Just++#if 1+CONCRETE_TOCON(Bool)+CONCRETE_TOCON(Integer)+CONCRETE_TOCON(Char)+CONCRETE_TOCON(Int)+CONCRETE_TOCON(Int8)+CONCRETE_TOCON(Int16)+CONCRETE_TOCON(Int32)+CONCRETE_TOCON(Int64)+CONCRETE_TOCON(Word)+CONCRETE_TOCON(Word8)+CONCRETE_TOCON(Word16)+CONCRETE_TOCON(Word32)+CONCRETE_TOCON(Word64)+CONCRETE_TOCON(Float)+CONCRETE_TOCON(Double)+CONCRETE_TOCON(B.ByteString)+CONCRETE_TOCON(T.Text)+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++instance ToCon (a =-> b) (a =-> b) where+  toCon = Just++instance ToCon (a --> b) (a --> b) where+  toCon = Just++#define TO_CON_SYMID_SIMPLE(symtype) \+instance ToCon symtype symtype where \+  toCon = Just++#define TO_CON_SYMID_BV(symtype) \+instance ToCon (symtype n) (symtype n) where \+  toCon = Just++#define TO_CON_SYMID_FUN(op) \+instance ToCon (a op b) (a op b) where \+  toCon = Just++#if 1+TO_CON_SYMID_SIMPLE(SymBool)+TO_CON_SYMID_SIMPLE(SymInteger)+TO_CON_SYMID_SIMPLE(SymAlgReal)+TO_CON_SYMID_BV(SymIntN)+TO_CON_SYMID_BV(SymWordN)+TO_CON_SYMID_FUN(=~>)+TO_CON_SYMID_FUN(-~>)+TO_CON_SYMID_SIMPLE(SymFPRoundingMode)+#endif++instance (ValidFP eb sb) => ToCon (SymFP eb sb) (SymFP eb sb) where+  toCon = Just++#define TO_CON_FROMSYM_SIMPLE(contype, symtype) \+instance ToCon symtype contype where \+  toCon = conView++#define TO_CON_FROMSYM_BV(contype, symtype) \+instance (KnownNat n, 1 <= n) => ToCon (symtype n) (contype n) where \+  toCon = conView++#define TO_CON_FROMSYM_FUN(conop, symop, consop) \+instance (LinkedRep ca sa, LinkedRep cb sb) => ToCon (symop sa sb) (conop ca cb) where \+  toCon a@(consop _) = conView a++#if 1+-- TO_CON_FROMSYM_SIMPLE(Bool, SymBool)+TO_CON_FROMSYM_SIMPLE(Integer, SymInteger)+TO_CON_FROMSYM_SIMPLE(AlgReal, SymAlgReal)+TO_CON_FROMSYM_BV(IntN, SymIntN)+TO_CON_FROMSYM_BV(WordN, SymWordN)+TO_CON_FROMSYM_FUN((=->), (=~>), SymTabularFun)+TO_CON_FROMSYM_FUN((-->), (-~>), SymGeneralFun)+TO_CON_FROMSYM_SIMPLE(FPRoundingMode, SymFPRoundingMode)+#endif++instance (ValidFP eb sb) => ToCon (SymFP eb sb) (FP eb sb) where+  toCon = conView++#define TOCON_MACHINE_INTEGER(sbvw, bvw, n, int) \+instance ToCon (sbvw n) int where \+  toCon (Con (bvw v :: bvw n)) = Just $ fromIntegral v; \+  toCon _ = Nothing++#if 1+TOCON_MACHINE_INTEGER(SymIntN, IntN, 8, Int8)+TOCON_MACHINE_INTEGER(SymIntN, IntN, 16, Int16)+TOCON_MACHINE_INTEGER(SymIntN, IntN, 32, Int32)+TOCON_MACHINE_INTEGER(SymIntN, IntN, 64, Int64)+TOCON_MACHINE_INTEGER(SymWordN, WordN, 8, Word8)+TOCON_MACHINE_INTEGER(SymWordN, WordN, 16, Word16)+TOCON_MACHINE_INTEGER(SymWordN, WordN, 32, Word32)+TOCON_MACHINE_INTEGER(SymWordN, WordN, 64, Word64)+TOCON_MACHINE_INTEGER(SymIntN, IntN, $intBitwidthQ, Int)+TOCON_MACHINE_INTEGER(SymWordN, WordN, $intBitwidthQ, Word)+#endif++instance ToCon SymFP32 Float where+  toCon (Con (fp :: FP32)) = Just $ bitCastOrCanonical fp+  toCon _ = Nothing++instance ToCon SymFP64 Double where+  toCon (Con (fp :: FP64)) = Just $ bitCastOrCanonical fp+  toCon _ = Nothing++instance (ToCon a b, Integral b) => ToCon (Ratio a) (Ratio b) where+  toCon r = do+    n <- toCon (numerator r)+    d <- toCon (denominator r)+    return $ n % d++instance ToCon SymAlgReal Rational where+  toCon (Con (x :: AlgReal)) =+    case x of+      AlgExactRational r -> Just r+      _ -> Nothing+  toCon _ = Nothing++derive+  [ ''Either,+    ''(,),+    ''(,,),+    ''(,,,),+    ''(,,,,),+    ''(,,,,,),+    ''(,,,,,,),+    ''(,,,,,,,),+    ''(,,,,,,,,),+    ''(,,,,,,,,,),+    ''(,,,,,,,,,,),+    ''(,,,,,,,,,,,),+    ''(,,,,,,,,,,,,),+    ''(,,,,,,,,,,,,,),+    ''(,,,,,,,,,,,,,,)+  ]+  [''ToCon, ''ToCon1, ''ToCon2]++derive+  [ ''[],+    ''Maybe,+    ''Monoid.Dual,+    ''Monoid.Sum,+    ''Monoid.Product,+    ''Monoid.First,+    ''Monoid.Last,+    ''Down,+    ''ExceptT,+    ''MaybeT,+    ''WriterLazy.WriterT,+    ''WriterStrict.WriterT+  ]+  [''ToCon, ''ToCon1]++derive+  [ ''(),+    ''AssertionError,+    ''VerificationConditions,+    ''NotRepresentableFPError,+    ''ArithException+  ]+  [''ToCon]++-- 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 (Product l r a))+  instance+    (ToCon (l0 a0) (l a), ToCon (r0 a0) (r a)) =>+    ToCon (Product l0 r0 a0) (Product l r a)++deriving via+  (Default1 (Product l r))+  instance+    (ToCon1 l0 l, ToCon1 r0 r) => ToCon1 (Product l0 r0) (Product l r)++-- 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)++deriving via+  (Default1 (Sum l r))+  instance+    (ToCon1 l0 l, ToCon1 r0 r) => ToCon1 (Sum l0 r0) (Sum l r)++-- 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+  (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 #-}++-- Const+deriving via+  (Default (Const a b))+  instance+    (ToCon a0 a) => ToCon (Const a0 b0) (Const a b)++deriving via+  (Default1 (Const a))+  instance+    (ToCon a0 a) => ToCon1 (Const a0) (Const a)++-- Alt+deriving via+  (Default (Alt f a))+  instance+    (ToCon (f0 a0) (f a)) => ToCon (Alt f0 a0) (Alt f a)++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)++instance {-# INCOHERENT #-} (ToCon a b) => ToCon (AsKey a) b where+  toCon (AsKey a) = toCon a++instance {-# INCOHERENT #-} (ToCon a b) => ToCon a (AsKey b) where+  toCon a = AsKey <$> toCon a++instance {-# INCOHERENT #-} (ToCon a b) => ToCon (AsKey a) (AsKey b) where+  toCon (AsKey a) = AsKey <$> toCon a++instance {-# INCOHERENT #-} (ToCon (f a) b) => ToCon (AsKey1 f a) b where+  toCon (AsKey1 a) = toCon a++instance {-# INCOHERENT #-} (ToCon a (f b)) => ToCon a (AsKey1 f b) where+  toCon a = AsKey1 <$> toCon a++instance {-# INCOHERENT #-} (ToCon (f a) (f b)) => ToCon (AsKey1 f a) (AsKey1 f b) where+  toCon (AsKey1 a) = AsKey1 <$> toCon a
+ src/Grisette/Internal/Internal/Impl/Core/Data/Class/ToSym.hs view
@@ -0,0 +1,515 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# 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.Internal.Impl.Core.Data.Class.ToSym+-- 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.Internal.Impl.Core.Data.Class.ToSym () where++import Control.Exception (ArithException)+import Control.Monad.Identity+  ( Identity (Identity, runIdentity),+    IdentityT (IdentityT),+  )+import Control.Monad.Reader (ReaderT (ReaderT))+import qualified Control.Monad.State.Lazy as StateLazy+import qualified Control.Monad.State.Strict as StateStrict+import Control.Monad.Trans.Except (ExceptT)+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.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.Monoid (Alt, Ap)+import qualified Data.Monoid as Monoid+import Data.Ord (Down)+import Data.Ratio (Ratio, denominator, numerator, (%))+import qualified Data.Text as T+import Data.Typeable (Typeable)+import Data.Word (Word16, Word32, Word64, Word8)+import GHC.TypeNats (KnownNat, type (<=))+import Generics.Deriving+  ( Default (Default),+    Default1 (Default1),+    K1 (K1),+    M1 (M1),+    Par1 (Par1),+    Rec1 (Rec1),+    U1,+    V1,+    (:.:) (Comp1),+    type (:*:),+    type (:+:),+  )+import Grisette.Internal.Core.Control.Exception+  ( AssertionError,+    VerificationConditions,+  )+import Grisette.Internal.Core.Data.Class.AsKey (AsKey (AsKey))+import Grisette.Internal.Core.Data.Class.BitCast (BitCast (bitCast))+import Grisette.Internal.Core.Data.Class.Solvable (Solvable (con))+import Grisette.Internal.Internal.Decl.Core.Data.Class.ToSym+  ( ToSym (toSym),+    ToSym1 (liftToSym),+    ToSym2 (liftToSym2),+    toSym1,+  )+import Grisette.Internal.Internal.Impl.Core.Data.Class.Mergeable ()+import Grisette.Internal.SymPrim.AlgReal (AlgReal)+import Grisette.Internal.SymPrim.BV+  ( IntN,+    WordN,+  )+import Grisette.Internal.SymPrim.FP+  ( FP,+    FPRoundingMode,+    NotRepresentableFPError,+    ValidFP,+  )+import Grisette.Internal.SymPrim.GeneralFun (type (-->))+import Grisette.Internal.SymPrim.IntBitwidth (intBitwidthQ)+import Grisette.Internal.SymPrim.Prim.Term+  ( LinkedRep,+    SupportedNonFuncPrim,+    SupportedPrim,+  )+import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal)+import Grisette.Internal.SymPrim.SymBV+  ( SymIntN,+    SymWordN,+  )+import Grisette.Internal.SymPrim.SymBool (SymBool)+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.Derivation.Derive (derive)++-- $setup+-- >>> import Grisette.SymPrim++#define CONCRETE_TOSYM(type) \+instance ToSym type type where \+  toSym = id++#define CONCRETE_TOSYM_BV(type) \+instance (KnownNat n, 1 <= n) => ToSym (type n) (type n) where \+  toSym = id++#if 1+CONCRETE_TOSYM(Bool)+CONCRETE_TOSYM(Integer)+CONCRETE_TOSYM(Char)+CONCRETE_TOSYM(Int)+CONCRETE_TOSYM(Int8)+CONCRETE_TOSYM(Int16)+CONCRETE_TOSYM(Int32)+CONCRETE_TOSYM(Int64)+CONCRETE_TOSYM(Word)+CONCRETE_TOSYM(Word8)+CONCRETE_TOSYM(Word16)+CONCRETE_TOSYM(Word32)+CONCRETE_TOSYM(Word64)+CONCRETE_TOSYM(Float)+CONCRETE_TOSYM(Double)+CONCRETE_TOSYM(B.ByteString)+CONCRETE_TOSYM(T.Text)+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++instance ToSym (a =-> b) (a =-> b) where+  toSym = id++instance ToSym (a --> b) (a --> b) where+  toSym = id++#define TO_SYM_SYMID_SIMPLE(symtype) \+instance ToSym symtype symtype where \+  toSym = id++#define TO_SYM_SYMID_BV(symtype) \+instance (KnownNat n, 1 <= n) => ToSym (symtype n) (symtype n) where \+  toSym = id++#define TO_SYM_SYMID_FUN(cop, op) \+instance (SupportedPrim (cop ca cb), LinkedRep ca sa, LinkedRep cb sb) => \+  ToSym (op sa sb) (op sa sb) where \+  toSym = id++#if 1+TO_SYM_SYMID_SIMPLE(SymBool)+TO_SYM_SYMID_SIMPLE(SymInteger)+TO_SYM_SYMID_SIMPLE(SymAlgReal)+TO_SYM_SYMID_BV(SymIntN)+TO_SYM_SYMID_BV(SymWordN)+TO_SYM_SYMID_FUN((=->), (=~>))+TO_SYM_SYMID_FUN((-->), (-~>))+TO_SYM_SYMID_SIMPLE(SymFPRoundingMode)+#endif++instance (ValidFP eb sb) => ToSym (SymFP eb sb) (SymFP eb sb) where+  toSym = id++#define TO_SYM_FROMCON_SIMPLE(contype, symtype) \+instance ToSym contype symtype where \+  toSym = con++#define TO_SYM_FROMCON_BV(contype, symtype) \+instance (KnownNat n, 1 <= n) => ToSym (contype n) (symtype n) where \+  toSym = con++#define TO_SYM_FROMCON_FUN(conop, symop) \+instance (SupportedPrim (conop ca cb), SupportedNonFuncPrim ca, LinkedRep ca sa, LinkedRep cb sb) => \+  ToSym (conop ca cb) (symop sa sb) where \+  toSym = con++#if 1+TO_SYM_FROMCON_SIMPLE(Bool, SymBool)+TO_SYM_FROMCON_SIMPLE(Integer, SymInteger)+TO_SYM_FROMCON_SIMPLE(AlgReal, SymAlgReal)+TO_SYM_FROMCON_BV(IntN, SymIntN)+TO_SYM_FROMCON_BV(WordN, SymWordN)+TO_SYM_FROMCON_FUN((=->), (=~>))+TO_SYM_FROMCON_FUN((-->), (-~>))+TO_SYM_FROMCON_SIMPLE(FPRoundingMode, SymFPRoundingMode)+#endif++instance (ValidFP eb sb) => ToSym (FP eb sb) (SymFP eb sb) where+  toSym = con++#define TOSYM_MACHINE_INTEGER(int, bv) \+instance ToSym int (bv) where \+  toSym = fromIntegral++#if 1+TOSYM_MACHINE_INTEGER(Int8, SymIntN 8)+TOSYM_MACHINE_INTEGER(Int16, SymIntN 16)+TOSYM_MACHINE_INTEGER(Int32, SymIntN 32)+TOSYM_MACHINE_INTEGER(Int64, SymIntN 64)+TOSYM_MACHINE_INTEGER(Word8, SymWordN 8)+TOSYM_MACHINE_INTEGER(Word16, SymWordN 16)+TOSYM_MACHINE_INTEGER(Word32, SymWordN 32)+TOSYM_MACHINE_INTEGER(Word64, SymWordN 64)+TOSYM_MACHINE_INTEGER(Int, SymIntN $intBitwidthQ)+TOSYM_MACHINE_INTEGER(Word, SymWordN $intBitwidthQ)+#endif++instance ToSym Float SymFP32 where+  toSym = con . bitCast+  {-# INLINE toSym #-}++instance ToSym Double SymFP64 where+  toSym = con . bitCast+  {-# INLINE toSym #-}++instance+  (Integral b, Typeable b, ToSym a b) =>+  ToSym (Ratio a) (Ratio b)+  where+  toSym r = toSym (numerator r) % toSym (denominator r)+  {-# INLINE toSym #-}++instance ToSym Rational SymAlgReal where+  toSym v = con (fromRational v)++-- 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 #-}++derive+  [ ''Either,+    ''(,),+    ''(,,),+    ''(,,,),+    ''(,,,,),+    ''(,,,,,),+    ''(,,,,,,),+    ''(,,,,,,,),+    ''(,,,,,,,,),+    ''(,,,,,,,,,),+    ''(,,,,,,,,,,),+    ''(,,,,,,,,,,,),+    ''(,,,,,,,,,,,,),+    ''(,,,,,,,,,,,,,),+    ''(,,,,,,,,,,,,,,)+  ]+  [''ToSym, ''ToSym1, ''ToSym2]++derive+  [ ''[],+    ''Maybe,+    ''Monoid.Dual,+    ''Monoid.Sum,+    ''Monoid.Product,+    ''Monoid.First,+    ''Monoid.Last,+    ''Down,+    ''ExceptT,+    ''MaybeT,+    ''WriterLazy.WriterT,+    ''WriterStrict.WriterT+  ]+  [''ToSym, ''ToSym1]++derive+  [ ''(),+    ''AssertionError,+    ''VerificationConditions,+    ''NotRepresentableFPError,+    ''ArithException+  ]+  [''ToSym]++-- 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 ::+    forall a b.+    (ToSym s2 s1, ToSym1 m1 m2) =>+    (a -> b) ->+    ReaderT s1 m1 a ->+    ReaderT s2 m2 b+  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 #-}++-- Product+deriving via+  (Default (Product l r a))+  instance+    (ToSym (l0 a0) (l a), ToSym (r0 a0) (r a)) =>+    ToSym (Product l0 r0 a0) (Product l r a)++deriving via+  (Default1 (Product l r))+  instance+    (ToSym1 l0 l, ToSym1 r0 r) => ToSym1 (Product l0 r0) (Product l r)++-- 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)++deriving via+  (Default1 (Sum l r))+  instance+    (ToSym1 l0 l, ToSym1 r0 r) => ToSym1 (Sum l0 r0) (Sum l r)++-- 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+  (ToSym1 f0 f, ToSym1 g0 g) =>+  ToSym1 (Compose f0 g0) (Compose f g)+  where+  liftToSym ::+    forall a b.+    (ToSym1 f0 f, ToSym1 g0 g) =>+    (a -> b) ->+    Compose f0 g0 a ->+    Compose f g b+  liftToSym f (Compose v) = Compose $ liftToSym (liftToSym f) v+  {-# INLINE liftToSym #-}++-- Const+deriving via+  (Default (Const a b))+  instance+    (ToSym a0 a) => ToSym (Const a0 b0) (Const a b)++deriving via+  (Default1 (Const a))+  instance+    (ToSym a0 a) => ToSym1 (Const a0) (Const a)++-- Alt+deriving via+  (Default (Alt f a))+  instance+    (ToSym (f0 a0) (f a)) => ToSym (Alt f0 a0) (Alt f a)++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)++instance {-# INCOHERENT #-} (ToSym a b) => ToSym (AsKey a) (AsKey b) where+  toSym (AsKey a) = AsKey $ toSym a+  {-# INLINE toSym #-}++instance {-# INCOHERENT #-} (ToSym a b) => ToSym a (AsKey b) where+  toSym a = AsKey $ toSym a+  {-# INLINE toSym #-}++instance {-# INCOHERENT #-} (ToSym a b) => ToSym (AsKey a) b where+  toSym (AsKey a) = toSym a+  {-# INLINE toSym #-}
+ src/Grisette/Internal/Internal/Impl/Core/Data/Class/TryMerge.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}++-- |+-- Module      :   Grisette.Internal.Internal.Impl.Core.Data.Class.TryMerge+-- 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.Internal.Impl.Core.Data.Class.TryMerge () where++import Control.Monad.Cont (ContT (ContT))+import Control.Monad.Except (ExceptT (ExceptT))+import Control.Monad.Identity+  ( IdentityT (IdentityT),+  )+import qualified Control.Monad.RWS.Lazy as RWSLazy+import qualified Control.Monad.RWS.Strict as RWSStrict+import Control.Monad.Reader (ReaderT (ReaderT))+import qualified Control.Monad.State.Lazy as StateLazy+import qualified Control.Monad.State.Strict as StateStrict+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.Sum (Sum (InL, InR))+import qualified Data.Monoid as Monoid+import Grisette.Internal.Core.Data.Class.Mergeable+  ( Mergeable (rootStrategy),+    Mergeable1 (liftRootStrategy),+    Mergeable2 (liftRootStrategy2),+    Mergeable3 (liftRootStrategy3),+  )+import Grisette.Internal.Internal.Decl.Core.Data.Class.TryMerge+  ( TryMerge (tryMergeWithStrategy),+  )++-- $setup+-- >>> import Grisette.Core+-- >>> import Grisette.SymPrim++instance (TryMerge m) => TryMerge (MaybeT m) where+  tryMergeWithStrategy strategy (MaybeT ma) =+    MaybeT $ tryMergeWithStrategy (liftRootStrategy strategy) ma+  {-# INLINE tryMergeWithStrategy #-}++instance (Mergeable e, TryMerge m) => TryMerge (ExceptT e m) where+  tryMergeWithStrategy strategy (ExceptT ma) =+    ExceptT $ tryMergeWithStrategy (liftRootStrategy strategy) ma+  {-# INLINE tryMergeWithStrategy #-}++instance (TryMerge m) => TryMerge (ReaderT r m) where+  tryMergeWithStrategy strategy (ReaderT f) =+    ReaderT $ \v -> tryMergeWithStrategy strategy $ f v+  {-# INLINE tryMergeWithStrategy #-}++instance (Mergeable s, TryMerge m) => TryMerge (StateLazy.StateT s m) where+  tryMergeWithStrategy strategy (StateLazy.StateT f) =+    StateLazy.StateT $+      \s -> tryMergeWithStrategy (liftRootStrategy2 strategy rootStrategy) (f s)+  {-# INLINE tryMergeWithStrategy #-}++instance (Mergeable s, TryMerge m) => TryMerge (StateStrict.StateT s m) where+  tryMergeWithStrategy strategy (StateStrict.StateT f) =+    StateStrict.StateT $+      \s -> tryMergeWithStrategy (liftRootStrategy2 strategy rootStrategy) (f s)+  {-# INLINE tryMergeWithStrategy #-}++instance+  (Monoid w, Mergeable w, TryMerge m) =>+  TryMerge (WriterLazy.WriterT w m)+  where+  tryMergeWithStrategy strategy (WriterLazy.WriterT f) =+    WriterLazy.WriterT $+      tryMergeWithStrategy (liftRootStrategy2 strategy rootStrategy) f+  {-# INLINE tryMergeWithStrategy #-}++instance+  (Monoid w, Mergeable w, TryMerge m) =>+  TryMerge (WriterStrict.WriterT w m)+  where+  tryMergeWithStrategy strategy (WriterStrict.WriterT f) =+    WriterStrict.WriterT $+      tryMergeWithStrategy (liftRootStrategy2 strategy rootStrategy) f+  {-# INLINE tryMergeWithStrategy #-}++instance+  (Monoid w, Mergeable w, Mergeable s, TryMerge m) =>+  TryMerge (RWSStrict.RWST r w s m)+  where+  tryMergeWithStrategy strategy (RWSStrict.RWST f) =+    RWSStrict.RWST $+      \r s ->+        tryMergeWithStrategy+          (liftRootStrategy3 strategy rootStrategy rootStrategy)+          (f r s)+  {-# INLINE tryMergeWithStrategy #-}++instance+  (Monoid w, Mergeable w, Mergeable s, TryMerge m) =>+  TryMerge (RWSLazy.RWST r w s m)+  where+  tryMergeWithStrategy strategy (RWSLazy.RWST f) =+    RWSLazy.RWST $+      \r s ->+        tryMergeWithStrategy+          (liftRootStrategy3 strategy rootStrategy rootStrategy)+          (f r s)+  {-# INLINE tryMergeWithStrategy #-}++instance (TryMerge m) => TryMerge (IdentityT m) where+  tryMergeWithStrategy strategy (IdentityT ma) =+    IdentityT $ tryMergeWithStrategy strategy ma+  {-# INLINE tryMergeWithStrategy #-}++instance (TryMerge m, Mergeable r) => TryMerge (ContT r m) where+  tryMergeWithStrategy _ (ContT ma) =+    ContT $ \c -> tryMergeWithStrategy rootStrategy (ma c)+  {-# INLINE tryMergeWithStrategy #-}++#define TRYMERGE_ID(T) \+  instance TryMerge (T) where { \+    tryMergeWithStrategy _ = id; {-# INLINE tryMergeWithStrategy #-} \+  }++#if 1+TRYMERGE_ID(Either a)+TRYMERGE_ID(Maybe)+TRYMERGE_ID([])+TRYMERGE_ID((,) a)+TRYMERGE_ID((,,) a b)+TRYMERGE_ID((,,,) a b c)+TRYMERGE_ID((,,,,) a b c d)+TRYMERGE_ID((,,,,,) a b c d e)+TRYMERGE_ID((,,,,,,) a b c d e f)+TRYMERGE_ID((,,,,,,,) a b c d e f g)+TRYMERGE_ID((,,,,,,,,) a b c d e f g h)+#endif++instance (TryMerge f, TryMerge g) => TryMerge (Sum f g) where+  tryMergeWithStrategy strategy (InL fa) =+    InL $ tryMergeWithStrategy strategy fa+  tryMergeWithStrategy strategy (InR fa) =+    InR $ tryMergeWithStrategy strategy fa++instance TryMerge Monoid.Sum where+  tryMergeWithStrategy _ = id+  {-# INLINE tryMergeWithStrategy #-}
+ src/Grisette/Internal/Internal/Impl/Core/Data/UnionBase.hs view
@@ -0,0 +1,162 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeFamilies #-}++-- |+-- Module      :   Grisette.Internal.Internal.Impl.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.Internal.Impl.Core.Data.UnionBase+  (+  )+where++#if MIN_VERSION_prettyprinter(1,7,0)+import Prettyprinter (align, group, nest, vsep)+#else+import Data.Text.Prettyprint.Doc (align, group, nest, vsep)+#endif++import Control.DeepSeq (NFData (rnf), NFData1 (liftRnf), rnf1)+import qualified Data.Binary as Binary+import Data.Bytes.Get (MonadGet (getWord8))+import Data.Bytes.Put (MonadPut (putWord8))+import Data.Bytes.Serial (Serial (deserialize, serialize))+import Data.Functor.Classes+  ( Eq1 (liftEq),+    Show1 (liftShowsPrec),+    showsPrec1,+    showsUnaryWith,+  )+import Data.Hashable (Hashable (hashWithSalt))+import qualified Data.Serialize as Cereal+import Grisette.Internal.Core.Data.Class.AsKey+  ( KeyHashable (keyHashWithSalt),+    KeyHashable1 (liftKeyHashWithSalt),+  )+import Grisette.Internal.Core.Data.Class.Mergeable+  ( Mergeable (rootStrategy),+  )+import Grisette.Internal.Core.Data.Class.PPrint+  ( PPrint (pformatPrec),+    PPrint1 (liftPFormatPrec),+    condEnclose,+    pformatPrec1,+  )+import Grisette.Internal.Internal.Decl.Core.Data.UnionBase+  ( UnionBase (UnionIf, UnionSingle),+    ifWithStrategy,+  )+import Grisette.Internal.SymPrim.AllSyms+  ( AllSyms (allSymsS),+    AllSyms1 (liftAllSymsS),+    SomeSym (SomeSym),+  )++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++instance (Mergeable a, Serial a) => Serial (UnionBase a) where+  serialize (UnionSingle a) = putWord8 0 >> serialize a+  serialize (UnionIf _ _ c a b) =+    putWord8 1 >> serialize c >> serialize a >> serialize b+  deserialize = do+    tag <- getWord8+    case tag of+      0 -> UnionSingle <$> deserialize+      1 ->+        ifWithStrategy rootStrategy+          <$> deserialize+          <*> deserialize+          <*> deserialize+      _ -> fail "Invalid tag"++instance (Mergeable a, Serial a) => Cereal.Serialize (UnionBase a) where+  put = serialize+  get = deserialize++instance (Mergeable a, Serial a) => Binary.Binary (UnionBase a) where+  put = serialize+  get = deserialize++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 (Eq a, Hashable a) => KeyHashable (UnionBase a) where+  keyHashWithSalt = liftKeyHashWithSalt hashWithSalt+  {-# INLINE keyHashWithSalt #-}++instance KeyHashable1 UnionBase where+  liftKeyHashWithSalt f s (UnionSingle a) = s `hashWithSalt` (0 :: Int) `f` a+  liftKeyHashWithSalt f s (UnionIf _ _ c l r) =+    let g = liftKeyHashWithSalt f+     in ( s+            `hashWithSalt` (1 :: Int)+              `keyHashWithSalt` c+        )+          `g` l+          `g` 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)
+ src/Grisette/Internal/Internal/Impl/SymPrim/AllSyms.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.Internal.Impl.SymPrim.AllSyms+-- 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.Internal.Impl.SymPrim.AllSyms () where++import Control.Monad.Except (ExceptT)+import Control.Monad.Identity+  ( Identity,+    IdentityT (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.Sum (Sum)+import Data.Int (Int16, Int32, Int64, Int8)+import Data.Proxy (Proxy)+import Data.Ratio (Ratio, denominator, numerator)+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),+  )+import Grisette.Internal.Core.Control.Exception+  ( AssertionError,+    VerificationConditions,+  )+import Grisette.Internal.Internal.Decl.SymPrim.AllSyms+  ( AllSyms (allSymsS),+    AllSyms1 (liftAllSymsS),+    AllSyms2,+    allSymsS1,+  )+import Grisette.Internal.SymPrim.AlgReal (AlgReal)+import Grisette.Internal.SymPrim.BV (IntN, WordN)+import Grisette.Internal.SymPrim.FP (FP, FPRoundingMode, ValidFP)+import Grisette.Internal.TH.Derivation.Derive (derive)++-- $setup+-- >>> import Grisette.Core+-- >>> import Grisette.SymPrim+-- >>> import Grisette.Backend+-- >>> import Data.Proxy++derive+  [ ''Either,+    ''(,),+    ''(,,),+    ''(,,,),+    ''(,,,,),+    ''(,,,,,),+    ''(,,,,,,),+    ''(,,,,,,,),+    ''(,,,,,,,,),+    ''(,,,,,,,,,),+    ''(,,,,,,,,,,),+    ''(,,,,,,,,,,,),+    ''(,,,,,,,,,,,,),+    ''(,,,,,,,,,,,,,),+    ''(,,,,,,,,,,,,,,)+  ]+  [''AllSyms, ''AllSyms1, ''AllSyms2]+derive+  [ ''[],+    ''Maybe,+    ''Identity,+    ''ExceptT,+    ''MaybeT,+    ''WriterLazy.WriterT,+    ''WriterStrict.WriterT+  ]+  [''AllSyms, ''AllSyms1]+derive+  [ ''(),+    ''AssertionError,+    ''VerificationConditions+  ]+  [''AllSyms]++-- 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+  (AllSyms1 m, AllSyms a) =>+  AllSyms (IdentityT m a)+  where+  allSymsS = allSymsS1+  {-# INLINE allSymsS #-}++instance (AllSyms1 m) => AllSyms1 (IdentityT m) where+  liftAllSymsS f (IdentityT a) = liftAllSymsS f a+  {-# INLINE liftAllSymsS #-}++#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)+CONCRETE_ALLSYMS(AlgReal)+#endif++instance AllSyms (Proxy a) where+  allSymsS _ = id+  {-# INLINE allSymsS #-}++instance AllSyms1 Proxy where+  liftAllSymsS _ _ = id+  {-# INLINE liftAllSymsS #-}++instance (AllSyms a) => AllSyms (Ratio a) where+  allSymsS r = allSymsS (numerator r) . allSymsS (denominator r)+  {-# INLINE allSymsS #-}++instance (ValidFP eb sb) => AllSyms (FP eb sb) where+  allSymsS _ = id+  {-# INLINE allSymsS #-}
+ src/Grisette/Internal/Internal/Impl/Unified/BVFPConversion.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.Internal.Impl.Unified.BVFPConversion+-- 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.Internal.Impl.Unified.BVFPConversion+  ( UnifiedBVFPConversion,+    SafeUnifiedBVFPConversion,+    AllUnifiedBVFPConversion,+  )+where++import Control.Monad.Error.Class (MonadError)+import GHC.TypeLits (KnownNat, type (+), type (<=))+import Grisette.Internal.Internal.Decl.Unified.BVFPConversion+  ( AllUnifiedBVFPConversion,+    SafeUnifiedBVFPConversion,+    SafeUnifiedBVFPConversionImpl,+    UnifiedBVFPConversion,+    UnifiedBVFPConversionImpl,+  )+import Grisette.Internal.Internal.Decl.Unified.UnifiedBV+  ( UnifiedBVImpl (GetIntN, GetWordN),+  )+import Grisette.Internal.Internal.Decl.Unified.UnifiedFP+  ( UnifiedFPImpl (GetFP, GetFPRoundingMode),+  )+import Grisette.Internal.Internal.Impl.Unified.UnifiedBV ()+import Grisette.Internal.Internal.Impl.Unified.UnifiedFP ()+import Grisette.Internal.SymPrim.BV (IntN, WordN)+import Grisette.Internal.SymPrim.FP+  ( FP,+    FPRoundingMode,+    NotRepresentableFPError,+    ValidFP,+  )+import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN)+import Grisette.Internal.SymPrim.SymFP (SymFP, SymFPRoundingMode)+import Grisette.Internal.Unified.Class.UnifiedSafeBitCast (UnifiedSafeBitCast)+import Grisette.Internal.Unified.Class.UnifiedSafeFromFP (UnifiedSafeFromFP)+import Grisette.Internal.Unified.Class.UnifiedSimpleMergeable (UnifiedBranching)+import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C, S))++instance+  (ValidFP eb sb, KnownNat n, 1 <= n, n ~ (eb + sb)) =>+  UnifiedBVFPConversionImpl+    'C+    WordN+    IntN+    FP+    n+    eb+    sb+    (WordN n)+    (IntN n)+    (FP eb sb)+    FPRoundingMode++instance+  (ValidFP eb sb, KnownNat n, 1 <= n, n ~ (eb + sb)) =>+  UnifiedBVFPConversionImpl+    'S+    SymWordN+    SymIntN+    SymFP+    n+    eb+    sb+    (SymWordN n)+    (SymIntN n)+    (SymFP eb sb)+    SymFPRoundingMode++instance+  ( UnifiedBVFPConversionImpl mode wordn intn fpn n eb sb word int fp fprd,+    UnifiedSafeBitCast mode NotRepresentableFPError fp int m,+    UnifiedSafeBitCast mode NotRepresentableFPError fp word m,+    UnifiedSafeFromFP mode NotRepresentableFPError word fp fprd m+  ) =>+  SafeUnifiedBVFPConversionImpl mode wordn intn fpn n eb sb word int fp fprd m++instance+  ( SafeUnifiedBVFPConversionImpl+      mode+      (GetWordN mode)+      (GetIntN mode)+      (GetFP mode)+      n+      eb+      sb+      (GetWordN mode n)+      (GetIntN mode n)+      (GetFP mode eb sb)+      (GetFPRoundingMode mode)+      m+  ) =>+  SafeUnifiedBVFPConversion mode n eb sb m++instance+  ( UnifiedBVFPConversionImpl+      (mode :: EvalModeTag)+      (GetWordN mode)+      (GetIntN mode)+      (GetFP mode)+      n+      eb+      sb+      (GetWordN mode n)+      (GetIntN mode n)+      (GetFP mode eb sb)+      (GetFPRoundingMode mode)+  ) =>+  UnifiedBVFPConversion mode n eb sb++instance+  ( forall n eb sb.+    (ValidFP eb sb, KnownNat n, 1 <= n, n ~ (eb + sb)) =>+    UnifiedBVFPConversion mode n eb sb,+    forall n eb sb m.+    ( UnifiedBranching mode m,+      ValidFP eb sb,+      KnownNat n,+      1 <= n,+      n ~ (eb + sb),+      MonadError NotRepresentableFPError m+    ) =>+    SafeUnifiedBVFPConversion mode n eb sb m+  ) =>+  AllUnifiedBVFPConversion mode
+ src/Grisette/Internal/Internal/Impl/Unified/Class/UnifiedITEOp.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Eta reduce" #-}++-- |+-- Module      :   Grisette.Internal.Internal.Impl.Unified.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.Internal.Internal.Impl.Unified.Class.UnifiedITEOp+  ( symIte,+    symIteMerge,+  )+where++import Data.Kind (Constraint)+import Data.Type.Bool (If)+import Grisette.Internal.Core.Control.Monad.Union (Union)+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 Grisette.Internal.Core.Data.Class.UnionView+  ( UnionView,+    pattern If,+    pattern Single,+  )+import qualified Grisette.Internal.Core.Data.Class.UnionView+import Grisette.Internal.Internal.Decl.Unified.Class.UnifiedITEOp+  ( UnifiedITEOp (withBaseITEOp),+  )+import Grisette.Internal.Unified.Class.UnionViewMode (UnionViewMode)+import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (S), IsConMode)+import Grisette.Internal.Unified.UnifiedBool (UnifiedBool (GetBool))+import Grisette.Internal.Unified.Util (DecideEvalMode, 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.+  (DecideEvalMode 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 (... :: GetData mode v) ...+symIteMerge ::+  forall mode u v.+  ( DecideEvalMode mode,+    UnifiedITEOp mode v,+    Mergeable v,+    UnionViewMode mode u,+    UnionView u+  ) =>+  u v ->+  v+symIteMerge m =+  withMode @mode+    ( withBaseITEOp @mode @v $ case m of+        Single x -> x+        If {} ->+          error "symIteMerge: If case should not happen under concrete mode"+    )+    ( withBaseITEOp @mode @v $+        Grisette.Internal.Core.Data.Class.UnionView.symIteMerge m+    )++instance+  {-# INCOHERENT #-}+  ( DecideEvalMode mode,+    If (IsConMode mode) (() :: Constraint) (ITEOp a)+  ) =>+  UnifiedITEOp mode a+  where+  withBaseITEOp r = withMode @mode r r+  {-# INLINE withBaseITEOp #-}++instance (UnifiedITEOp 'S v, Mergeable v) => UnifiedITEOp 'S (Union v) where+  withBaseITEOp r = withBaseITEOp @'S @v r+  {-# INLINE withBaseITEOp #-}
+ src/Grisette/Internal/Internal/Impl/Unified/Class/UnifiedSimpleMergeable.hs view
@@ -0,0 +1,740 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.Internal.Impl.Unified.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.Internal.Internal.Impl.Unified.Class.UnifiedSimpleMergeable+  ( mrgIf,+    liftUnion,+    mrgIte,+    mrgIte1,+    liftMrgIte,+    mrgIte2,+    liftMrgIte2,+    simpleMerge,+    (.#),+    onUnion,+    onUnion2,+    onUnion3,+    onUnion4,+  )+where++import Control.Monad.Cont (ContT)+import Control.Monad.Except (ExceptT)+import Control.Monad.Identity (Identity, 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 Grisette.Internal.Core.Control.Exception (AssertionError)+import Grisette.Internal.Core.Data.Class.Function (Function ((#)))+import Grisette.Internal.Core.Data.Class.GenSym (FreshT)+import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable, Mergeable1)+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,+    tryMerge,+  )+import Grisette.Internal.Core.Data.Class.UnionView+  ( UnionView,+    pattern If,+    pattern Single,+  )+import qualified Grisette.Internal.Core.Data.Class.UnionView as Grisette+import Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSimpleMergeable+  ( UnifiedBranching (withBaseBranching),+    UnifiedSimpleMergeable (withBaseSimpleMergeable),+    UnifiedSimpleMergeable1 (withBaseSimpleMergeable1),+    UnifiedSimpleMergeable2 (withBaseSimpleMergeable2),+  )+import Grisette.Internal.TH.Derivation.Derive (derive)+import Grisette.Internal.Unified.Class.UnionViewMode (UnionViewMode)+import Grisette.Internal.Unified.EvalModeTag (IsConMode)+import Grisette.Internal.Unified.UnifiedBool (UnifiedBool (GetBool))+import Grisette.Internal.Unified.Util (DecideEvalMode, 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.+  (DecideEvalMode 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.+liftUnion ::+  forall mode a m u.+  ( Applicative m,+    UnifiedBranching mode m,+    Mergeable a,+    UnionView u,+    UnionViewMode mode u+  ) =>+  u a ->+  m a+liftUnion b =+  withMode @mode+    ( withBaseBranching @mode @m $ case b of+        Single x -> mrgSingle x+        If {} ->+          error "liftUnion: If case should not happen under concrete mode"+    )+    (withBaseBranching @mode @m $ Grisette.liftUnion b)+{-# INLINE liftUnion #-}++-- | Unified merge of simply mergeable values in the base monad.+simpleMerge ::+  forall mode a u.+  ( UnifiedSimpleMergeable mode a,+    UnionView u,+    UnionViewMode mode u+  ) =>+  u a ->+  a+simpleMerge =+  withMode @mode+    ( \case+        Single x -> x+        If {} ->+          error "simpleMerge: If case should not happen under concrete mode"+    )+    (withBaseSimpleMergeable @mode @a Grisette.simpleMerge)++(.#) ::+  (Function f a r, UnifiedSimpleMergeable mode r, UnionView u, UnionViewMode mode u) =>+  f ->+  u a ->+  r+(.#) f u = simpleMerge $ fmap (f #) u+{-# INLINE (.#) #-}++infixl 9 .#++onUnion ::+  ( UnifiedSimpleMergeable mode r,+    UnifiedBranching mode u,+    Mergeable a,+    UnionView u,+    UnionViewMode mode u+  ) =>+  (a -> r) -> (u a -> r)+onUnion f = simpleMerge . fmap f . tryMerge++onUnion2 ::+  ( UnifiedSimpleMergeable mode r,+    UnifiedBranching mode u,+    Mergeable a,+    Mergeable b,+    UnionView u,+    UnionViewMode mode u+  ) =>+  (a -> b -> r) -> (u a -> u b -> r)+onUnion2 f ua ub = simpleMerge $ f <$> tryMerge ua <*> tryMerge ub++onUnion3 ::+  ( UnifiedSimpleMergeable mode r,+    UnifiedBranching mode u,+    Mergeable a,+    Mergeable b,+    Mergeable c,+    UnionView u,+    UnionViewMode mode u+  ) =>+  (a -> b -> c -> r) -> (u a -> u b -> u c -> r)+onUnion3 f ua ub uc = simpleMerge $ f <$> tryMerge ua <*> tryMerge ub <*> tryMerge uc++onUnion4 ::+  ( UnifiedSimpleMergeable mode r,+    UnifiedBranching mode u,+    Mergeable a,+    Mergeable b,+    Mergeable c,+    Mergeable d,+    UnionView u,+    UnionViewMode mode u+  ) =>+  (a -> b -> c -> d -> r) -> (u a -> u b -> u c -> u d -> r)+onUnion4 f ua ub uc ud = simpleMerge $ f <$> tryMerge ua <*> tryMerge ub <*> tryMerge uc <*> tryMerge ud++-- | Unified `Grisette.mrgIte`.+mrgIte ::+  forall mode a.+  (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.+  ( 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.+  (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.+  ( 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.+  (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+    )++instance+  {-# INCOHERENT #-}+  ( DecideEvalMode mode,+    TryMerge m,+    If (IsConMode mode) ((TryMerge m) :: Constraint) (SymBranching m)+  ) =>+  UnifiedBranching mode m+  where+  withBaseBranching r = r+  {-# INLINE withBaseBranching #-}++instance+  {-# INCOHERENT #-}+  ( DecideEvalMode mode,+    Mergeable m,+    If (IsConMode mode) (() :: Constraint) (SimpleMergeable m)+  ) =>+  UnifiedSimpleMergeable mode m+  where+  withBaseSimpleMergeable r = r+  {-# INLINE withBaseSimpleMergeable #-}++instance+  {-# INCOHERENT #-}+  ( DecideEvalMode mode,+    If (IsConMode mode) (() :: Constraint) (SimpleMergeable1 m)+  ) =>+  UnifiedSimpleMergeable1 mode m+  where+  withBaseSimpleMergeable1 r = r+  {-# INLINE withBaseSimpleMergeable1 #-}++instance+  {-# INCOHERENT #-}+  ( DecideEvalMode mode,+    If (IsConMode mode) (() :: Constraint) (SimpleMergeable2 m)+  ) =>+  UnifiedSimpleMergeable2 mode m+  where+  withBaseSimpleMergeable2 r = r+  {-# INLINE withBaseSimpleMergeable2 #-}++derive+  [ ''(,),+    ''(,,),+    ''(,,,),+    ''(,,,,),+    ''(,,,,,),+    ''(,,,,,,),+    ''(,,,,,,,),+    ''(,,,,,,,,),+    ''(,,,,,,,,,),+    ''(,,,,,,,,,,),+    ''(,,,,,,,,,,,),+    ''(,,,,,,,,,,,,),+    ''(,,,,,,,,,,,,,),+    ''(,,,,,,,,,,,,,,)+  ]+  [ ''UnifiedSimpleMergeable,+    ''UnifiedSimpleMergeable1,+    ''UnifiedSimpleMergeable2+  ]++derive+  [''Identity]+  [''UnifiedSimpleMergeable, ''UnifiedSimpleMergeable1]++derive+  [''(), ''AssertionError]+  [''UnifiedSimpleMergeable]++instance+  (UnifiedSimpleMergeable mode b) =>+  UnifiedSimpleMergeable mode (a -> b)+  where+  withBaseSimpleMergeable r =+    withMode @mode+      (withBaseSimpleMergeable @mode @b r)+      (withBaseSimpleMergeable @mode @b r)+  {-# INLINE withBaseSimpleMergeable #-}++instance (DecideEvalMode mode) => UnifiedSimpleMergeable1 mode ((->) a) where+  withBaseSimpleMergeable1 r = withMode @mode r r+  {-# INLINE withBaseSimpleMergeable1 #-}++instance (DecideEvalMode mode) => UnifiedSimpleMergeable2 mode (->) where+  withBaseSimpleMergeable2 r = withMode @mode r r+  {-# INLINE withBaseSimpleMergeable2 #-}++instance+  (UnifiedBranching mode m, Mergeable a, Mergeable1 m) =>+  UnifiedSimpleMergeable mode (FreshT m a)+  where+  withBaseSimpleMergeable r =+    withMode @mode+      (withBaseBranching @mode @m r)+      (withBaseBranching @mode @m r)+  {-# INLINE withBaseSimpleMergeable #-}++instance+  (UnifiedBranching mode m) =>+  UnifiedSimpleMergeable1 mode (FreshT m)+  where+  withBaseSimpleMergeable1 r =+    withMode @mode+      (withBaseBranching @mode @m r)+      (withBaseBranching @mode @m r)+  {-# INLINE withBaseSimpleMergeable1 #-}++instance+  (UnifiedBranching mode m) =>+  UnifiedBranching mode (FreshT m)+  where+  withBaseBranching r =+    withMode @mode+      (withBaseBranching @mode @m r)+      (withBaseBranching @mode @m r)+  {-# INLINE withBaseBranching #-}++instance+  (UnifiedBranching mode m, Mergeable a, Mergeable1 m) =>+  UnifiedSimpleMergeable mode (MaybeT m a)+  where+  withBaseSimpleMergeable r =+    withMode @mode+      (withBaseBranching @mode @m r)+      (withBaseBranching @mode @m r)+  {-# INLINE withBaseSimpleMergeable #-}++instance+  (UnifiedBranching mode m) =>+  UnifiedSimpleMergeable1 mode (MaybeT m)+  where+  withBaseSimpleMergeable1 r =+    withMode @mode+      (withBaseBranching @mode @m r)+      (withBaseBranching @mode @m r)+  {-# INLINE withBaseSimpleMergeable1 #-}++instance+  (UnifiedBranching mode m) =>+  UnifiedBranching mode (MaybeT m)+  where+  withBaseBranching r =+    withMode @mode+      (withBaseBranching @mode @m r)+      (withBaseBranching @mode @m r)+  {-# INLINE withBaseBranching #-}++instance+  (UnifiedBranching mode m, Mergeable a, Mergeable1 m) =>+  UnifiedSimpleMergeable mode (IdentityT m a)+  where+  withBaseSimpleMergeable r =+    withMode @mode+      (withBaseBranching @mode @m r)+      (withBaseBranching @mode @m r)+  {-# INLINE withBaseSimpleMergeable #-}++instance+  (UnifiedBranching mode m) =>+  UnifiedSimpleMergeable1 mode (IdentityT m)+  where+  withBaseSimpleMergeable1 r =+    withMode @mode+      (withBaseBranching @mode @m r)+      (withBaseBranching @mode @m r)+  {-# INLINE withBaseSimpleMergeable1 #-}++instance+  (UnifiedBranching mode m) =>+  UnifiedBranching mode (IdentityT m)+  where+  withBaseBranching r =+    withMode @mode+      (withBaseBranching @mode @m r)+      (withBaseBranching @mode @m r)+  {-# INLINE withBaseBranching #-}++instance+  (UnifiedBranching mode m, Mergeable a, Mergeable1 m) =>+  UnifiedSimpleMergeable mode (ReaderT r m a)+  where+  withBaseSimpleMergeable r =+    withMode @mode+      (withBaseBranching @mode @m r)+      (withBaseBranching @mode @m r)+  {-# INLINE withBaseSimpleMergeable #-}++instance+  (UnifiedBranching mode m) =>+  UnifiedSimpleMergeable1 mode (ReaderT r m)+  where+  withBaseSimpleMergeable1 r =+    withMode @mode+      (withBaseBranching @mode @m r)+      (withBaseBranching @mode @m r)+  {-# INLINE withBaseSimpleMergeable1 #-}++instance+  (UnifiedBranching mode m) =>+  UnifiedBranching mode (ReaderT r m)+  where+  withBaseBranching r =+    withMode @mode+      (withBaseBranching @mode @m r)+      (withBaseBranching @mode @m r)+  {-# INLINE withBaseBranching #-}++instance+  (UnifiedBranching mode m, Mergeable s, Mergeable a, Mergeable1 m) =>+  UnifiedSimpleMergeable mode (StateLazy.StateT s m a)+  where+  withBaseSimpleMergeable r =+    withMode @mode+      (withBaseBranching @mode @m r)+      (withBaseBranching @mode @m r)+  {-# INLINE withBaseSimpleMergeable #-}++instance+  (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+  (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+  (UnifiedBranching mode m, Mergeable s, Mergeable a, Mergeable1 m) =>+  UnifiedSimpleMergeable mode (StateStrict.StateT s m a)+  where+  withBaseSimpleMergeable r =+    withMode @mode+      (withBaseBranching @mode @m r)+      (withBaseBranching @mode @m r)+  {-# INLINE withBaseSimpleMergeable #-}++instance+  (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+  (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+  (UnifiedBranching mode m, Mergeable w, Mergeable a, Monoid w, Mergeable1 m) =>+  UnifiedSimpleMergeable mode (WriterLazy.WriterT w m a)+  where+  withBaseSimpleMergeable r =+    withMode @mode+      (withBaseBranching @mode @m r)+      (withBaseBranching @mode @m r)+  {-# INLINE withBaseSimpleMergeable #-}++instance+  (UnifiedBranching mode m, Mergeable w, Monoid w, Mergeable1 m) =>+  UnifiedSimpleMergeable1 mode (WriterLazy.WriterT w m)+  where+  withBaseSimpleMergeable1 r =+    withMode @mode+      (withBaseBranching @mode @m r)+      (withBaseBranching @mode @m r)+  {-# INLINE withBaseSimpleMergeable1 #-}++instance+  (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+  (UnifiedBranching mode m, Mergeable w, Mergeable a, Monoid w, Mergeable1 m) =>+  UnifiedSimpleMergeable mode (WriterStrict.WriterT w m a)+  where+  withBaseSimpleMergeable r =+    withMode @mode+      (withBaseBranching @mode @m r)+      (withBaseBranching @mode @m r)+  {-# INLINE withBaseSimpleMergeable #-}++instance+  (UnifiedBranching mode m, Mergeable w, Monoid w, Mergeable1 m) =>+  UnifiedSimpleMergeable1 mode (WriterStrict.WriterT w m)+  where+  withBaseSimpleMergeable1 r =+    withMode @mode+      (withBaseBranching @mode @m r)+      (withBaseBranching @mode @m r)+  {-# INLINE withBaseSimpleMergeable1 #-}++instance+  (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+  (UnifiedBranching mode m, Mergeable e, Mergeable a, Mergeable1 m) =>+  UnifiedSimpleMergeable mode (ExceptT e m a)+  where+  withBaseSimpleMergeable r =+    withMode @mode+      (withBaseBranching @mode @m r)+      (withBaseBranching @mode @m r)+  {-# INLINE withBaseSimpleMergeable #-}++instance+  (UnifiedBranching mode m, Mergeable e, Mergeable1 m) =>+  UnifiedSimpleMergeable1 mode (ExceptT e m)+  where+  withBaseSimpleMergeable1 r =+    withMode @mode+      (withBaseBranching @mode @m r)+      (withBaseBranching @mode @m r)+  {-# INLINE withBaseSimpleMergeable1 #-}++instance+  (UnifiedBranching mode m, Mergeable e) =>+  UnifiedBranching mode (ExceptT e m)+  where+  withBaseBranching r =+    withMode @mode+      (withBaseBranching @mode @m r)+      (withBaseBranching @mode @m r)+  {-# INLINE withBaseBranching #-}++instance+  (UnifiedBranching mode m, Mergeable r, Mergeable a, Mergeable1 m) =>+  UnifiedSimpleMergeable mode (ContT r m a)+  where+  withBaseSimpleMergeable r =+    withMode @mode+      (withBaseBranching @mode @m r)+      (withBaseBranching @mode @m r)+  {-# INLINE withBaseSimpleMergeable #-}++instance+  (UnifiedBranching mode m, Mergeable r, Mergeable1 m) =>+  UnifiedSimpleMergeable1 mode (ContT r m)+  where+  withBaseSimpleMergeable1 r =+    withMode @mode+      (withBaseBranching @mode @m r)+      (withBaseBranching @mode @m r)+  {-# INLINE withBaseSimpleMergeable1 #-}++instance+  (UnifiedBranching mode m, Mergeable r, Mergeable1 m) =>+  UnifiedBranching mode (ContT r m)+  where+  withBaseBranching r =+    withMode @mode+      (withBaseBranching @mode @m r)+      (withBaseBranching @mode @m r)+  {-# INLINE withBaseBranching #-}++instance+  (UnifiedBranching mode m, Mergeable w, Monoid w, Mergeable s, Mergeable a, Mergeable1 m) =>+  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+  (UnifiedBranching mode m, Mergeable w, Monoid w, Mergeable s, Mergeable1 m) =>+  UnifiedSimpleMergeable1 mode (RWSLazy.RWST r w s m)+  where+  withBaseSimpleMergeable1 r =+    withMode @mode+      (withBaseBranching @mode @m r)+      (withBaseBranching @mode @m r)+  {-# INLINE withBaseSimpleMergeable1 #-}++instance+  (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+  (UnifiedBranching mode m, Mergeable w, Monoid w, Mergeable s, Mergeable a, Mergeable1 m) =>+  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+  (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+  (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 #-}
+ src/Grisette/Internal/Internal/Impl/Unified/Class/UnifiedSymEq.hs view
@@ -0,0 +1,364 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Eta reduce" #-}++-- |+-- Module      :   Grisette.Internal.Internal.Impl.Unified.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.Internal.Internal.Impl.Unified.Class.UnifiedSymEq+  ( (.==),+    (./=),+    symDistinct,+    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 Data.Ratio (Ratio)+import qualified Data.Text as T+import Data.Type.Bool (If)+import Data.Word (Word16, Word32, Word64, Word8)+import Grisette.Internal.Core.Control.Exception+  ( AssertionError,+    VerificationConditions,+  )+import Grisette.Internal.Core.Control.Monad.Union (Union)+import Grisette.Internal.Internal.Decl.Core.Data.Class.SymEq+  ( SymEq,+    SymEq1,+    SymEq2,+  )+import qualified Grisette.Internal.Internal.Decl.Core.Data.Class.SymEq as SymEq+import Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSymEq+  ( UnifiedSymEq (withBaseSymEq),+    UnifiedSymEq1 (withBaseSymEq1),+    UnifiedSymEq2 (withBaseSymEq2),+  )+import Grisette.Internal.SymPrim.BV (IntN, WordN)+import Grisette.Internal.SymPrim.FP (FP, FPRoundingMode)+import Grisette.Internal.TH.Derivation.Common+  ( DeriveConfig (bitSizePositions, fpBitSizePositions),+  )+import Grisette.Internal.TH.Derivation.Derive (derive, deriveWith)+import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (S), IsConMode)+import Grisette.Internal.Unified.UnifiedBool (UnifiedBool (GetBool))+import Grisette.Internal.Unified.Util (DecideEvalMode, 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.Internal.Unified.Class.UnifiedBranching.mrgIf`.+(.==) ::+  forall mode a. (DecideEvalMode mode, UnifiedSymEq mode a) => a -> a -> GetBool mode+(.==) a b =+  withMode @mode+    (withBaseSymEq @mode @a $ a == b)+    (withBaseSymEq @mode @a $ a SymEq..== b)+{-# INLINE (.==) #-}++infix 4 .==++-- | 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.Internal.Unified.Class.UnifiedBranching.mrgIf`.+(./=) ::+  forall mode a. (DecideEvalMode mode, UnifiedSymEq mode a) => a -> a -> GetBool mode+(./=) a b =+  withMode @mode+    (withBaseSymEq @mode @a $ a /= b)+    (withBaseSymEq @mode @a $ a SymEq../= b)+{-# INLINE (./=) #-}++infix 4 ./=++-- | Unified `Grisette.Internal.Core.Data.Class.SymEq.symDistinct`.+--+-- Note that you may sometimes need to write type annotations for the result+-- when the mode isn't clear:+--+-- > symDistinct l :: GetBool mode+--+-- One example when it isn't clear is when this is used in unified+-- `Grisette.Internal.Unified.Class.UnifiedBranching.mrgIf`.+symDistinct ::+  forall mode a. (DecideEvalMode mode, UnifiedSymEq mode a) => [a] -> GetBool mode+symDistinct l =+  withMode @mode+    ( withBaseSymEq @mode @a $+        SymEq.distinct l+    )+    ( withBaseSymEq @mode @a $+        SymEq.symDistinct l+    )++-- | Unified `Grisette.Internal.Core.Data.Class.SymEq.liftSymEq`.+liftSymEq ::+  forall mode f a b.+  (DecideEvalMode 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 $+        SymEq.liftSymEq f a b+    )++-- | Unified `Grisette.Internal.Core.Data.Class.SymEq.symEq1`.+symEq1 ::+  forall mode f a.+  (DecideEvalMode 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 $+          SymEq.symEq1 a b+    )++-- | Unified `Grisette.Internal.Core.Data.Class.SymEq.liftSymEq2`.+liftSymEq2 ::+  forall mode f a b c d.+  (DecideEvalMode 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 $+        SymEq.liftSymEq2 f a b+    )++-- | Unified `Grisette.Internal.Core.Data.Class.SymEq.symEq2`.+symEq2 ::+  forall mode f a b.+  ( DecideEvalMode 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 $+            SymEq.symEq2 a b+    )++instance+  {-# INCOHERENT #-}+  (DecideEvalMode mode, If (IsConMode mode) (Eq a) (SymEq a)) =>+  UnifiedSymEq mode a+  where+  withBaseSymEq r = r+  {-# INLINE withBaseSymEq #-}++instance+  {-# INCOHERENT #-}+  ( DecideEvalMode 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 #-}+  ( DecideEvalMode 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 #-}++instance (UnifiedSymEq 'S v) => UnifiedSymEq 'S (Union v) where+  withBaseSymEq r = withBaseSymEq @'S @v r+  {-# INLINE withBaseSymEq #-}++derive+  [ ''Either,+    ''(,)+  ]+  [''UnifiedSymEq, ''UnifiedSymEq1, ''UnifiedSymEq2]++derive+  [ ''[],+    ''Maybe,+    ''Identity,+    ''ExceptT,+    ''MaybeT,+    ''WriterLazy.WriterT,+    ''WriterStrict.WriterT+  ]+  [''UnifiedSymEq, ''UnifiedSymEq1]++derive+  [ ''Bool,+    ''Integer,+    ''Char,+    ''Int,+    ''Int8,+    ''Int16,+    ''Int32,+    ''Int64,+    ''Word,+    ''Word8,+    ''Word16,+    ''Word32,+    ''Word64,+    ''Float,+    ''Double,+    ''B.ByteString,+    ''T.Text,+    ''FPRoundingMode,+    ''(),+    ''(,,,,),+    ''(,,,,,),+    ''(,,,,,,),+    ''(,,,,,,,),+    ''(,,,,,,,,),+    ''(,,,,,,,,,),+    ''(,,,,,,,,,,),+    ''(,,,,,,,,,,,),+    ''(,,,,,,,,,,,,),+    ''(,,,,,,,,,,,,,),+    ''(,,,,,,,,,,,,,,),+    ''AssertionError,+    ''VerificationConditions,+    ''Ratio+  ]+  [''UnifiedSymEq]++#if MIN_VERSION_base(4,16,0)+derive+  [ ''(,,),+    ''(,,,)+  ]+  [''UnifiedSymEq, ''UnifiedSymEq1, ''UnifiedSymEq2]+#else+derive+  [ ''(,,),+    ''(,,,)+  ]+  [''UnifiedSymEq]+#endif++deriveWith+  (mempty {bitSizePositions = [0]})+  [''WordN, ''IntN]+  [''UnifiedSymEq]++deriveWith+  (mempty {fpBitSizePositions = [(0, 1)]})+  [''FP]+  [''UnifiedSymEq]++-- Sum+instance+  ( DecideEvalMode 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+  (DecideEvalMode 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+  (DecideEvalMode 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+  (DecideEvalMode mode, UnifiedSymEq1 mode m) =>+  UnifiedSymEq1 mode (IdentityT m)+  where+  withBaseSymEq1 r =+    withMode @mode (withBaseSymEq1 @mode @m r) (withBaseSymEq1 @mode @m r)+  {-# INLINE withBaseSymEq1 #-}
+ src/Grisette/Internal/Internal/Impl/Unified/Class/UnifiedSymOrd.hs view
@@ -0,0 +1,396 @@+{-# 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 #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Eta reduce" #-}++-- |+-- Module      :   Grisette.Internal.Internal.Impl.Unified.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.Internal.Internal.Impl.Unified.Class.UnifiedSymOrd+  ( (.<=),+    (.<),+    (.>=),+    (.>),+    symMax,+    symMin,+    mrgMax,+    mrgMin,+  )+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 (Ord1, Ord2)+import Data.Functor.Sum (Sum)+import Data.Int (Int16, Int32, Int64, Int8)+import Data.Ratio (Ratio)+import qualified Data.Text as T+import Data.Type.Bool (If)+import Data.Word (Word16, Word32, Word64, Word8)+import Grisette.Internal.Core.Control.Exception+  ( AssertionError,+    VerificationConditions,+  )+import Grisette.Internal.Core.Control.Monad.Union (Union)+import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable)+import Grisette.Internal.Core.Data.Class.TryMerge (tryMerge)+import Grisette.Internal.Internal.Decl.Core.Data.Class.SymOrd+  ( SymOrd,+    SymOrd1,+    SymOrd2,+  )+import qualified Grisette.Internal.Internal.Decl.Core.Data.Class.SymOrd as SymOrd+import Grisette.Internal.Internal.Decl.Unified.Class.UnifiedITEOp+  ( UnifiedITEOp (withBaseITEOp),+  )+import Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSimpleMergeable+  ( UnifiedBranching (withBaseBranching),+  )+import Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSymOrd+  ( UnifiedSymOrd (withBaseSymOrd),+    UnifiedSymOrd1 (withBaseSymOrd1),+    UnifiedSymOrd2 (withBaseSymOrd2),+  )+import Grisette.Internal.SymPrim.BV (IntN, WordN)+import Grisette.Internal.SymPrim.FP (FP, FPRoundingMode)+import Grisette.Internal.TH.Derivation.Common+  ( DeriveConfig (bitSizePositions, fpBitSizePositions),+  )+import Grisette.Internal.TH.Derivation.Derive (derive, deriveWith)+import Grisette.Internal.Unified.EvalModeTag+  ( EvalModeTag (S),+    IsConMode,+  )+import Grisette.Internal.Unified.UnifiedBool (GetBool)+import Grisette.Internal.Unified.Util (DecideEvalMode, 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.Internal.Unified.Class.UnifiedBranching.mrgIf`.+(.<=) ::+  forall mode a. (DecideEvalMode mode, UnifiedSymOrd mode a) => a -> a -> GetBool mode+(.<=) a b =+  withMode @mode+    (withBaseSymOrd @mode @a $ a <= b)+    (withBaseSymOrd @mode @a $ a SymOrd..<= b)+{-# INLINE (.<=) #-}++infix 4 .<=++-- | Unified `(Grisette.Internal.Core.Data.Class.SymOrd..<)`.+(.<) ::+  forall mode a. (DecideEvalMode mode, UnifiedSymOrd mode a) => a -> a -> GetBool mode+(.<) a b =+  withMode @mode+    (withBaseSymOrd @mode @a $ a < b)+    (withBaseSymOrd @mode @a $ a SymOrd..< b)+{-# INLINE (.<) #-}++infix 4 .<++-- | Unified `(Grisette.Internal.Core.Data.Class.SymOrd..>=)`.+(.>=) ::+  forall mode a. (DecideEvalMode mode, UnifiedSymOrd mode a) => a -> a -> GetBool mode+(.>=) a b =+  withMode @mode+    (withBaseSymOrd @mode @a $ a >= b)+    (withBaseSymOrd @mode @a $ a SymOrd..>= b)+{-# INLINE (.>=) #-}++infix 4 .>=++-- | Unified `(Grisette.Internal.Core.Data.Class.SymOrd..>)`.+(.>) ::+  forall mode a. (DecideEvalMode mode, UnifiedSymOrd mode a) => a -> a -> GetBool mode+(.>) a b =+  withMode @mode+    (withBaseSymOrd @mode @a $ a > b)+    (withBaseSymOrd @mode @a $ a SymOrd..> b)+{-# INLINE (.>) #-}++infix 4 .>++-- | Unified `Grisette.Internal.Core.Data.Class.SymOrd.symMax`.+symMax ::+  forall mode a.+  (UnifiedSymOrd mode a, UnifiedITEOp mode a, DecideEvalMode mode) =>+  a ->+  a ->+  a+symMax x y =+  withMode @mode+    (withBaseSymOrd @mode @a $ max x y)+    ( withBaseSymOrd @mode @a $+        withBaseITEOp @mode @a+          SymOrd.symMax+          x+          y+    )+{-# INLINE symMax #-}++-- | Unified `Grisette.Internal.Core.Data.Class.SymOrd.symMin`.+symMin ::+  forall mode a.+  (UnifiedSymOrd mode a, UnifiedITEOp mode a, DecideEvalMode mode) =>+  a ->+  a ->+  a+symMin x y =+  withMode @mode+    (withBaseSymOrd @mode @a $ min x y)+    ( withBaseSymOrd @mode @a $+        withBaseITEOp @mode @a+          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,+    DecideEvalMode 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 $+          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,+    DecideEvalMode 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 $+          SymOrd.mrgMin x y+    )+{-# INLINE mrgMin #-}++instance+  {-# INCOHERENT #-}+  (DecideEvalMode mode, If (IsConMode mode) (Ord a) (SymOrd a)) =>+  UnifiedSymOrd mode a+  where+  withBaseSymOrd r = r+  {-# INLINE withBaseSymOrd #-}++instance+  {-# INCOHERENT #-}+  ( DecideEvalMode 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 #-}+  ( DecideEvalMode 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 #-}++instance (UnifiedSymOrd 'S v) => UnifiedSymOrd 'S (Union v) where+  withBaseSymOrd r = withBaseSymOrd @'S @v r+  {-# INLINE withBaseSymOrd #-}++derive+  [ ''Either,+    ''(,)+  ]+  [''UnifiedSymOrd, ''UnifiedSymOrd1, ''UnifiedSymOrd2]++derive+  [ ''[],+    ''Maybe,+    ''Identity,+    ''ExceptT,+    ''MaybeT,+    ''WriterLazy.WriterT,+    ''WriterStrict.WriterT+  ]+  [''UnifiedSymOrd, ''UnifiedSymOrd1]++derive+  [ ''Bool,+    ''Integer,+    ''Char,+    ''Int,+    ''Int8,+    ''Int16,+    ''Int32,+    ''Int64,+    ''Word,+    ''Word8,+    ''Word16,+    ''Word32,+    ''Word64,+    ''Float,+    ''Double,+    ''B.ByteString,+    ''T.Text,+    ''FPRoundingMode,+    ''(),+    ''(,,,,),+    ''(,,,,,),+    ''(,,,,,,),+    ''(,,,,,,,),+    ''(,,,,,,,,),+    ''(,,,,,,,,,),+    ''(,,,,,,,,,,),+    ''(,,,,,,,,,,,),+    ''(,,,,,,,,,,,,),+    ''(,,,,,,,,,,,,,),+    ''(,,,,,,,,,,,,,,),+    ''AssertionError,+    ''VerificationConditions+  ]+  [''UnifiedSymOrd]++#if MIN_VERSION_base(4,16,0)+derive+  [ ''(,,),+    ''(,,,)+  ]+  [''UnifiedSymOrd, ''UnifiedSymOrd1, ''UnifiedSymOrd2]+#else+derive+  [ ''(,,),+    ''(,,,)+  ]+  [''UnifiedSymOrd]+#endif++deriveWith+  (mempty {bitSizePositions = [0]})+  [''WordN, ''IntN]+  [''UnifiedSymOrd]++deriveWith+  (mempty {fpBitSizePositions = [(0, 1)]})+  [''FP]+  [''UnifiedSymOrd]++instance+  (DecideEvalMode mode, UnifiedSymOrd mode a, Integral a) =>+  UnifiedSymOrd mode (Ratio a)+  where+  withBaseSymOrd r =+    withMode @mode (withBaseSymOrd @mode @a r) (withBaseSymOrd @mode @a r)+  {-# INLINE withBaseSymOrd #-}++-- Sum+instance+  ( DecideEvalMode 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+  (DecideEvalMode 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+  (DecideEvalMode 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+  (DecideEvalMode mode, UnifiedSymOrd1 mode m) =>+  UnifiedSymOrd1 mode (IdentityT m)+  where+  withBaseSymOrd1 r =+    withMode @mode (withBaseSymOrd1 @mode @m r) (withBaseSymOrd1 @mode @m r)+  {-# INLINE withBaseSymOrd1 #-}
+ src/Grisette/Internal/Internal/Impl/Unified/EvalMode.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE DataKinds #-}++-- |+-- Module      :   Grisette.Internal.Internal.Impl.Unified.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.Internal.Internal.Impl.Unified.EvalMode () where++import Grisette.Internal.Internal.Decl.Unified.EvalMode+  ( EvalModeAll,+    EvalModeBV,+    EvalModeBase,+    EvalModeFP,+  )+import Grisette.Internal.Internal.Impl.Unified.BVFPConversion ()+import Grisette.Internal.Internal.Impl.Unified.FPFPConversion ()+import Grisette.Internal.Internal.Impl.Unified.UnifiedBV ()+import Grisette.Internal.Internal.Impl.Unified.UnifiedFP ()+import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C, S))++instance EvalModeBase 'C++instance EvalModeBase 'S++instance EvalModeAll 'C++instance EvalModeAll 'S++instance EvalModeBV 'C++instance EvalModeBV 'S++instance EvalModeFP 'C++instance EvalModeFP 'S
+ src/Grisette/Internal/Internal/Impl/Unified/FPFPConversion.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.Internal.Impl.Unified.FPFPConversion+-- 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.Internal.Impl.Unified.FPFPConversion () where++import Grisette.Internal.Internal.Decl.Unified.FPFPConversion+  ( AllUnifiedFPFPConversion,+    UnifiedFPFPConversion,+    UnifiedFPFPConversionImpl,+  )+import Grisette.Internal.Internal.Decl.Unified.UnifiedFP+  ( UnifiedFPImpl (GetFP, GetFPRoundingMode),+  )+import Grisette.Internal.Internal.Impl.Unified.UnifiedFP ()+import Grisette.Internal.SymPrim.FP (FP, FPRoundingMode, ValidFP)+import Grisette.Internal.SymPrim.SymFP (SymFP, SymFPRoundingMode)+import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C, S))++instance+  (ValidFP eb0 sb0, ValidFP eb1 sb1) =>+  UnifiedFPFPConversionImpl+    'C+    FP+    eb0+    sb0+    eb1+    sb1+    (FP eb0 sb0)+    (FP eb1 sb1)+    FPRoundingMode++instance+  (ValidFP eb0 sb0, ValidFP eb1 sb1) =>+  UnifiedFPFPConversionImpl+    'S+    SymFP+    eb0+    sb0+    eb1+    sb1+    (SymFP eb0 sb0)+    (SymFP eb1 sb1)+    SymFPRoundingMode++instance+  ( UnifiedFPFPConversionImpl+      (mode :: EvalModeTag)+      (GetFP mode)+      eb0+      sb0+      eb1+      sb1+      (GetFP mode eb0 sb0)+      (GetFP mode eb1 sb1)+      (GetFPRoundingMode mode)+  ) =>+  UnifiedFPFPConversion mode eb0 sb0 eb1 sb1++instance+  ( forall eb0 sb0 eb1 sb1.+    (ValidFP eb0 sb0, ValidFP eb1 sb1) =>+    UnifiedFPFPConversion+      mode+      eb0+      sb0+      eb1+      sb1+  ) =>+  AllUnifiedFPFPConversion mode
+ src/Grisette/Internal/Internal/Impl/Unified/UnifiedBV.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UndecidableSuperClasses #-}++-- |+-- Module      :   Grisette.Internal.Internal.Impl.Unified.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.Internal.Internal.Impl.Unified.UnifiedBV () where++import Control.Exception (ArithException)+import Control.Monad.Except (MonadError)+import GHC.TypeLits (KnownNat, type (<=))+import Grisette.Internal.Core.Data.Class.BitVector (SizedBV)+import Grisette.Internal.Internal.Decl.Unified.UnifiedBV+  ( AllUnifiedBV,+    GetSomeIntN,+    GetSomeWordN,+    SafeUnifiedBV,+    SafeUnifiedBVImpl,+    SafeUnifiedSomeBV,+    SafeUnifiedSomeBVImpl,+    SomeBVPair,+    UnifiedBV,+    UnifiedBVImpl (GetIntN, GetWordN),+  )+import Grisette.Internal.SymPrim.BV (IntN, WordN)+import Grisette.Internal.SymPrim.SomeBV+  ( SomeBV,+    SomeBVException,+  )+import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN)+import Grisette.Internal.Unified.Class.UnifiedSafeDiv (UnifiedSafeDiv)+import Grisette.Internal.Unified.Class.UnifiedSafeLinearArith+  ( UnifiedSafeLinearArith,+  )+import Grisette.Internal.Unified.Class.UnifiedSafeSymRotate+  ( UnifiedSafeSymRotate,+  )+import Grisette.Internal.Unified.Class.UnifiedSafeSymShift (UnifiedSafeSymShift)+import Grisette.Internal.Unified.Class.UnifiedSimpleMergeable+  ( UnifiedBranching,+  )+import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C, S))++instance+  (KnownNat n, 1 <= n) =>+  UnifiedBVImpl 'C WordN IntN n (WordN n) (IntN n)+  where+  type GetWordN 'C = WordN+  type GetIntN 'C = IntN++instance+  (KnownNat n, 1 <= n) =>+  UnifiedBVImpl 'S SymWordN SymIntN n (SymWordN n) (SymIntN n)+  where+  type GetWordN 'S = SymWordN+  type GetIntN 'S = SymIntN++instance+  ( UnifiedBVImpl+      mode+      (GetWordN mode)+      (GetIntN mode)+      n+      (GetWordN mode n)+      (GetIntN mode n)+  ) =>+  UnifiedBV mode n++instance+  ( UnifiedSafeDiv mode ArithException word m,+    UnifiedSafeLinearArith mode ArithException word m,+    UnifiedSafeSymShift mode ArithException word m,+    UnifiedSafeSymRotate mode ArithException word m,+    UnifiedSafeDiv 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++instance+  ( SafeUnifiedBVImpl+      mode+      (GetWordN mode)+      (GetIntN mode)+      n+      (GetWordN mode n)+      (GetIntN mode n)+      m+  ) =>+  SafeUnifiedBV mode n m++instance+  ( SomeBVPair mode word int,+    UnifiedSafeDiv mode (Either SomeBVException ArithException) word m,+    UnifiedSafeLinearArith mode (Either SomeBVException ArithException) word m,+    UnifiedSafeSymRotate mode (Either SomeBVException ArithException) word m,+    UnifiedSafeSymShift mode (Either SomeBVException ArithException) word m,+    UnifiedSafeDiv mode (Either SomeBVException ArithException) int m,+    UnifiedSafeLinearArith mode (Either SomeBVException ArithException) int m,+    UnifiedSafeSymRotate mode (Either SomeBVException ArithException) int m,+    UnifiedSafeSymShift mode (Either SomeBVException ArithException) int m+  ) =>+  SafeUnifiedSomeBVImpl (mode :: EvalModeTag) word int m++instance+  ( SafeUnifiedSomeBVImpl+      mode+      (SomeBV (GetWordN mode))+      (SomeBV (GetIntN mode))+      m+  ) =>+  SafeUnifiedSomeBV mode m++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 SomeBVException ArithException) m+    ) =>+    SafeUnifiedSomeBV mode m,+    forall n. (KnownNat n, 1 <= n) => UnifiedBV mode n,+    SomeBVPair mode (GetSomeWordN mode) (GetSomeIntN mode),+    SizedBV (GetWordN mode),+    SizedBV (GetIntN mode)+  ) =>+  AllUnifiedBV mode
+ src/Grisette/Internal/Internal/Impl/Unified/UnifiedBool.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}++-- |+-- Module      :   Grisette.Internal.Internal.Impl.Unified.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.Internal.Internal.Impl.Unified.UnifiedBool () where++import Grisette.Internal.Internal.Decl.Unified.UnifiedBool+  ( UnifiedBool (GetBool),+  )+import Grisette.Internal.Internal.Impl.Core.Data.Class.SymOrd ()+import Grisette.Internal.SymPrim.SymBool (SymBool)+import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C, S))++instance UnifiedBool 'C where+  type GetBool 'C = Bool++instance UnifiedBool 'S where+  type GetBool 'S = SymBool
+ src/Grisette/Internal/Internal/Impl/Unified/UnifiedFP.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.Internal.Impl.Unified.UnifiedFP+-- 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.Internal.Impl.Unified.UnifiedFP () where++import Control.Monad.Error.Class (MonadError)+import Grisette.Internal.Internal.Decl.Unified.UnifiedFP+  ( AllUnifiedFP,+    GetFP,+    GetFPRoundingMode,+    SafeUnifiedFP,+    SafeUnifiedFPImpl,+    UnifiedFP,+    UnifiedFPImpl,+  )+import Grisette.Internal.SymPrim.FP+  ( FP,+    FPRoundingMode,+    NotRepresentableFPError,+    ValidFP,+  )+import Grisette.Internal.SymPrim.SymFP (SymFP, SymFPRoundingMode)+import Grisette.Internal.Unified.Class.UnifiedSafeFromFP (UnifiedSafeFromFP)+import Grisette.Internal.Unified.Class.UnifiedSimpleMergeable (UnifiedBranching)+import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C, S))+import Grisette.Internal.Unified.UnifiedInteger (GetInteger)++instance+  (ValidFP eb sb) =>+  UnifiedFPImpl 'C FP eb sb (FP eb sb) FPRoundingMode+  where+  type GetFP 'C = FP+  type GetFPRoundingMode 'C = FPRoundingMode++instance+  (ValidFP eb sb) =>+  UnifiedFPImpl 'S SymFP eb sb (SymFP eb sb) SymFPRoundingMode+  where+  type GetFP 'S = SymFP+  type GetFPRoundingMode 'S = SymFPRoundingMode++instance+  ( UnifiedFPImpl+      mode+      (GetFP mode)+      eb+      sb+      (GetFP mode eb sb)+      (GetFPRoundingMode mode)+  ) =>+  UnifiedFP mode eb sb++instance+  (UnifiedFPImpl mode fpn eb sb fp rd) =>+  SafeUnifiedFPImpl mode fpn eb sb fp rd m++instance+  ( SafeUnifiedFPImpl+      mode+      (GetFP mode)+      eb+      sb+      (GetFP mode eb sb)+      (GetFPRoundingMode mode)+      m,+    UnifiedSafeFromFP+      mode+      NotRepresentableFPError+      (GetInteger mode)+      (GetFP mode eb sb)+      (GetFPRoundingMode mode)+      m+  ) =>+  SafeUnifiedFP mode eb sb m++instance+  ( forall eb sb. (ValidFP eb sb) => UnifiedFP mode eb sb,+    forall eb sb m.+    ( ValidFP eb sb,+      UnifiedBranching mode m,+      MonadError NotRepresentableFPError m+    ) =>+    SafeUnifiedFP mode eb sb m+  ) =>+  AllUnifiedFP mode
+ src/Grisette/Internal/SymPrim/AlgReal.hs view
@@ -0,0 +1,216 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-}++-- |+-- Module      :   Grisette.Internal.SymPrim.AlgReal+-- 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.AlgReal+  ( AlgRealPoly (..),+    UnsupportedAlgRealOperation (..),+    toSBVAlgReal,+    fromSBVAlgReal,+    RealPoint (..),+    AlgReal (..),+  )+where++import Control.DeepSeq (NFData)+import Control.Exception (Exception, throw)+import qualified Data.Binary as Binary+import Data.Bytes.Serial (Serial (deserialize, serialize))+import Data.Hashable (Hashable)+import qualified Data.SBV as SBV+import qualified Data.SBV.Internals as SBV+import qualified Data.Serialize as Cereal+import GHC.Generics (Generic)+import Grisette.Internal.Core.Data.Class.Function (Apply (FunType, apply))+import Language.Haskell.TH.Syntax (Lift)+import Test.QuickCheck (Arbitrary)+import Test.QuickCheck.Arbitrary (Arbitrary (arbitrary))++-- | A univariate polynomial with integer coefficients.+--+-- For instance, @5x^3+2x-5@ is represented as+-- @v'AlgRealPoly' [(5, 3), (2, 1), (-5, 0)]@.+newtype AlgRealPoly = AlgRealPoly [(Integer, Integer)]+  deriving (Eq, Generic, Lift)+  deriving newtype (Hashable, NFData)+  deriving anyclass (Serial)++instance Cereal.Serialize AlgRealPoly where+  put = serialize+  get = deserialize++instance Binary.Binary AlgRealPoly where+  put = serialize+  get = deserialize++-- | Boundary point for real intervals.+data RealPoint+  = -- | Open point.+    OpenPoint Rational+  | -- | Closed point.+    ClosedPoint Rational+  deriving (Eq, Generic, Lift)+  deriving anyclass (Hashable, NFData, Serial)++instance Cereal.Serialize RealPoint where+  put = serialize+  get = deserialize++instance Binary.Binary RealPoint where+  put = serialize+  get = deserialize++toSBVRealPoint :: RealPoint -> SBV.RealPoint Rational+toSBVRealPoint (OpenPoint r) = SBV.OpenPoint r+toSBVRealPoint (ClosedPoint r) = SBV.ClosedPoint r++fromSBVRealPoint :: SBV.RealPoint Rational -> RealPoint+fromSBVRealPoint (SBV.OpenPoint r) = OpenPoint r+fromSBVRealPoint (SBV.ClosedPoint r) = ClosedPoint r++-- | Algebraic real numbers. The representation can be abstract for+-- roots-of-polynomials or intervals.+data AlgReal where+  -- | Exact rational number.+  AlgExactRational :: Rational -> AlgReal+  -- | Inexact rational numbers. SMT-solver return it with ? at the end.+  AlgInexactRational :: Rational -> AlgReal+  -- | Algebraic real number as a root of a polynomial.+  AlgPolyRoot ::+    -- | Which root is it?+    Integer ->+    -- | Polynomial defining equation.+    AlgRealPoly ->+    -- | Approximate decimal representation.+    Maybe String ->+    AlgReal+  -- | Interval with low and high bounds.+  AlgInterval ::+    -- | Lower bound.+    RealPoint ->+    -- | Upper bound.+    RealPoint ->+    AlgReal+  deriving (Generic, Lift)+  deriving anyclass (Hashable, NFData, Serial)++instance Cereal.Serialize AlgReal where+  put = serialize+  get = deserialize++instance Binary.Binary AlgReal where+  put = serialize+  get = deserialize++-- | Convert algebraic real numbers to SBV's algebraic real numbers.+toSBVAlgReal :: AlgReal -> SBV.AlgReal+toSBVAlgReal (AlgExactRational r) = SBV.AlgRational True r+toSBVAlgReal (AlgInexactRational r) = SBV.AlgRational False r+toSBVAlgReal (AlgPolyRoot i (AlgRealPoly ps) approx) =+  SBV.AlgPolyRoot (i, SBV.AlgRealPoly ps) approx+toSBVAlgReal (AlgInterval l u) =+  SBV.AlgInterval (toSBVRealPoint l) (toSBVRealPoint u)++-- | Convert SBV's algebraic real numbers to algebraic real numbers.+fromSBVAlgReal :: SBV.AlgReal -> AlgReal+fromSBVAlgReal (SBV.AlgRational True r) = AlgExactRational r+fromSBVAlgReal (SBV.AlgRational False r) = AlgInexactRational r+fromSBVAlgReal (SBV.AlgPolyRoot (i, SBV.AlgRealPoly ps) approx) =+  AlgPolyRoot i (AlgRealPoly ps) approx+fromSBVAlgReal (SBV.AlgInterval l u) =+  AlgInterval (fromSBVRealPoint l) (fromSBVRealPoint u)++instance Show AlgReal where+  show r = show $ toSBVAlgReal r++-- | Exception for unsupported operations on algebraic real numbers.+--+-- We only support operations on exact rationals.+data UnsupportedAlgRealOperation = UnsupportedAlgRealOperation+  { op :: String,+    msg :: String+  }+  deriving anyclass (Exception)++instance Show UnsupportedAlgRealOperation where+  show (UnsupportedAlgRealOperation op msg) =+    "AlgReal."+      ++ op+      ++ ": unsupported operation on algebraic rationals, only support exact "+      ++ "rationals"+      ++ ": "+      ++ msg++op1 :: String -> (Rational -> Rational) -> AlgReal -> AlgReal+op1 _ f (AlgExactRational r) = AlgExactRational $ f r+op1 name _ r =+  throw+    UnsupportedAlgRealOperation {op = name, msg = show r}++op2 ::+  String ->+  (Rational -> Rational -> Rational) ->+  AlgReal ->+  AlgReal ->+  AlgReal+op2 _ f (AlgExactRational l) (AlgExactRational r) = AlgExactRational $ f l r+op2 name _ l r =+  throw+    UnsupportedAlgRealOperation+      { op = name,+        msg = show l <> " and " <> show r+      }++instance Eq AlgReal where+  (AlgExactRational l) == (AlgExactRational r) = l == r+  l == r =+    throw $+      UnsupportedAlgRealOperation "==" $+        show l <> " and " <> show r++instance Ord AlgReal where+  compare (AlgExactRational l) (AlgExactRational r) = compare l r+  compare l r =+    throw $+      UnsupportedAlgRealOperation "compare" $+        show l <> " and " <> show r++instance Num AlgReal where+  (+) = op2 "+" (+)+  (*) = op2 "*" (*)+  (-) = op2 "-" (-)+  negate = op1 "negate" negate+  abs = op1 "abs" abs+  signum = op1 "signum" signum+  fromInteger = AlgExactRational . fromInteger++-- | Unlike sbv, we throw the error when divided by zero happens+instance Fractional AlgReal where+  (/) = op2 "/" (/)+  fromRational = AlgExactRational++instance Real AlgReal where+  toRational (AlgExactRational r) = r+  toRational r =+    throw $+      UnsupportedAlgRealOperation "toRational" $+        show r++instance Arbitrary AlgReal where+  arbitrary = AlgExactRational <$> arbitrary++instance Apply AlgReal where+  type FunType AlgReal = AlgReal+  apply = id
+ src/Grisette/Internal/SymPrim/AllSyms.hs view
@@ -0,0 +1,32 @@+{-# OPTIONS_GHC -Wno-missing-import-lists #-}++-- |+-- Module      :   Grisette.Internal.SymPrim.AllSyms+-- 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.AllSyms+  ( -- * Get all symbolic primitive values in a value+    SomeSym (..),+    AllSyms (..),+    AllSyms1 (..),+    allSymsS1,+    AllSyms2 (..),+    allSymsS2,+    allSymsSize,+    symSize,+    symsSize,++    -- * Generic 'AllSyms'+    AllSymsArgs (..),+    GAllSyms (..),+    genericAllSymsS,+    genericLiftAllSymsS,+  )+where++import Grisette.Internal.Internal.Decl.SymPrim.AllSyms+import Grisette.Internal.Internal.Impl.SymPrim.AllSyms ()
+ src/Grisette/Internal/SymPrim/BV.hs view
@@ -0,0 +1,681 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -funbox-strict-fields #-}++-- |+-- Module      :   Grisette.Internal.SymPrim.BV+-- 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.SymPrim.BV+  ( IntN (..),+    IntN8,+    IntN16,+    IntN32,+    IntN64,+    WordN (..),+    WordN8,+    WordN16,+    WordN32,+    WordN64,+    readBinary,+  )+where++import Control.Applicative (Alternative ((<|>)))+import Control.DeepSeq (NFData)+import Control.Exception+  ( ArithException (Overflow),+    throw,+  )+import qualified Data.Binary as Binary+import Data.Bits+  ( Bits+      ( bit,+        bitSize,+        bitSizeMaybe,+        clearBit,+        complement,+        isSigned,+        popCount,+        rotateL,+        rotateR,+        shiftL,+        shiftR,+        testBit,+        xor,+        zeroBits,+        (.&.),+        (.|.)+      ),+    FiniteBits (finiteBitSize),+  )+import Data.Bytes.Serial (Serial (deserialize, serialize))+import Data.Hashable (Hashable)+import Data.Maybe (fromMaybe, isJust)+import Data.Proxy (Proxy (Proxy))+import Data.SBV (Int16, Int32, Int64, Int8, Word8)+import qualified Data.Serialize as Cereal+import Data.Word (Word16, Word32, Word64)+import GHC.Enum+  ( boundedEnumFrom,+    boundedEnumFromThen,+    predError,+    succError,+    toEnumError,+  )+import GHC.Generics (Generic)+import GHC.Read+  ( Read (readListPrec, readPrec),+    parens,+    readListDefault,+    readListPrecDefault,+    readNumber,+  )+import GHC.Real ((%))+import GHC.TypeNats+  ( KnownNat,+    Nat,+    natVal,+    type (+),+    type (<=),+  )+import Grisette.Internal.Core.Data.Class.BitCast (BitCast (bitCast))+import Grisette.Internal.Core.Data.Class.BitVector+  ( SizedBV+      ( sizedBVConcat,+        sizedBVExt,+        sizedBVSelect,+        sizedBVSext,+        sizedBVZext+      ),+  )+import Grisette.Internal.Core.Data.Class.Function (Apply (FunType, apply))+import Grisette.Internal.Core.Data.Class.SignConversion+  ( SignConversion (toSigned, toUnsigned),+  )+import Grisette.Internal.Core.Data.Class.SymRotate+  ( DefaultFiniteBitsSymRotate (DefaultFiniteBitsSymRotate),+    SymRotate,+  )+import Grisette.Internal.Core.Data.Class.SymShift+  ( DefaultFiniteBitsSymShift (DefaultFiniteBitsSymShift),+    SymShift,+  )+import Language.Haskell.TH.Syntax (Lift)+import Numeric (showHex, showIntAtBase)+import qualified Test.QuickCheck as QC+import Text.ParserCombinators.ReadP (string)+import Text.ParserCombinators.ReadPrec+  ( ReadPrec,+    get,+    look,+    pfail,+  )+import Text.Read (lift)+import qualified Text.Read.Lex as L++-- $setup+-- >>> import Grisette.Core+-- >>> import Grisette.SymPrim+-- >>> import Grisette.Backend+-- >>> import Data.Proxy++-- |+-- Unsigned bit vector type. Indexed with the bit width. Signedness affect the+-- semantics of the operations, including comparison/extension, etc.+--+-- >>> 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+  show (WordN w) = if (bitwidth `mod` 4) == 0 then hexRepPre ++ hexRep else binRepPre ++ binRep+    where+      bitwidth = natVal (Proxy :: Proxy n)+      hexRepPre = "0x" ++ replicate (fromIntegral (bitwidth `div` 4) - length hexRep) '0'+      hexRep = showHex w ""+      binRepPre = "0b" ++ replicate (fromIntegral bitwidth - length binRep) '0'+      binRep = showIntAtBase 2 (\x -> if x == 0 then '0' else '1') w ""++instance (KnownNat n, 1 <= n) => Serial (WordN n) where+  serialize (WordN w) = serialize w+  deserialize = WordN <$> deserialize++instance (KnownNat n, 1 <= n) => Cereal.Serialize (WordN n) where+  put = serialize+  get = deserialize++instance (KnownNat n, 1 <= n) => Binary.Binary (WordN n) where+  put = serialize+  get = deserialize++convertInt :: (Num a) => L.Lexeme -> ReadPrec a+convertInt (L.Number n)+  | Just i <- L.numberToInteger n = return (fromInteger i)+convertInt _ = pfail++-- | Read a binary number.+readBinary :: (Num a) => ReadPrec a+readBinary = parens $ do+  r0 <- look+  case r0 of+    ('-' : _) -> do+      _ <- get+      negate <$> parens parse0b+    _ -> parse0b+  where+    isDigit c = isJust (valDig c)+    valDigit c = fromMaybe 0 (valDig c)+    valDig '0' = Just 0+    valDig '1' = Just 1+    valDig _ = Nothing+    parse0b = do+      _ <- Text.Read.lift $ string "0b"+      fromInteger <$> Text.Read.lift (L.readIntP 2 isDigit valDigit)++#if MIN_VERSION_base(4,21,0)+readBV :: Num a => ReadPrec a+readBV = readNumber convertInt+#else+readBV :: Num a => ReadPrec a+readBV = readNumber convertInt <|> readBinary+#endif++instance (KnownNat n, 1 <= n) => Read (WordN n) where+  readPrec = readBV+  readListPrec = readListPrecDefault+  readList = readListDefault++-- |+-- Signed bit vector type. Indexed with the bit width. Signedness affects the+-- semantics of the operations, including comparison/extension, etc.+--+-- >>> 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+  show (IntN w) = if (bitwidth `mod` 4) == 0 then hexRepPre ++ hexRep else binRepPre ++ binRep+    where+      bitwidth = natVal (Proxy :: Proxy n)+      hexRepPre = "0x" ++ replicate (fromIntegral (bitwidth `div` 4) - length hexRep) '0'+      hexRep = showHex w ""+      binRepPre = "0b" ++ replicate (fromIntegral bitwidth - length binRep) '0'+      binRep = showIntAtBase 2 (\x -> if x == 0 then '0' else '1') w ""++instance (KnownNat n, 1 <= n) => Serial (IntN n) where+  serialize (IntN w) = serialize w+  deserialize = IntN <$> deserialize++instance (KnownNat n, 1 <= n) => Cereal.Serialize (IntN n) where+  put = serialize+  get = deserialize++instance (KnownNat n, 1 <= n) => Binary.Binary (IntN n) where+  put = serialize+  get = deserialize++instance (KnownNat n, 1 <= n) => Read (IntN n) where+  readPrec = readBV+  readListPrec = readListPrecDefault+  readList = readListDefault++instance (KnownNat n, 1 <= n) => Bits (WordN n) where+  WordN a .&. WordN b = WordN (a .&. b)+  WordN a .|. WordN b = WordN (a .|. b)+  WordN a `xor` WordN b = WordN (a `xor` b)+  complement a = maxBound `xor` a++  -- shift use default implementation+  -- rotate use default implementation+  zeroBits = WordN 0+  bit i+    | i < 0 || i >= fromIntegral (natVal (Proxy :: Proxy n)) = zeroBits+    | otherwise = WordN (bit i)++  -- setBit use default implementation+  clearBit (WordN a) i = WordN (clearBit a i)++  -- complementBit use default implementation+  testBit (WordN a) = testBit a+  bitSizeMaybe = Just . finiteBitSize+  bitSize = finiteBitSize+  isSigned _ = False+  shiftL w i | i >= finiteBitSize w = 0+  shiftL (WordN a) i = WordN (a `shiftL` i) .&. maxBound++  -- unsafeShiftL use default implementation+  shiftR w i | i >= finiteBitSize w = 0+  shiftR (WordN a) i = WordN (a `shiftR` i)++  -- unsafeShiftR use default implementation+  rotateL a 0 = a+  rotateL (WordN a) k+    | k >= n = rotateL (WordN a) (k `mod` n)+    | otherwise = WordN $ l + h+    where+      n = fromIntegral $ natVal (Proxy :: Proxy n)+      s = n - k+      l = a `shiftR` s+      h = (a - (l `shiftL` s)) `shiftL` k+  rotateR a 0 = a+  rotateR (WordN a) k+    | k >= n = rotateR (WordN a) (k `mod` n)+    | otherwise = WordN $ l + h+    where+      n = fromIntegral $ natVal (Proxy :: Proxy n)+      s = n - k+      l = a `shiftR` k+      h = (a - (l `shiftL` k)) `shiftL` s+  popCount (WordN n) = popCount n++instance (KnownNat n, 1 <= n) => FiniteBits (WordN n) where+  finiteBitSize _ = fromIntegral (natVal (Proxy :: Proxy n))++instance (KnownNat n, 1 <= n) => Bounded (WordN n) where+  maxBound = WordN ((1 `shiftL` fromIntegral (natVal (Proxy :: Proxy n))) - 1)+  minBound = WordN 0++instance (KnownNat n, 1 <= n) => Enum (WordN n) where+  succ x+    | x /= maxBound = x + 1+    | otherwise = succError $ "WordN " ++ show (natVal (Proxy :: Proxy n))+  pred x+    | x /= minBound = x - 1+    | otherwise = predError $ "WordN " ++ show (natVal (Proxy :: Proxy n))+  toEnum i+    | i >= 0 && toInteger i <= toInteger (maxBound :: WordN n) = WordN (toInteger i)+    | otherwise = toEnumError ("WordN " ++ show (natVal (Proxy :: Proxy n))) i (minBound :: WordN n, maxBound :: WordN n)+  fromEnum (WordN n) = fromEnum n+  enumFrom = boundedEnumFrom+  {-# INLINE enumFrom #-}+  enumFromThen = boundedEnumFromThen+  {-# INLINE enumFromThen #-}++instance (KnownNat n, 1 <= n) => Real (WordN n) where+  toRational (WordN n) = n % 1++instance (KnownNat n, 1 <= n) => Integral (WordN n) where+  quot (WordN x) (WordN y) = WordN (x `quot` y)+  rem (WordN x) (WordN y) = WordN (x `rem` y)+  quotRem (WordN x) (WordN y) = case quotRem x y of+    (q, r) -> (WordN q, WordN r)+  div = quot+  mod = rem+  divMod = quotRem+  toInteger (WordN n) = n++instance (KnownNat n, 1 <= n) => Num (WordN n) where+  WordN x + WordN y = WordN (x + y) .&. maxBound+  WordN x * WordN y = WordN (x * y) .&. maxBound+  WordN x - WordN y+    | x >= y = WordN (x - y)+    | otherwise = WordN ((1 `shiftL` fromIntegral (natVal (Proxy :: Proxy n))) + x - y)+  negate (WordN 0) = WordN 0+  negate a = complement a + WordN 1+  abs x = x+  signum (WordN 0) = 0+  signum _ = 1+  fromInteger !x+    | x == 0 = WordN 0+    | x > 0 = WordN (x .&. unWordN (maxBound :: WordN n))+    | otherwise = -fromInteger (-x)++instance (KnownNat n, 1 <= n) => QC.Arbitrary (WordN n) where+  arbitrary = QC.arbitrarySizedBoundedIntegral++  -- QC.shrinkIntegral assumes that 2 is representable by the number, which is+  -- not the case for 1-bit bit vector.+  shrink i+    | i == 0 = []+    | i == 1 = [0]+    | otherwise = QC.shrinkIntegral i++minusOneIntN :: forall proxy n. (KnownNat n) => proxy n -> IntN n+minusOneIntN _ = IntN (1 `shiftL` fromIntegral (natVal (Proxy :: Proxy n)) - 1)++instance (KnownNat n, 1 <= n) => Bits (IntN n) where+  IntN a .&. IntN b = IntN (a .&. b)+  IntN a .|. IntN b = IntN (a .|. b)+  IntN a `xor` IntN b = IntN (a `xor` b)+  complement a = minusOneIntN (Proxy :: Proxy n) `xor` a++  -- shift use default implementation+  -- rotate use default implementation+  zeroBits = IntN 0+  bit i = IntN (unWordN (bit i :: WordN n))++  -- setBit use default implementation+  clearBit (IntN a) i = IntN (clearBit a i)++  -- complementBit use default implementation+  testBit (IntN a) = testBit a+  bitSizeMaybe = Just . finiteBitSize+  bitSize = finiteBitSize+  isSigned _ = True++  shiftL (IntN a) i = IntN (unWordN $ (WordN a :: WordN n) `shiftL` i)++  -- unsafeShiftL use default implementation+  shiftR i 0 = i+  shiftR (IntN i) k+    | k >= n = if b then IntN (maxi - 1) else IntN 0+    | otherwise = if b then IntN (maxi - noi + (i `shiftR` k)) else IntN (i `shiftR` k)+    where+      b = testBit i (n - 1)+      n = fromIntegral $ natVal (Proxy :: Proxy n)+      maxi = (1 :: Integer) `shiftL` n+      noi = (1 :: Integer) `shiftL` (n - k)++  -- unsafeShiftR use default implementation+  rotateL (IntN i) k = IntN $ unWordN $ rotateL (WordN i :: WordN n) k+  rotateR (IntN i) k = IntN $ unWordN $ rotateR (WordN i :: WordN n) k+  popCount (IntN i) = popCount i++instance (KnownNat n, 1 <= n) => FiniteBits (IntN n) where+  finiteBitSize _ = fromIntegral (natVal (Proxy :: Proxy n))++instance (KnownNat n, 1 <= n) => Bounded (IntN n) where+  maxBound = IntN (1 `shiftL` (fromIntegral (natVal (Proxy :: Proxy n)) - 1) - 1)+  minBound = maxBound + 1++instance (KnownNat n, 1 <= n) => Enum (IntN n) where+  succ x+    | x /= maxBound = x + 1+    | otherwise = succError $ "IntN " ++ show (natVal (Proxy :: Proxy n))+  pred x+    | x /= minBound = x - 1+    | otherwise = predError $ "IntN " ++ show (natVal (Proxy :: Proxy n))+  toEnum i+    | i >= fromIntegral (minBound :: IntN n) && i <= fromIntegral (maxBound :: IntN n) = fromIntegral i+    | otherwise = toEnumError ("IntN " ++ show (natVal (Proxy :: Proxy n))) i (minBound :: WordN n, maxBound :: WordN n)+  fromEnum = fromEnum . toInteger+  enumFrom = boundedEnumFrom+  {-# INLINE enumFrom #-}+  enumFromThen = boundedEnumFromThen+  {-# INLINE enumFromThen #-}++instance (KnownNat n, 1 <= n) => Real (IntN n) where+  toRational i = toInteger i % 1++instance (KnownNat n, 1 <= n) => Integral (IntN n) where+  quot x y =+    if x == minBound && y == -1+      then throw Overflow+      else fromInteger (toInteger x `quot` toInteger y)+  rem x y = fromInteger (toInteger x `rem` toInteger y)+  quotRem x y =+    if x == minBound && y == -1+      then throw Overflow+      else case quotRem (toInteger x) (toInteger y) of+        (q, r) -> (fromInteger q, fromInteger r)+  div x y =+    if x == minBound && y == -1+      then throw Overflow+      else fromInteger (toInteger x `div` toInteger y)+  mod x y = fromInteger (toInteger x `mod` toInteger y)+  divMod x y =+    if x == minBound && y == -1+      then throw Overflow+      else case divMod (toInteger x) (toInteger y) of+        (q, r) -> (fromInteger q, fromInteger r)+  toInteger i@(IntN n) = case signum i of+    0 -> 0+    -1 ->+      let x = negate i+       in if signum x == -1 then -n else negate (toInteger x)+    1 -> n+    _ -> undefined++instance (KnownNat n, 1 <= n) => Num (IntN n) where+  IntN x + IntN y = IntN (x + y) .&. minusOneIntN (Proxy :: Proxy n)+  IntN x * IntN y = IntN (x * y) .&. minusOneIntN (Proxy :: Proxy n)+  IntN x - IntN y+    | x >= y = IntN (x - y)+    | otherwise = IntN ((1 `shiftL` fromIntegral (natVal (Proxy :: Proxy n))) + x - y)+  negate (IntN 0) = IntN 0+  negate a = complement a + IntN 1+  abs x = if testBit x (fromIntegral $ natVal (Proxy :: Proxy n) - 1) then negate x else x+  signum (IntN 0) = IntN 0+  signum i = if testBit i (fromIntegral $ natVal (Proxy :: Proxy n) - 1) then -1 else 1+  fromInteger !x = IntN $ if v >= 0 then v else (1 `shiftL` n) + v+    where+      v = unWordN (fromInteger (x + maxn) :: WordN n) - maxn+      n = fromIntegral (natVal (Proxy :: Proxy n))+      maxn = 1 `shiftL` (n - 1) - 1++instance (KnownNat n, 1 <= n) => Ord (IntN n) where+  IntN a <= IntN b+    | as && not bs = True+    | not as && bs = False+    | otherwise = a <= b+    where+      n = fromIntegral (natVal (Proxy :: Proxy n))+      as = testBit a (n - 1)+      bs = testBit b (n - 1)++instance (KnownNat n, 1 <= n) => QC.Arbitrary (IntN n) where+  arbitrary = QC.arbitrarySizedBoundedIntegral++  -- QC.shrinkIntegral assumes that 2 is representable by the number, which is+  -- not the case for 1-bit bit vector.+  shrink i+    | i == 0 = []+    | i == 1 = [0]+    | otherwise = QC.shrinkIntegral i++instance SizedBV WordN where+  sizedBVConcat :: forall l r. (KnownNat l, KnownNat r, 1 <= l, 1 <= r) => WordN l -> WordN r -> WordN (l + r)+  sizedBVConcat (WordN a) (WordN b) = WordN ((a `shiftL` fromIntegral (natVal (Proxy :: Proxy r))) .|. b)+  sizedBVZext _ (WordN v) = WordN v+  sizedBVSext :: forall l r proxy. (KnownNat l, KnownNat r, 1 <= l, KnownNat r, l <= r) => proxy r -> WordN l -> WordN r+  sizedBVSext pr (WordN v) = if s then WordN (maxi - noi + v) else WordN v+    where+      r = fromIntegral $ natVal pr+      l = fromIntegral $ natVal (Proxy :: Proxy l)+      s = testBit v (l - 1)+      maxi = (1 :: Integer) `shiftL` r+      noi = (1 :: Integer) `shiftL` l+  sizedBVExt = sizedBVZext+  sizedBVSelect ::+    forall n ix w p q.+    (KnownNat n, KnownNat ix, KnownNat w, 1 <= n, 1 <= w, ix + w <= n) =>+    p ix ->+    q w ->+    WordN n ->+    WordN w+  sizedBVSelect pix pw (WordN v) = WordN ((v `shiftR` ix) .&. mask)+    where+      ix = fromIntegral $ natVal pix+      w = fromIntegral $ natVal pw+      mask = (1 `shiftL` w) - 1++instance SizedBV IntN where+  sizedBVConcat :: forall l r. (KnownNat l, KnownNat r, 1 <= l, 1 <= r) => IntN l -> IntN r -> IntN (l + r)+  sizedBVConcat (IntN a) (IntN b) = IntN $ unWordN $ sizedBVConcat (WordN a :: WordN l) (WordN b :: WordN r)+  sizedBVZext _ (IntN v) = IntN v+  sizedBVSext :: forall l r proxy. (KnownNat l, KnownNat r, 1 <= l, KnownNat r, l <= r) => proxy r -> IntN l -> IntN r+  sizedBVSext pr (IntN v) = IntN $ unWordN $ sizedBVSext pr (WordN v :: WordN l)+  sizedBVExt = sizedBVSext+  sizedBVSelect ::+    forall n ix w p q.+    (KnownNat n, KnownNat ix, KnownNat w, 1 <= n, 1 <= w, ix + w <= n) =>+    p ix ->+    q w ->+    IntN n ->+    IntN w+  sizedBVSelect pix pw (IntN v) = IntN $ unWordN $ sizedBVSelect pix pw (WordN v :: WordN n)++instance (KnownNat n, 1 <= n) => SignConversion (WordN n) (IntN n) where+  toSigned (WordN i) = IntN i+  toUnsigned (IntN i) = WordN i++deriving via+  (DefaultFiniteBitsSymShift (IntN n))+  instance+    (KnownNat n, 1 <= n) => SymShift (IntN n)++deriving via+  (DefaultFiniteBitsSymShift (WordN n))+  instance+    (KnownNat n, 1 <= n) => SymShift (WordN n)++deriving via+  (DefaultFiniteBitsSymRotate (IntN n))+  instance+    (KnownNat n, 1 <= n) => SymRotate (IntN n)++deriving via+  (DefaultFiniteBitsSymRotate (WordN n))+  instance+    (KnownNat n, 1 <= n) => SymRotate (WordN n)++#define BITCAST_FROM_INTEGRAL(from, to) \+  instance BitCast (from) (to) where \+    bitCast = fromIntegral++#if 1+BITCAST_FROM_INTEGRAL(WordN 8, Word8)+BITCAST_FROM_INTEGRAL(WordN 16, Word16)+BITCAST_FROM_INTEGRAL(WordN 32, Word32)+BITCAST_FROM_INTEGRAL(WordN 64, Word64)+BITCAST_FROM_INTEGRAL(WordN 8, Int8)+BITCAST_FROM_INTEGRAL(WordN 16, Int16)+BITCAST_FROM_INTEGRAL(WordN 32, Int32)+BITCAST_FROM_INTEGRAL(WordN 64, Int64)++BITCAST_FROM_INTEGRAL(Word8, WordN 8)+BITCAST_FROM_INTEGRAL(Word16, WordN 16)+BITCAST_FROM_INTEGRAL(Word32, WordN 32)+BITCAST_FROM_INTEGRAL(Word64, WordN 64)+BITCAST_FROM_INTEGRAL(Int8, WordN 8)+BITCAST_FROM_INTEGRAL(Int16, WordN 16)+BITCAST_FROM_INTEGRAL(Int32, WordN 32)+BITCAST_FROM_INTEGRAL(Int64, WordN 64)++BITCAST_FROM_INTEGRAL(IntN 8, Word8)+BITCAST_FROM_INTEGRAL(IntN 16, Word16)+BITCAST_FROM_INTEGRAL(IntN 32, Word32)+BITCAST_FROM_INTEGRAL(IntN 64, Word64)+BITCAST_FROM_INTEGRAL(IntN 8, Int8)+BITCAST_FROM_INTEGRAL(IntN 16, Int16)+BITCAST_FROM_INTEGRAL(IntN 32, Int32)+BITCAST_FROM_INTEGRAL(IntN 64, Int64)++BITCAST_FROM_INTEGRAL(Word8, IntN 8)+BITCAST_FROM_INTEGRAL(Word16, IntN 16)+BITCAST_FROM_INTEGRAL(Word32, IntN 32)+BITCAST_FROM_INTEGRAL(Word64, IntN 64)+BITCAST_FROM_INTEGRAL(Int8, IntN 8)+BITCAST_FROM_INTEGRAL(Int16, IntN 16)+BITCAST_FROM_INTEGRAL(Int32, IntN 32)+BITCAST_FROM_INTEGRAL(Int64, IntN 64)+#endif++instance (KnownNat n, 1 <= n) => BitCast (WordN n) (IntN n) where+  bitCast (WordN i) = IntN i++instance (KnownNat n, 1 <= n) => BitCast (IntN n) (WordN n) where+  bitCast (IntN i) = WordN i++#define BITCAST_VIA_WORDx(from, to, intermediate) \+  instance BitCast (from) (to) where \+    bitCast x = bitCast (bitCast x :: intermediate)++#if 1+BITCAST_VIA_WORDx(WordN64, Double, Word64)+BITCAST_VIA_WORDx(Double, WordN64, Word64)+BITCAST_VIA_WORDx(IntN64, Double, Word64)+BITCAST_VIA_WORDx(Double, IntN64, Word64)+BITCAST_VIA_WORDx(WordN32, Float, Word32)+BITCAST_VIA_WORDx(Float, WordN32, Word32)+BITCAST_VIA_WORDx(IntN32, Float, Word32)+BITCAST_VIA_WORDx(Float, IntN32, Word32)+#endif++instance BitCast Bool (WordN 1) where+  bitCast False = 0+  bitCast True = 1++instance BitCast (WordN 1) Bool where+  bitCast 0 = False+  bitCast _ = True++instance BitCast Bool (IntN 1) where+  bitCast False = 0+  bitCast True = 1++instance BitCast (IntN 1) Bool where+  bitCast 0 = False+  bitCast _ = True++instance Apply (IntN n) where+  type FunType (IntN n) = IntN n+  apply = id++instance Apply (WordN n) where+  type FunType (WordN n) = WordN n+  apply = id
+ src/Grisette/Internal/SymPrim/FP.hs view
@@ -0,0 +1,993 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# 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 (..),+    FP16,+    FP32,+    FP64,+    withValidFPProofs,+    FPRoundingMode (..),+    allFPRoundingMode,+    NotRepresentableFPError (..),+    ConvertibleBound (..),+    nextFP,+    prevFP,+    withUnsafeValidFP,+    checkDynamicValidFP,+    invalidFPMessage,+  )+where++import Control.DeepSeq (NFData (rnf))+import Control.Exception (Exception, throw)+import qualified Data.Binary as Binary+import Data.Bits (Bits (complement, shiftL, shiftR, xor, (.&.)))+import Data.Bytes.Serial (Serial (deserialize, serialize))+import Data.Hashable (Hashable (hashWithSalt))+import Data.Int (Int16, Int32, Int64)+import Data.Maybe (fromJust)+import Data.Proxy (Proxy (Proxy))+import Data.Ratio (numerator)+import Data.SBV+  ( BVIsNonZero,+    FloatingPoint,+    SWord,+    SymVal (literal, unliteral),+    ValidFloat,+    Word16,+    Word32,+    Word64,+    denominator,+    infinity,+    nan,+    sFloatingPointAsSWord,+    sWordAsSFloatingPoint,+  )+import Data.SBV.Float (fpEncodeFloat)+import qualified Data.SBV.Float as SBVF+import qualified Data.SBV.Internals as SBVI+import qualified Data.Serialize as Cereal+import Data.Type.Bool (type (&&), type (||))+import Data.Type.Equality (type (:~:) (Refl), type (==))+import GHC.Exception (Exception (displayException))+import GHC.Generics (Generic)+import GHC.Natural (Natural)+import GHC.TypeNats+  ( CmpNat,+    KnownNat,+    Nat,+    natVal,+    type (+),+    type (<=),+  )+import Grisette.Internal.Core.Data.Class.BitCast+  ( BitCast (bitCast),+    BitCastCanonical (bitCastCanonicalValue),+    BitCastOr (bitCastOr),+    bitCastOrCanonical,+  )+import Grisette.Internal.Core.Data.Class.BitVector (SizedBV (sizedBVConcat))+import Grisette.Internal.Core.Data.Class.Function (Apply (FunType, apply))+import Grisette.Internal.Core.Data.Class.IEEEFP+  ( IEEEFPConstants+      ( fpMaxNormalized,+        fpMaxSubnormal,+        fpMinNormalized,+        fpMinSubnormal,+        fpNaN,+        fpNegativeInfinite,+        fpNegativeZero,+        fpPositiveInfinite,+        fpPositiveZero+      ),+    IEEEFPConvertible (fromFPOr, toFP),+    IEEEFPOp+      ( fpAbs,+        fpMaximum,+        fpMaximumNumber,+        fpMinimum,+        fpMinimumNumber,+        fpNeg,+        fpRem+      ),+    IEEEFPRoundingMode (rna, rne, rtn, rtp, rtz),+    IEEEFPRoundingOp (fpAdd, fpDiv, fpFMA, fpMul, fpRoundToIntegral, fpSqrt, fpSub),+    IEEEFPToAlgReal,+    fpIsInfinite,+    fpIsNaN,+    fpIsNegativeInfinite,+    fpIsNegativeZero,+    fpIsPositiveInfinite,+    fpIsPositiveZero,+    fpIsZero,+  )+import Grisette.Internal.SymPrim.AlgReal+  ( AlgReal (AlgExactRational),+    UnsupportedAlgRealOperation (UnsupportedAlgRealOperation, msg, op),+  )+import Grisette.Internal.SymPrim.BV (IntN, WordN, WordN16, WordN32, WordN64)+import Grisette.Internal.Utils.Parameterized+  ( KnownProof (KnownProof),+    knownAdd,+    unsafeAxiom,+    unsafeLeqProof,+    withKnownProof,+    withLeqProof,+  )+import Language.Haskell.TH.Syntax (Lift (liftTyped))+import LibBF+  ( BFOpts,+    BigFloat,+    RoundMode,+    Status,+    allowSubnormal,+    bfAdd,+    bfDiv,+    bfFMA,+    bfFromInteger,+    bfIsInf,+    bfIsNaN,+    bfIsNeg,+    bfIsPos,+    bfIsZero,+    bfMul,+    bfNaN,+    bfNegInf,+    bfNegZero,+    bfPosInf,+    bfPosZero,+    bfRoundFloat,+    bfRoundInt,+    bfSqrt,+    bfSub,+    expBits,+    precBits,+    rnd,+    pattern NearAway,+    pattern NearEven,+    pattern ToNegInf,+    pattern ToPosInf,+    pattern ToZero,+  )+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) =>+  proxy w ->+  ((BVIsNonZero w) => r) ->+  r+bvIsNonZeroFromGEq1 _ r1 = case unsafeAxiom :: w :~: 1 of+  Refl -> r1++-- | A type-level proof that the given bit-widths are valid for a floating-point+-- number.+type ValidFP (eb :: Nat) (sb :: Nat) = ValidFloat eb sb++-- | Check if the given floating-point type is valid.+checkDynamicValidFP :: Natural -> Natural -> Bool+checkDynamicValidFP eb sb =+  eb >= 2 && eb <= 61 && sb >= 2 && sb <= 4611686018427387902++-- | A message thrown when the floating-point type is invalid.+invalidFPMessage :: String+invalidFPMessage =+  "Invalid floating point type `SFloatingPoint eb sb'\n`n"+    <> "  A valid float of type 'SFloatingPoint eb sb' must satisfy:\n"+    <> "        eb `elem` [2 .. 61]\n"+    <> "        sb `elem` [2 .. 4611686018427387902]\n\n"+    <> "  Given type falls outside of this range, or the sizes are not known naturals."++#if MIN_VERSION_sbv(12,0,0)+-- | Provide an (unsafe) type-level proof that the given floating-point type is+-- valid.+withUnsafeValidFP ::+  forall eb sb r. (KnownNat eb, KnownNat sb) => ((ValidFP eb sb) => r) -> r+withUnsafeValidFP r =+  let eb = natVal (Proxy @eb)+      sb = natVal (Proxy @sb)+   in if checkDynamicValidFP eb sb+        then case unsafeAxiom @True+          @( ((CmpNat eb 2 == 'EQ) || (CmpNat eb 2 == 'GT))+               && ( ((CmpNat eb 29 == 'EQ) || (CmpNat eb 29 == 'LT))+                      && ( ((CmpNat sb 2 == 'EQ) || (CmpNat sb 2 == 'GT))+                             && ( (CmpNat sb 1073741822 == 'EQ)+                                    || (CmpNat sb 1073741822 == 'LT)+                                )+                         )+                  )+           ) of+          Refl -> r+        else error invalidFPMessage+#else+-- | Provide an (unsafe) type-level proof that the given floating-point type is+-- valid.+withUnsafeValidFP ::+  forall eb sb r. (KnownNat eb, KnownNat sb) => ((ValidFP eb sb) => r) -> r+withUnsafeValidFP r =+  let eb = natVal (Proxy @eb)+      sb = natVal (Proxy @sb)+   in if checkDynamicValidFP eb sb+        then case unsafeAxiom @True+          @( ((CmpNat eb 2 == 'EQ) || (CmpNat eb 2 == 'GT))+               && ( ((CmpNat eb 61 == 'EQ) || (CmpNat eb 61 == 'LT))+                      && ( ((CmpNat sb 2 == 'EQ) || (CmpNat sb 2 == 'GT))+                             && ( (CmpNat sb 4611686018427387902 == 'EQ)+                                    || (CmpNat sb 4611686018427387902 == 'LT)+                                )+                         )+                  )+           ) of+          Refl -> r+        else error invalidFPMessage+#endif++-- | IEEE 754 floating-point number with @eb@ exponent bits and @sb@ significand+-- bits.+--+-- >>> 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)++-- Workaround for https://github.com/GaloisInc/libBF-hs/pull/32, which affects+-- the correctness of the Ord instance for 'Data.SBV.FloatingPoint'.+instance (ValidFP eb sb) => Ord (FP eb sb) where+  FP x < FP y | isNaN x || isNaN y = False+  FP x < FP y = x < y+  FP x <= FP y | isNaN x || isNaN y = False+  FP x <= FP y = x <= y+  FP x > FP y | isNaN x || isNaN y = False+  FP x > FP y = x > y+  FP x >= FP y | isNaN x || isNaN y = False+  FP x >= FP y = x >= y++-- | IEEE 754 half-precision floating-point number.+type FP16 = FP 5 11++-- | IEEE 754 single-precision floating-point number.+type FP32 = FP 8 24++-- | IEEE 754 double-precision floating-point number.+type FP64 = FP 11 53++-- | Some type-level witnesses that could be derived from 'ValidFP'.+withValidFPProofs ::+  forall eb sb r.+  (ValidFP eb sb) =>+  ( ( KnownNat (eb + sb),+      BVIsNonZero (eb + sb),+      1 <= eb + sb,+      1 <= eb,+      1 <= sb+    ) =>+    r+  ) ->+  r+withValidFPProofs r =+  withKnownProof (knownAdd (KnownProof @eb) (KnownProof @sb)) $+    withLeqProof (unsafeLeqProof @1 @(eb + sb)) $+      withLeqProof (unsafeLeqProof @1 @eb) $+        withLeqProof (unsafeLeqProof @1 @sb) $+          bvIsNonZeroFromGEq1 (Proxy @(eb + sb)) r++instance (ValidFP eb sb, r ~ (eb + sb)) => BitCast (WordN r) (FP eb sb) where+  bitCast v = FP fp+    where+      sword :: SWord r+      sword = withValidFPProofs @eb @sb fromIntegral v+      fp :: FloatingPoint eb sb+      fp =+        withValidFPProofs @eb @sb $+          fromJust $+            unliteral $+              sWordAsSFloatingPoint sword++instance (ValidFP eb sb, r ~ (eb + sb)) => BitCast (IntN r) (FP eb sb) where+  bitCast x = withValidFPProofs @eb @sb $ bitCast (bitCast x :: WordN (eb + sb))++#define BITCAST_VIA_INTERMEDIATE(from, to, intermediate) \+  instance BitCast (from) (to) where \+    bitCast x = bitCast (bitCast x :: intermediate)++#if 1+BITCAST_VIA_INTERMEDIATE(Double, FP64, WordN 64)+BITCAST_VIA_INTERMEDIATE(Int64, FP64, WordN 64)+BITCAST_VIA_INTERMEDIATE(Word64, FP64, WordN 64)++BITCAST_VIA_INTERMEDIATE(Float, FP32, WordN 32)+BITCAST_VIA_INTERMEDIATE(Int32, FP32, WordN 32)+BITCAST_VIA_INTERMEDIATE(Word32, FP32, WordN 32)++BITCAST_VIA_INTERMEDIATE(Word16, FP16, WordN 16)+BITCAST_VIA_INTERMEDIATE(Int16, FP16, WordN 16)+#endif+instance NFData (FP eb sb) where+  rnf (FP x) = x `seq` ()++instance (ValidFP eb sb) => Lift (FP eb sb) where+  liftTyped fp = [||bitCast wordnValue||]+    where+      wordnValue = bitCastOrCanonical fp :: WordN (eb + sb)++instance (ValidFP eb sb) => Hashable (FP eb sb) where+  hashWithSalt salt x =+    hashWithSalt salt (bitCastOrCanonical x :: WordN (eb + sb))++deriving newtype instance (ValidFloat eb sb) => Num (FP eb sb)++deriving newtype instance (ValidFloat eb sb) => Fractional (FP eb sb)++deriving newtype instance (ValidFloat eb sb) => Floating (FP eb sb)++deriving newtype instance (ValidFloat eb sb) => Real (FP eb sb)++deriving newtype instance (ValidFloat eb sb) => RealFrac (FP eb sb)++deriving newtype instance (ValidFloat eb sb) => RealFloat (FP eb sb)++instance (ValidFloat eb sb) => QC.Arbitrary (FP eb sb) where+  arbitrary = do+    frequency+      [ ( 3,+          withValidFPProofs @eb @sb $+            bitCast+              <$> (QC.arbitrary :: QC.Gen (WordN (eb + sb)))+        ),+        ( 5,+          -- mostly normalized numbers+          withValidFPProofs @eb @sb $ do+            e <- egen+            s <- sgen+            msb <- msbGen+            smsb <- smsbGen+            return $ bitCast (sizedBVConcat e s `xor` msb `xor` smsb)+        ),+        ( 4,+          -- mostly denormalized numbers+          withValidFPProofs @eb @sb $ do+            s <- sgen+            msb <- msbGen+            smsb <- smsbGen+            return $+              bitCast (sizedBVConcat 0 s `xor` msb .&. complement smsb)+        ),+        (1, oneof $ return <$> [nan, 0, -0, infinity, -infinity])+      ]+    where+      eb = fromIntegral $ natVal (Proxy @eb) :: Int+      sb = fromIntegral $ natVal (Proxy @sb) :: Int+      egen = withValidFPProofs @eb @sb $ QC.arbitrary :: QC.Gen (WordN eb)+      sgen = withValidFPProofs @eb @sb $ QC.arbitrary :: QC.Gen (WordN sb)+      msbGen =+        withValidFPProofs @eb @sb $+          oneof [return 0, return $ 1 `shiftL` (eb + sb - 1)] ::+          QC.Gen (WordN (eb + sb))+      smsbGen =+        withValidFPProofs @eb @sb $+          oneof [return 0, return $ 1 `shiftL` (sb - 1)] ::+          QC.Gen (WordN (eb + sb))++-- | 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, Serial)++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]++instance QC.Arbitrary FPRoundingMode where+  arbitrary = QC.elements [RNE, RNA, RTP, RTN, RTZ]++instance+  (ValidFP eb sb, n ~ (eb + sb)) =>+  BitCastCanonical (FP eb sb) (WordN n)+  where+  bitCastCanonicalValue _ =+    withValidFPProofs @eb @sb $+      sizedBVConcat (shiftR (-1) 1 :: WordN eb) highsb+    where+      sb = fromIntegral $ natVal (Proxy @sb) :: Int+      highsb = withValidFPProofs @eb @sb $ shiftL 3 (sb - 2) :: WordN sb++instance+  (ValidFP eb sb, n ~ (eb + sb)) =>+  BitCastCanonical (FP eb sb) (IntN n)+  where+  bitCastCanonicalValue n =+    withValidFPProofs @eb @sb $+      bitCast (bitCastCanonicalValue n :: WordN n)++#define BIT_CAST_CANONICAL_VIA_INTERMEDIATE(from, to, intermediate) \+  instance BitCastCanonical (from) (to) where \+    bitCastCanonicalValue x = bitCast (bitCastCanonicalValue x :: intermediate)++#if 1+BIT_CAST_CANONICAL_VIA_INTERMEDIATE(FP64, Word64, WordN64)+BIT_CAST_CANONICAL_VIA_INTERMEDIATE(FP64, Int64, WordN64)+BIT_CAST_CANONICAL_VIA_INTERMEDIATE(FP64, Double, WordN64)+BIT_CAST_CANONICAL_VIA_INTERMEDIATE(FP32, Word32, WordN32)+BIT_CAST_CANONICAL_VIA_INTERMEDIATE(FP32, Int32, WordN32)+BIT_CAST_CANONICAL_VIA_INTERMEDIATE(FP32, Float, WordN32)+BIT_CAST_CANONICAL_VIA_INTERMEDIATE(FP16, Word16, WordN16)+BIT_CAST_CANONICAL_VIA_INTERMEDIATE(FP16, Int16, WordN16)+#endif++instance (ValidFP eb sb, r ~ (eb + sb)) => BitCastOr (FP eb sb) (WordN r) where+  bitCastOr d (FP f)+    | isNaN f = d+    | otherwise = wordn+    where+      wordn :: WordN (eb + sb)+      wordn =+        withValidFPProofs @eb @sb $+          fromIntegral $+            fromJust $+              unliteral $+                sFloatingPointAsSWord $+                  literal f++instance+  (ValidFP eb sb, n ~ (eb + sb)) =>+  BitCastOr (FP eb sb) (IntN n)+  where+  bitCastOr d n =+    withValidFPProofs @eb @sb $+      bitCast (bitCastOr (bitCast d) n :: WordN n)++#define BIT_CAST_OR_VIA_INTERMEDIATE(from, to, intermediate) \+  instance BitCastOr (from) (to) where \+    bitCastOr d x = bitCast (bitCastOr (bitCast d) x :: intermediate)++#if 1+BIT_CAST_OR_VIA_INTERMEDIATE(FP64, Word64, WordN64)+BIT_CAST_OR_VIA_INTERMEDIATE(FP64, Int64, WordN64)+BIT_CAST_OR_VIA_INTERMEDIATE(FP64, Double, WordN64)+BIT_CAST_OR_VIA_INTERMEDIATE(FP32, Word32, WordN32)+BIT_CAST_OR_VIA_INTERMEDIATE(FP32, Int32, WordN32)+BIT_CAST_OR_VIA_INTERMEDIATE(FP32, Float, WordN32)+BIT_CAST_OR_VIA_INTERMEDIATE(FP16, Word16, WordN16)+BIT_CAST_OR_VIA_INTERMEDIATE(FP16, Int16, WordN16)+#endif++-- | An error thrown when bitcasting or converting t'FP' NaN to other types.+data NotRepresentableFPError+  = NaNError+  | FPUnderflowError+  | FPOverflowError+  deriving (Show, Eq, Ord, Generic)++instance Exception NotRepresentableFPError where+  displayException NaNError =+    "Converting NaN value cannot be done precisely with SMT-LIB2"+  displayException FPUnderflowError =+    "Converting FP values that cannot be represented by non-FP types due to "+      <> "underflowing"+  displayException FPOverflowError =+    "Converting FP values that cannot be represented by non-FP types due to "+      <> "overflowing"++instance (ValidFP eb sb) => IEEEFPConstants (FP eb sb) where+  fpPositiveInfinite = FP infinity+  {-# INLINE fpPositiveInfinite #-}+  fpNegativeInfinite = FP $ -infinity+  {-# INLINE fpNegativeInfinite #-}+  fpNaN = FP nan+  {-# INLINE fpNaN #-}+  fpNegativeZero = FP $ -0+  {-# INLINE fpNegativeZero #-}+  fpPositiveZero = FP 0+  {-# INLINE fpPositiveZero #-}++  fpMinNormalized =+    withValidFPProofs @eb @sb $+      bitCast $+        (1 :: WordN (eb + sb)) `shiftL` fromIntegral (natVal (Proxy @sb) - 1)+  {-# INLINE fpMinNormalized #-}++  fpMaxNormalized =+    withValidFPProofs @eb @sb $+      bitCast $+        complement+          ( (1 :: WordN (eb + sb))+              `shiftL` fromIntegral (natVal (Proxy @sb) - 1)+          )+          `shiftL` 1+          `shiftR` 1+  {-# INLINE fpMaxNormalized #-}++  fpMinSubnormal = withValidFPProofs @eb @sb $ bitCast (1 :: WordN (eb + sb))+  {-# INLINE fpMinSubnormal #-}++  fpMaxSubnormal =+    withValidFPProofs @eb @sb $+      bitCast+        ( (1 :: WordN (eb + sb))+            `shiftL` fromIntegral (natVal (Proxy @sb) - 1)+            - 1+        )+  {-# INLINE fpMaxSubnormal #-}++cmpHandleNegZero :: (ValidFP eb sb) => FP eb sb -> FP eb sb -> Bool+cmpHandleNegZero x y =+  if fpIsZero x && fpIsZero y then fpIsNegativeZero x else x < y++instance (ValidFP eb sb) => IEEEFPOp (FP eb sb) where+  fpAbs = abs+  {-# INLINE fpAbs #-}+  fpNeg = negate+  {-# INLINE fpNeg #-}+  fpRem = SBVI.fpRemH+  {-# INLINE fpRem #-}+  fpMinimum a b+    | fpIsNaN a || fpIsNaN b = fpNaN+    | cmpHandleNegZero a b = a+    | otherwise = b+  {-# INLINE fpMinimum #-}+  fpMinimumNumber a b+    | fpIsNaN a = b+    | fpIsNaN b = a+    | cmpHandleNegZero a b = a+    | otherwise = b+  {-# INLINE fpMinimumNumber #-}+  fpMaximum a b+    | fpIsNaN a || fpIsNaN b = fpNaN+    | cmpHandleNegZero a b = b+    | otherwise = a+  {-# INLINE fpMaximum #-}+  fpMaximumNumber a b+    | fpIsNaN a = b+    | fpIsNaN b = a+    | cmpHandleNegZero a b = b+    | otherwise = a+  {-# INLINE fpMaximumNumber #-}++instance IEEEFPRoundingMode FPRoundingMode where+  rne = RNE+  {-# INLINE rne #-}+  rna = RNA+  {-# INLINE rna #-}+  rtp = RTP+  {-# INLINE rtp #-}+  rtn = RTN+  {-# INLINE rtn #-}+  rtz = RTZ+  {-# INLINE rtz #-}++libBFRoundingMode :: FPRoundingMode -> RoundMode+libBFRoundingMode RNE = NearEven+libBFRoundingMode RNA = NearAway+libBFRoundingMode RTP = ToPosInf+libBFRoundingMode RTN = ToNegInf+libBFRoundingMode RTZ = ToZero++libBFOpts ::+  forall eb sb. (ValidFP eb sb) => FPRoundingMode -> FP eb sb -> BFOpts+libBFOpts mode _ = rnd rd <> precBits sb <> expBits eb <> allowSubnormal+  where+    eb = fromIntegral $ natVal (Proxy @eb) :: Int+    sb = fromIntegral $ natVal (Proxy @sb) :: Word+    rd = libBFRoundingMode mode++toLibBF :: forall eb sb. (ValidFP eb sb) => FP eb sb -> BigFloat+toLibBF f+  | fpIsNegativeZero f = bfNegZero+  | fpIsPositiveZero f = bfPosZero+  | fpIsPositiveInfinite f = bfPosInf+  | fpIsNegativeInfinite f = bfNegInf+  | fpIsNaN f = bfNaN+  | otherwise =+      SBVF.fpValue $+        uncurry (fpEncodeFloat eb sb) $+          decodeFloat f+  where+    eb = fromIntegral $ natVal (Proxy @eb) :: Int+    sb = fromIntegral $ natVal (Proxy @sb) :: Int++fromLibBF :: forall eb sb. (ValidFP eb sb) => BigFloat -> FP eb sb+fromLibBF f+  | bfIsNeg f && bfIsZero f = fpNegativeZero+  | bfIsPos f && bfIsZero f = fpPositiveZero+  | bfIsNeg f && bfIsInf f = fpNegativeInfinite+  | bfIsPos f && bfIsInf f = fpPositiveInfinite+  | bfIsNaN f = fpNaN+  | otherwise = uncurry encodeFloat $ decodeFloat fp+  where+    fp = SBVF.FP eb sb f+    eb = fromIntegral $ natVal (Proxy @eb) :: Int+    sb = fromIntegral $ natVal (Proxy @sb) :: Int++liftLibBF1 ::+  (ValidFP eb sb) =>+  (BFOpts -> BigFloat -> (BigFloat, Status)) ->+  FPRoundingMode ->+  FP eb sb ->+  FP eb sb+liftLibBF1 f rd x = fromLibBF $ fst $ f opts xbf+  where+    opts = libBFOpts rd x+    xbf = toLibBF x++liftLibBF2 ::+  (ValidFP eb sb) =>+  (BFOpts -> BigFloat -> BigFloat -> (BigFloat, Status)) ->+  FPRoundingMode ->+  FP eb sb ->+  FP eb sb ->+  FP eb sb+liftLibBF2 f rd l r = fromLibBF $ fst $ f opts lbf rbf+  where+    opts = libBFOpts rd l+    lbf = toLibBF l+    rbf = toLibBF r++liftLibBF3 ::+  (ValidFP eb sb) =>+  (BFOpts -> BigFloat -> BigFloat -> BigFloat -> (BigFloat, Status)) ->+  FPRoundingMode ->+  FP eb sb ->+  FP eb sb ->+  FP eb sb ->+  FP eb sb+liftLibBF3 f rd x y z = fromLibBF $ fst $ f opts xbf ybf zbf+  where+    opts = libBFOpts rd x+    xbf = toLibBF x+    ybf = toLibBF y+    zbf = toLibBF z++instance (ValidFP eb sb) => IEEEFPRoundingOp (FP eb sb) FPRoundingMode where+  fpAdd = liftLibBF2 bfAdd+  {-# INLINE fpAdd #-}+  fpSub = liftLibBF2 bfSub+  {-# INLINE fpSub #-}+  fpMul = liftLibBF2 bfMul+  {-# INLINE fpMul #-}+  fpDiv = liftLibBF2 bfDiv+  {-# INLINE fpDiv #-}+  fpFMA = liftLibBF3 bfFMA+  {-# INLINE fpFMA #-}+  fpSqrt = liftLibBF1 bfSqrt+  {-# INLINE fpSqrt #-}+  fpRoundToIntegral rd x =+    fromLibBF $ fst $ bfRoundInt (libBFRoundingMode rd) $ toLibBF x+  {-# INLINE fpRoundToIntegral #-}++instance+  (ValidFP eb sb) =>+  IEEEFPConvertible AlgReal (FP eb sb) FPRoundingMode+  where+  fromFPOr d _ fp+    | fpIsInfinite fp = d+    | fpIsNaN fp = d+    | otherwise =+        let (m, n) = decodeFloat fp+         in fromRational (toRational m * (2 ^^ n))+  toFP mode (AlgExactRational v) = fromLibBF $ fst $ bfDiv opts n d+    where+      opts = libBFOpts mode (undefined :: FP eb sb)+      n = bfFromInteger $ numerator v+      d = bfFromInteger $ denominator v+  toFP _ r =+    throw+      UnsupportedAlgRealOperation {op = "toFP", msg = show r}++instance+  (ValidFP eb sb) =>+  IEEEFPToAlgReal AlgReal (FP eb sb) FPRoundingMode++roundRationalToInteger :: FPRoundingMode -> Rational -> Integer+roundRationalToInteger mode r+  | d == 1 = n+  | d == 2 = case mode of+      RNE -> if even ndivd then ndivd else ndivd + 1+      RNA -> if n > 0 then ndivd + 1 else ndivd+      RTP -> ndivd + 1+      RTN -> ndivd+      RTZ -> if n > 0 then ndivd else ndivd + 1+  | otherwise = case mode of+      RNE -> if nmodd > d `div` 2 then ndivd + 1 else ndivd+      RNA -> if nmodd > d `div` 2 then ndivd + 1 else ndivd+      RTP -> ndivd + 1+      RTN -> ndivd+      RTZ -> if n > 0 then ndivd else ndivd + 1+  where+    n = numerator r+    d = denominator r+    ndivd = n `div` d+    nmodd = n `mod` d++instance+  (ValidFP eb sb) =>+  IEEEFPConvertible Integer (FP eb sb) FPRoundingMode+  where+  fromFPOr d mode fp+    | fpIsInfinite fp = d+    | fpIsNaN fp = d+    | otherwise =+        let r = fromFPOr (fromIntegral d) mode fp+         in case r of+              AlgExactRational v -> roundRationalToInteger mode v+              _ -> error "Should not happen"+  toFP mode r = toFP mode (fromIntegral r :: AlgReal)++instance+  (ValidFP eb sb, KnownNat n, 1 <= n) =>+  IEEEFPConvertible (WordN n) (FP eb sb) FPRoundingMode+  where+  fromFPOr d mode fp+    | fpIsInfinite fp = d+    | fpIsNaN fp = d+    | otherwise =+        let p = fromFPOr (fromIntegral d :: Integer) mode fp+         in if p < (fromIntegral (minBound :: WordN n))+              || p > (fromIntegral (maxBound :: WordN n))+              then d+              else fromIntegral p+  toFP mode r = toFP mode (fromIntegral r :: AlgReal)++instance+  (ValidFP eb sb, KnownNat n, 1 <= n) =>+  IEEEFPConvertible (IntN n) (FP eb sb) FPRoundingMode+  where+  fromFPOr d mode fp+    | fpIsInfinite fp = d+    | fpIsNaN fp = d+    | otherwise =+        let p = fromFPOr (fromIntegral d :: Integer) mode fp+         in if p < (fromIntegral (minBound :: IntN n))+              || p > (fromIntegral (maxBound :: IntN n))+              then d+              else fromIntegral p+  toFP mode r = toFP mode (fromIntegral r :: AlgReal)++instance+  (ValidFP eb sb, ValidFP eb' sb') =>+  IEEEFPConvertible (FP eb' sb') (FP eb sb) FPRoundingMode+  where+  fromFPOr _ = toFP+  toFP mode fp+    | fpIsNegativeInfinite fp = fpNegativeInfinite+    | fpIsPositiveInfinite fp = fpPositiveInfinite+    | fpIsNaN fp = fpNaN+    | fpIsNegativeZero fp = fpNegativeZero+    | fpIsPositiveZero fp = fpPositiveZero+    | otherwise =+        let bffp = toLibBF fp+            opts = libBFOpts mode (undefined :: FP eb sb)+         in fromLibBF $ fst $ bfRoundFloat opts bffp++-- | Next representable floating-point number.+--+-- Note:+--+-- > nextFP(+inf) = +inf+-- > nextFP(-inf) = -maxNormalized+-- > nextFP(NaN) = NaN+--+-- The function do not distinguish between -0 and +0.+nextFP :: forall eb sb. (ValidFP eb sb) => FP eb sb -> FP eb sb+nextFP x+  | fpIsNaN x = fpNaN+  | fpIsNegativeInfinite x = -fpMaxNormalized+  | x == -fpMinNormalized = -fpMaxSubnormal+  | x == -fpMinSubnormal = 0+  | x == 0 = fpMinSubnormal+  | x == fpMaxSubnormal = fpMinNormalized+  | x == fpMaxNormalized = fpPositiveInfinite+  | fpIsPositiveInfinite x = fpPositiveInfinite+  | x > 0 =+      withValidFPProofs @eb @sb $+        bitCast ((bitCastOrCanonical x :: WordN (eb + sb)) + 1)+  | otherwise =+      withValidFPProofs @eb @sb $+        bitCast ((bitCastOrCanonical x :: WordN (eb + sb)) - 1)++-- | Previous representable floating-point number.+--+-- Note:+--+-- > prevFP(+inf) = +maxNormalized+-- > prevFP(-inf) = -inf+-- > prevFP(NaN) = NaN+--+-- The function do not distinguish between -0 and +0.+prevFP :: forall eb sb. (ValidFP eb sb) => FP eb sb -> FP eb sb+prevFP x+  | fpIsNaN x = fpNaN+  | fpIsPositiveInfinite x = fpMaxNormalized+  | x == fpMinNormalized = fpMaxSubnormal+  | x == fpMinSubnormal = 0+  | x == 0 = -fpMinSubnormal+  | x == -fpMaxSubnormal = -fpMinNormalized+  | x == -fpMaxNormalized = fpNegativeInfinite+  | fpIsNegativeInfinite x = fpNegativeInfinite+  | x > 0 =+      withValidFPProofs @eb @sb $+        bitCast ((bitCastOrCanonical x :: WordN (eb + sb)) - 1)+  | otherwise =+      withValidFPProofs @eb @sb $+        bitCast ((bitCastOrCanonical x :: WordN (eb + sb)) + 1)++-- | Bounds for converting bit vectors to floating-point numbers. Out-of-range+-- FP values cannot be converted to a representable bit-vector.+class ConvertibleBound bv where+  convertibleLowerBound ::+    forall eb sb n.+    (ValidFP eb sb, KnownNat n, 1 <= n) =>+    bv n ->+    FPRoundingMode ->+    FP eb sb+  convertibleUpperBound ::+    forall eb sb n.+    (ValidFP eb sb, KnownNat n, 1 <= n) =>+    bv n ->+    FPRoundingMode ->+    FP eb sb++instance ConvertibleBound WordN where+  convertibleLowerBound _ RTP = nextFP $ -1+  convertibleLowerBound _ RTZ = nextFP $ -1+  convertibleLowerBound _ RTN = 0+  convertibleLowerBound _ RNA = nextFP $ -0.5+  convertibleLowerBound _ RNE = -0.5+  convertibleUpperBound ::+    forall eb sb n.+    (ValidFP eb sb, KnownNat n, 1 <= n) =>+    WordN n ->+    FPRoundingMode ->+    FP eb sb+  convertibleUpperBound _ mode+    | ebn < n = fpMaxNormalized+    | ebn == n && sb <= n = fpMaxNormalized+    | ebn >= n && sb > n = case mode of+        RTP -> toFP rne (maxBound :: WordN n)+        RTZ -> prevFP $ toFP rne (maxBound :: WordN n) + 1+        RTN -> prevFP $ toFP rne (maxBound :: WordN n) + 1+        RNA -> prevFP $ toFP rne (maxBound :: WordN n) + 0.5+        RNE -> prevFP $ toFP rne (maxBound :: WordN n) + 0.5+    | ebn > n && sb == n = toFP rne (maxBound :: WordN n)+    -- ebn > n && sb < n+    | otherwise =+        prevFP $ toFP rne (maxBound `div` 2 + 1 :: WordN n) * 2+    where+      n = natVal (Proxy @n)+      eb = natVal (Proxy @eb)+      ebn = 2 ^ (eb - 1)+      sb = natVal (Proxy @sb)++instance ConvertibleBound IntN where+  convertibleLowerBound ::+    forall eb sb n.+    (ValidFP eb sb, KnownNat n, 1 <= n) =>+    IntN n ->+    FPRoundingMode ->+    FP eb sb+  convertibleLowerBound _ mode+    | ebn <= n - 1 = -fpMaxNormalized+    | ebn > n - 1 && sb <= n - 1 = toFP rne (minBound :: IntN n)+    -- ebn > n - 1 && sb > n - 1+    | otherwise = case mode of+        RTP -> nextFP $ toFP rne (minBound :: IntN n) - 1+        RTZ -> nextFP $ toFP rne (minBound :: IntN n) - 1+        RTN -> toFP rne (minBound :: IntN n)+        RNA ->+          if sb == n+            then toFP rne (minBound :: IntN n) - 0.5+            else nextFP $ toFP rne (minBound :: IntN n) - 0.5+        RNE -> toFP rne (minBound :: IntN n) - 0.5+    where+      n = natVal (Proxy @n)+      eb = natVal (Proxy @eb)+      ebn = 2 ^ (eb - 1)+      sb = natVal (Proxy @sb)+  convertibleUpperBound ::+    forall eb sb n.+    (ValidFP eb sb, KnownNat n, 1 <= n) =>+    IntN n ->+    FPRoundingMode ->+    FP eb sb+  convertibleUpperBound _ mode+    | ebn < n - 1 = fpMaxNormalized+    | ebn == n - 1 && sb <= n - 1 = fpMaxNormalized+    | ebn >= n - 1 && sb > n - 1 = case mode of+        RTP -> toFP rne (maxBound :: IntN n)+        RTZ -> prevFP $ toFP rne (maxBound :: IntN n) + 1+        RTN -> prevFP $ toFP rne (maxBound :: IntN n) + 1+        RNA -> prevFP $ toFP rne (maxBound :: IntN n) + 0.5+        RNE -> prevFP $ toFP rne (maxBound :: IntN n) + 0.5+    | ebn > n - 1 && sb == n - 1 = toFP rne (maxBound :: IntN n)+    -- ebn > n - 1 && sb < n - 1+    | otherwise =+        prevFP $ toFP rne (maxBound `div` 2 + 1 :: IntN n) * 2+    where+      n = natVal (Proxy @n)+      eb = natVal (Proxy @eb)+      ebn = 2 ^ (eb - 1)+      sb = natVal (Proxy @sb)++instance Apply (FP eb sb) where+  type FunType (FP eb sb) = FP eb sb+  apply = id++instance Apply FPRoundingMode where+  type FunType FPRoundingMode = FPRoundingMode+  apply = id++instance (ValidFP eb sb) => Serial (FP eb sb) where+  serialize x =+    withValidFPProofs @eb @sb $+      serialize (bitCastOrCanonical x :: WordN (eb + sb))+  deserialize = do+    w :: WordN (eb + sb) <- withValidFPProofs @eb @sb deserialize+    return $ withValidFPProofs @eb @sb $ bitCast w++instance (ValidFP eb sb) => Cereal.Serialize (FP eb sb) where+  put = serialize+  get = deserialize++instance (ValidFP eb sb) => Binary.Binary (FP eb sb) where+  put = serialize+  get = deserialize
+ src/Grisette/Internal/SymPrim/FunInstanceGen.hs view
@@ -0,0 +1,258 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Avoid lambda" #-}++-- |+-- Module      :   Grisette.Internal.SymPrim.FunInstanceGen+-- 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.FunInstanceGen+  ( supportedPrimFun,+    supportedPrimFunUpTo,+  )+where++import qualified Data.SBV as SBV+import Grisette.Internal.SymPrim.Prim.Internal.Term+  ( IsSymbolKind,+    SupportedNonFuncPrim,+    SupportedPrim+      ( castTypedSymbol,+        conSBVTerm,+        defaultValue,+        funcDummyConstraint,+        parseSMTModelResult,+        pevalDistinctTerm,+        pevalEqTerm,+        pevalITETerm,+        sameCon,+        sbvDistinct,+        sbvEq,+        symSBVName,+        symSBVTerm,+        withPrim+      ),+    TypedSymbol (unTypedSymbol),+    decideSymbolKind,+    translateTypeError,+    typedAnySymbol,+    withNonFuncPrim,+  )+import Language.Haskell.TH+  ( Cxt,+    Dec (InstanceD),+    DecsQ,+    Exp,+    ExpQ,+    Name,+    Overlap (Overlapping),+    Q,+    Type,+    TypeQ,+    forallT,+    lamE,+    newName,+    sigD,+    stringE,+    varE,+    varP,+    varT,+  )+import Language.Haskell.TH.Datatype.TyVarBndr+  ( plainTVInferred,+    plainTVSpecified,+  )+import Type.Reflection (TypeRep, typeRep, type (:~~:) (HRefl))++instanceWithOverlapDescD ::+  Maybe Overlap -> Q Cxt -> Q Type -> [DecsQ] -> DecsQ+instanceWithOverlapDescD o ctxts ty descs = do+  ctxts1 <- ctxts+  descs1 <- sequence descs+  ty1 <- ty+  return [InstanceD o ctxts1 ty1 (concat descs1)]++-- | Generate an instance of 'SupportedPrim' for a function with a given number+-- of arguments.+supportedPrimFun ::+  ExpQ ->+  ExpQ ->+  ExpQ ->+  ([TypeQ] -> ExpQ) ->+  String ->+  String ->+  Name ->+  Int ->+  DecsQ+supportedPrimFun+  dv+  ite+  parse+  consbv+  funNameInError+  funNamePrefix+  funTypeName+  numArg = do+    names <- traverse (newName . ("a" <>) . show) [0 .. numArg - 1]++    let tyVars = varT <$> names+    knd <- newName "knd"+    knd' <- newName "knd'"+    let kndty = varT knd+    let knd'ty = varT knd'+    instanceWithOverlapDescD+      (if numArg == 2 then Nothing else Just Overlapping)+      (constraints tyVars)+      [t|SupportedPrim $(funType tyVars)|]+      ( [ [d|$(varP 'sameCon) = (==)|],+          [d|$(varP 'defaultValue) = $dv|],+          [d|$(varP 'pevalITETerm) = $ite|],+          [d|+            $(varP 'pevalEqTerm) =+              $( translateError+                   tyVars+                   "does not supported equality comparison."+               )+            |],+          [d|+            $(varP 'pevalDistinctTerm) =+              $( translateError+                   tyVars+                   "does not supported equality comparison."+               )+            |],+          [d|+            $(varP 'conSBVTerm) = $(consbv tyVars)+            |],+          -- \$( translateError+          --      tyVars+          --      ( "must have already been partially evaluated away before "+          --          <> "reaching this point."+          --      )+          --  )++          [d|+            $(varP 'symSBVName) = \_ num ->+              $(stringE $ funNamePrefix <> show numArg <> "_") <> show num+            |],+          [d|+            $(varP 'symSBVTerm) = \r ->+              withPrim @($(funType tyVars)) $ return $ SBV.uninterpret r+            |],+          [d|$(varP 'withPrim) = $(withPrims tyVars)|],+          [d|+            $(varP 'sbvEq) =+              $( translateError+                   tyVars+                   "does not support equality comparison."+               )+            |],+          [d|+            $(varP 'sbvDistinct) =+              $( translateError+                   tyVars+                   "does not support equality comparison."+               )+            |],+          [d|$(varP 'parseSMTModelResult) = $parse|],+          (: [])+            <$> sigD+              'castTypedSymbol+              ( forallT+                  [plainTVInferred knd, plainTVSpecified knd']+                  ((: []) <$> [t|IsSymbolKind $knd'ty|])+                  [t|+                    TypedSymbol $kndty $(funType tyVars) ->+                    Maybe (TypedSymbol $knd'ty $(funType tyVars))+                    |]+              ),+          [d|+            $(varP 'castTypedSymbol) = \sym ->+              case decideSymbolKind @($knd'ty) of+                Left HRefl -> Nothing+                Right HRefl -> Just $ typedAnySymbol $ unTypedSymbol sym+            |],+          ( if numArg == 2+              then+                [d|+                  $(varP 'funcDummyConstraint) = \f ->+                    withPrim @($(funType tyVars)) $+                      withNonFuncPrim @($(last tyVars)) $ do+                        f (conSBVTerm (defaultValue :: $(head tyVars)))+                          SBV..== f+                            (conSBVTerm (defaultValue :: $(head tyVars)))+                  |]+              else+                [d|+                  $(varP 'funcDummyConstraint) = \f ->+                    withNonFuncPrim @($(head tyVars)) $+                      funcDummyConstraint @($(funType $ tail tyVars))+                        (f (conSBVTerm (defaultValue :: $(head tyVars))))+                  |]+          )+        ]+      )+    where+      translateError tyVars finalMsg =+        [|+          translateTypeError+            ( Just+                $( stringE $+                     "BUG. Please send a bug report. "+                       <> funNameInError+                       <> " "+                       <> finalMsg+                 )+            )+            (typeRep :: TypeRep $(funType tyVars))+          |]++      constraints =+        fmap concat . traverse (\ty -> sequence [[t|SupportedNonFuncPrim $ty|]])+      funType =+        foldl1 (\fty ty -> [t|$(varT funTypeName) $ty $fty|]) . reverse+      withPrims :: [Q Type] -> Q Exp+      withPrims tyVars = do+        r <- newName "r"+        lamE [varP r] $+          foldr+            (\ty r -> [|withNonFuncPrim @($ty) $r|])+            (varE r)+            tyVars++-- | Generate instances of 'SupportedPrim' for functions with up to a given+-- number of arguments.+supportedPrimFunUpTo ::+  ExpQ -> ExpQ -> ExpQ -> ([TypeQ] -> ExpQ) -> String -> String -> Name -> Int -> DecsQ+supportedPrimFunUpTo+  dv+  ite+  parse+  consbv+  funNameInError+  funNamePrefix+  funTypeName+  numArg =+    concat+      <$> sequence+        [ supportedPrimFun+            dv+            ite+            parse+            consbv+            funNameInError+            funNamePrefix+            funTypeName+            n+        | n <- [2 .. numArg]+        ]
+ src/Grisette/Internal/SymPrim/GeneralFun.hs view
@@ -0,0 +1,602 @@+{-# LANGUAGE CPP #-}+{-# HLINT ignore "Eta reduce" #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++-- |+-- Module      :   Grisette.Internal.SymPrim.GeneralFun+-- 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.GeneralFun+  ( type (-->) (..),+    buildGeneralFun,+    generalSubstSomeTerm,+    substTerm,+    freshArgSymbol,+  )+where++#if MIN_VERSION_base(4,20,0)+#else+import Data.Foldable (Foldable (foldl'))+#endif++import Control.DeepSeq (NFData (rnf))+import Data.Bifunctor (Bifunctor (second))+import qualified Data.HashSet as HS+import Data.Hashable (Hashable (hashWithSalt))+import Data.Maybe (fromJust)+import qualified Data.SBV as SBV+import qualified Data.SBV.Dynamic as SBVD+import Grisette.Internal.Core.Data.Class.Function+  ( Apply (FunType, apply),+    Function ((#)),+  )+import Grisette.Internal.Core.Data.MemoUtils (htmemo)+import Grisette.Internal.Core.Data.Symbol+  ( Symbol (IndexedSymbol),+  )+import Grisette.Internal.SymPrim.FunInstanceGen (supportedPrimFunUpTo)+import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalFP ()+import Grisette.Internal.SymPrim.Prim.Internal.PartialEval (totalize2)+import Grisette.Internal.SymPrim.Prim.Internal.Term+  ( IsSymbolKind,+    LinkedRep (underlyingTerm, wrapTerm),+    NonFuncPrimConstraint,+    NonFuncSBVBaseType,+    PEvalApplyTerm (pevalApplyTerm, sbvApplyTerm),+    PEvalBVTerm (pevalBVConcatTerm, pevalBVExtendTerm, pevalBVSelectTerm),+    PEvalBitCastOrTerm (pevalBitCastOrTerm),+    PEvalBitCastTerm (pevalBitCastTerm),+    PEvalBitwiseTerm+      ( pevalAndBitsTerm,+        pevalComplementBitsTerm,+        pevalOrBitsTerm,+        pevalXorBitsTerm+      ),+    PEvalDivModIntegralTerm+      ( pevalDivIntegralTerm,+        pevalModIntegralTerm+      ),+    PEvalFPTerm+      ( pevalFPBinaryTerm,+        pevalFPFMATerm,+        pevalFPRoundingBinaryTerm,+        pevalFPRoundingUnaryTerm,+        pevalFPTraitTerm,+        pevalFPUnaryTerm+      ),+    PEvalFloatingTerm (pevalFloatingUnaryTerm, pevalPowerTerm),+    PEvalFractionalTerm (pevalFdivTerm, pevalRecipTerm),+    PEvalFromIntegralTerm (pevalFromIntegralTerm),+    PEvalIEEEFPConvertibleTerm (pevalFromFPOrTerm, pevalToFPTerm),+    PEvalNumTerm+      ( pevalAbsNumTerm,+        pevalAddNumTerm,+        pevalMulNumTerm,+        pevalNegNumTerm,+        pevalSignumNumTerm+      ),+    PEvalOrdTerm (pevalLeOrdTerm, pevalLtOrdTerm),+    PEvalRotateTerm (pevalRotateRightTerm),+    PEvalShiftTerm (pevalShiftLeftTerm, pevalShiftRightTerm),+    SBVRep (SBVType),+    SomeTypedAnySymbol,+    SomeTypedConstantSymbol,+    SupportedNonFuncPrim (withNonFuncPrim),+    SupportedPrim+      ( castTypedSymbol,+        defaultValue,+        parseSMTModelResult,+        pevalDistinctTerm,+        pevalITETerm,+        primTypeRep,+        withPrim+      ),+    SupportedPrimConstraint (PrimConstraint),+    SymRep (SymType),+    SymbolKind (AnyKind),+    Term,+    TypedAnySymbol,+    TypedConstantSymbol,+    TypedSymbol,+    applyTerm,+    conTerm,+    eqHeteroSymbol,+    existsTerm,+    forallTerm,+    partitionCVArg,+    pevalAndTerm,+    pevalEqTerm,+    pevalITEBasicTerm,+    pevalNotTerm,+    pevalOrTerm,+    pevalQuotIntegralTerm,+    pevalRemIntegralTerm,+    pevalRotateLeftTerm,+    pformatTerm,+    someTypedSymbol,+    symTerm,+    translateTypeError,+    typedAnySymbol,+    typedConstantSymbol,+    pattern AbsNumTerm,+    pattern AddNumTerm,+    pattern AndBitsTerm,+    pattern AndTerm,+    pattern ApplyTerm,+    pattern BVConcatTerm,+    pattern BVExtendTerm,+    pattern BVSelectTerm,+    pattern BitCastOrTerm,+    pattern BitCastTerm,+    pattern ComplementBitsTerm,+    pattern ConTerm,+    pattern DistinctTerm,+    pattern DivIntegralTerm,+    pattern EqTerm,+    pattern ExistsTerm,+    pattern FPBinaryTerm,+    pattern FPFMATerm,+    pattern FPRoundingBinaryTerm,+    pattern FPRoundingUnaryTerm,+    pattern FPTraitTerm,+    pattern FPUnaryTerm,+    pattern FdivTerm,+    pattern FloatingUnaryTerm,+    pattern ForallTerm,+    pattern FromFPOrTerm,+    pattern FromIntegralTerm,+    pattern ITETerm,+    pattern LeOrdTerm,+    pattern LtOrdTerm,+    pattern ModIntegralTerm,+    pattern MulNumTerm,+    pattern NegNumTerm,+    pattern NotTerm,+    pattern OrBitsTerm,+    pattern OrTerm,+    pattern PowerTerm,+    pattern QuotIntegralTerm,+    pattern RecipTerm,+    pattern RemIntegralTerm,+    pattern RotateLeftTerm,+    pattern RotateRightTerm,+    pattern ShiftLeftTerm,+    pattern ShiftRightTerm,+    pattern SignumNumTerm,+    pattern SupportedTypedSymbol,+    pattern SymTerm,+    pattern ToFPTerm,+    pattern XorBitsTerm,+  )+import Grisette.Internal.SymPrim.Prim.Pattern (pattern SubTerms)+import Grisette.Internal.SymPrim.Prim.SomeTerm (SomeTerm (SomeTerm), someTerm)+import Language.Haskell.TH.Syntax (Lift (liftTyped))+import Type.Reflection+  ( TypeRep,+    eqTypeRep,+    typeRep,+    pattern App,+    type (:~~:) (HRefl),+  )+import Unsafe.Coerce (unsafeCoerce)++-- $setup+-- >>> import Grisette.Core+-- >>> import Grisette.SymPrim++-- | General symbolic function type. Use the '#' operator to apply the function.+-- Note that this function should be applied to symbolic values only. It is by+-- itself already a symbolic value, but can be considered partially concrete+-- as the function body is specified. Use 'Grisette.SymPrim.SymPrim.-~>'+-- for uninterpreted general symbolic functions.+--+-- The result would be partially evaluated.+--+-- >>> let f = ("x" :: TypedConstantSymbol Integer) --> ("x" + 1 + "y" :: SymInteger) :: Integer --> Integer+-- >>> f # 1    -- 1 has the type SymInteger+-- (+ 2 y)+-- >>> f # "a"  -- "a" has the type SymInteger+-- (+ 1 (+ a y))+data (-->) a b where+  GeneralFun ::+    (SupportedNonFuncPrim a, SupportedPrim b) =>+    TypedConstantSymbol a ->+    Term b ->+    a --> b++instance (LinkedRep a sa, LinkedRep b sb) => Function (a --> b) sa sb where+  (GeneralFun s t) # x = wrapTerm $ substTerm s (underlyingTerm x) HS.empty t++infixr 0 -->++extractSymSomeTermIncludeBoundedVars ::+  SomeTerm -> HS.HashSet SomeTypedAnySymbol+extractSymSomeTermIncludeBoundedVars = htmemo go+  where+    goTyped :: Term a -> HS.HashSet SomeTypedAnySymbol+    goTyped = go . someTerm++    go :: SomeTerm -> HS.HashSet SomeTypedAnySymbol+    go (SomeTerm (SymTerm (sym :: TypedAnySymbol a))) =+      HS.singleton $ someTypedSymbol sym+    go (SomeTerm (ConTerm cv :: Term v)) =+      case (primTypeRep :: TypeRep v) of+        App (App gf _) _ ->+          case eqTypeRep (typeRep @(-->)) gf of+            Just HRefl ->+              case cv of+                GeneralFun (tsym :: TypedConstantSymbol x) tm ->+                  HS.union+                    ( HS.singleton+                        (someTypedSymbol $ fromJust $ castTypedSymbol tsym)+                    )+                    $ go (SomeTerm tm)+            Nothing -> HS.empty+        _ -> HS.empty+    go (SomeTerm (ForallTerm sym arg)) =+      HS.insert (someTypedSymbol $ fromJust $ castTypedSymbol sym) $ goTyped arg+    go (SomeTerm (ExistsTerm sym arg)) =+      HS.insert (someTypedSymbol $ fromJust $ castTypedSymbol sym) $ goTyped arg+    go (SomeTerm (SubTerms tms)) = mconcat <$> map go $ tms++-- | Generate a fresh argument symbol that is not used as bounded or unbounded+-- variables in the function body for a general symbolic function.+freshArgSymbol ::+  forall a. (SupportedNonFuncPrim a) => [SomeTerm] -> TypedConstantSymbol a+freshArgSymbol terms = typedConstantSymbol $ go 0+  where+    allSymbols = mconcat $ extractSymSomeTermIncludeBoundedVars <$> terms+    go :: Int -> Symbol+    go n =+      let currentSymbol = IndexedSymbol "arg" n+          currentTypedSymbol =+            someTypedSymbol (typedAnySymbol currentSymbol :: TypedAnySymbol a)+       in if HS.member currentTypedSymbol allSymbols+            then go (n + 1)+            else currentSymbol++-- | Build a general symbolic function with a bounded symbol and a term.+buildGeneralFun ::+  forall a b.+  (SupportedNonFuncPrim a, SupportedPrim b) =>+  TypedConstantSymbol a ->+  Term b ->+  a --> b+buildGeneralFun arg v =+  GeneralFun+    argSymbol+    (substTerm arg (symTerm argSymbol) HS.empty v)+  where+    argSymbol = freshArgSymbol [SomeTerm v]++-- | Checks if two formulas are the same. Not building the actual symbolic+-- equality formula.+--+-- The reason why we choose this behavior is to allow symbolic variables to be+-- used as keys in hash maps, which can be useful for memoization.+--+-- Use with caution. Usually you should use t'Grisette.Core.SymEq' instead.+instance Eq (a --> b) where+  GeneralFun sym1 tm1 == GeneralFun sym2 tm2 = sym1 == sym2 && tm1 == tm2++instance Show (a --> b) where+  show (GeneralFun sym tm) = "\\(" ++ show sym ++ ") -> " ++ pformatTerm tm++instance Lift (a --> b) where+  liftTyped (GeneralFun sym tm) = [||GeneralFun sym tm||]++instance Hashable (a --> b) where+  s `hashWithSalt` (GeneralFun sym tm) = s `hashWithSalt` sym `hashWithSalt` tm++instance NFData (a --> b) where+  rnf (GeneralFun sym tm) = rnf sym `seq` rnf tm++instance+  (SupportedNonFuncPrim a, SupportedPrim b) =>+  SupportedPrimConstraint (a --> b)+  where+  type+    PrimConstraint (a --> b) =+      ( SupportedNonFuncPrim a,+        SupportedPrim b,+        NonFuncPrimConstraint a,+        PrimConstraint b,+        SBVType (a --> b) ~ (SBV.SBV (NonFuncSBVBaseType a) -> SBVType b)+      )++instance+  (SupportedNonFuncPrim a, SupportedPrim b) =>+  SBVRep (a --> b)+  where+  type+    SBVType (a --> b) =+      SBV.SBV (NonFuncSBVBaseType a) ->+      SBVType b++instance (Apply st, LinkedRep ca sa, LinkedRep ct st) => Apply (ca --> ct) where+  type FunType (ca --> ct) = SymType ca -> FunType (SymType ct)+  apply uf a = apply (uf # a)++pevalGeneralFunApplyTerm ::+  ( SupportedNonFuncPrim a,+    SupportedPrim b,+    SupportedPrim (a --> b)+  ) =>+  Term (a --> b) ->+  Term a ->+  Term b+pevalGeneralFunApplyTerm = totalize2 doPevalApplyTerm applyTerm+  where+    doPevalApplyTerm (ConTerm (GeneralFun arg tm)) v =+      Just $ substTerm arg v HS.empty tm+    doPevalApplyTerm (ITETerm c l r) v =+      return $ pevalITETerm c (pevalApplyTerm l v) (pevalApplyTerm r v)+    doPevalApplyTerm _ _ = Nothing++instance+  ( SupportedPrim (a --> b),+    SupportedNonFuncPrim a,+    SupportedPrim b+  ) =>+  PEvalApplyTerm (a --> b) a b+  where+  pevalApplyTerm = pevalGeneralFunApplyTerm+  sbvApplyTerm f a =+    withPrim @(a --> b) $ withNonFuncPrim @a $ f a++parseGeneralFunSMTModelResult ::+  forall a b.+  (SupportedNonFuncPrim a, SupportedPrim b) =>+  Int ->+  ([([SBVD.CV], SBVD.CV)], SBVD.CV) ->+  a --> b+parseGeneralFunSMTModelResult level (l, s) =+  let sym = typedConstantSymbol $ IndexedSymbol "arg" level+      funs =+        second+          ( \r ->+              case r of+                [([], v)] -> parseSMTModelResult (level + 1) ([], v)+                _ -> parseSMTModelResult (level + 1) (r, s)+          )+          <$> partitionCVArg @a l+      def = parseSMTModelResult (level + 1) ([], s)+      body =+        foldl'+          ( \acc (v, f) ->+              pevalITETerm+                (pevalEqTerm (symTerm sym) (conTerm v))+                (conTerm f)+                acc+          )+          (conTerm def)+          funs+   in buildGeneralFun sym body++-- | General procedure for substituting symbols in a term.+{-# NOINLINE generalSubstSomeTerm #-}+generalSubstSomeTerm ::+  forall v.+  (forall a. TypedSymbol 'AnyKind a -> Term a) ->+  HS.HashSet SomeTypedConstantSymbol ->+  Term v ->+  Term v+generalSubstSomeTerm subst initialBoundedSymbols = go initialMemo+  where+    go :: forall a. (SomeTerm -> SomeTerm) -> Term a -> Term a+    go memo a = case memo $ someTerm a of+      SomeTerm v -> unsafeCoerce v+    initialMemo :: SomeTerm -> SomeTerm+    initialMemo = htmemo (goSome initialMemo initialBoundedSymbols)+    {-# NOINLINE initialMemo #-}+    goSome ::+      (SomeTerm -> SomeTerm) ->+      HS.HashSet SomeTypedConstantSymbol ->+      SomeTerm ->+      SomeTerm+    goSome _ bs c@(SomeTerm (ConTerm cv :: Term x)) =+      case (primTypeRep :: TypeRep x) of+        App (App gf _) _ ->+          case eqTypeRep gf (typeRep @(-->)) of+            Just HRefl -> case cv of+              GeneralFun sym (tm :: Term r) ->+                let newmemo =+                      htmemo+                        ( goSome+                            newmemo+                            (HS.union (HS.singleton (someTypedSymbol sym)) bs)+                        )+                    {-# NOINLINE newmemo #-}+                 in SomeTerm $ conTerm $ GeneralFun sym (go newmemo tm)+            Nothing -> c+        _ -> c+    goSome _ bs c@(SomeTerm ((SymTerm sym) :: Term a)) =+      case castTypedSymbol sym of+        Just sym' | HS.member (someTypedSymbol sym') bs -> c+        _ -> SomeTerm $ subst sym+    goSome _ bs (SomeTerm (ForallTerm tsym b)) =+      let newmemo =+            htmemo (goSome newmemo (HS.insert (someTypedSymbol tsym) bs))+          {-# NOINLINE newmemo #-}+       in goUnary newmemo (forallTerm tsym) b+    goSome _ bs (SomeTerm (ExistsTerm tsym b)) =+      let newmemo =+            htmemo (goSome newmemo (HS.insert (someTypedSymbol tsym) bs))+          {-# NOINLINE newmemo #-}+       in goUnary newmemo (existsTerm tsym) b+    goSome memo _ (SomeTerm (NotTerm arg)) =+      goUnary memo pevalNotTerm arg+    goSome memo _ (SomeTerm (OrTerm arg1 arg2)) =+      goBinary memo pevalOrTerm arg1 arg2+    goSome memo _ (SomeTerm (AndTerm arg1 arg2)) =+      goBinary memo pevalAndTerm arg1 arg2+    goSome memo _ (SomeTerm (EqTerm arg1 arg2)) =+      goBinary memo pevalEqTerm arg1 arg2+    goSome memo _ (SomeTerm (DistinctTerm args)) =+      SomeTerm $ pevalDistinctTerm (fmap (go memo) args)+    goSome memo _ (SomeTerm (ITETerm cond arg1 arg2)) =+      goTernary memo pevalITETerm cond arg1 arg2+    goSome memo _ (SomeTerm (AddNumTerm arg1 arg2)) =+      goBinary memo pevalAddNumTerm arg1 arg2+    goSome memo _ (SomeTerm (NegNumTerm arg)) =+      goUnary memo pevalNegNumTerm arg+    goSome memo _ (SomeTerm (MulNumTerm arg1 arg2)) =+      goBinary memo pevalMulNumTerm arg1 arg2+    goSome memo _ (SomeTerm (AbsNumTerm arg)) =+      goUnary memo pevalAbsNumTerm arg+    goSome memo _ (SomeTerm (SignumNumTerm arg)) =+      goUnary memo pevalSignumNumTerm arg+    goSome memo _ (SomeTerm (LtOrdTerm arg1 arg2)) =+      goBinary memo pevalLtOrdTerm arg1 arg2+    goSome memo _ (SomeTerm (LeOrdTerm arg1 arg2)) =+      goBinary memo pevalLeOrdTerm arg1 arg2+    goSome memo _ (SomeTerm (AndBitsTerm arg1 arg2)) =+      goBinary memo pevalAndBitsTerm arg1 arg2+    goSome memo _ (SomeTerm (OrBitsTerm arg1 arg2)) =+      goBinary memo pevalOrBitsTerm arg1 arg2+    goSome memo _ (SomeTerm (XorBitsTerm arg1 arg2)) =+      goBinary memo pevalXorBitsTerm arg1 arg2+    goSome memo _ (SomeTerm (ComplementBitsTerm arg)) =+      goUnary memo pevalComplementBitsTerm arg+    goSome memo _ (SomeTerm (ShiftLeftTerm arg n)) =+      goBinary memo pevalShiftLeftTerm arg n+    goSome memo _ (SomeTerm (RotateLeftTerm arg n)) =+      goBinary memo pevalRotateLeftTerm arg n+    goSome memo _ (SomeTerm (ShiftRightTerm arg n)) =+      goBinary memo pevalShiftRightTerm arg n+    goSome memo _ (SomeTerm (RotateRightTerm arg n)) =+      goBinary memo pevalRotateRightTerm arg n+    goSome memo _ (SomeTerm (BitCastTerm (arg :: Term a) :: Term r)) =+      goUnary memo (pevalBitCastTerm @a @r) arg+    goSome memo _ (SomeTerm (BitCastOrTerm (d :: term r) (arg :: Term a) :: Term r)) =+      goBinary memo (pevalBitCastOrTerm @a @r) d arg+    goSome memo _ (SomeTerm (BVConcatTerm arg1 arg2)) =+      goBinary memo pevalBVConcatTerm arg1 arg2+    goSome memo _ (SomeTerm (BVSelectTerm ix w arg)) =+      goUnary memo (pevalBVSelectTerm ix w) arg+    goSome memo _ (SomeTerm (BVExtendTerm n signed arg)) =+      goUnary memo (pevalBVExtendTerm n signed) arg+    goSome memo _ (SomeTerm (ApplyTerm f arg)) =+      goBinary memo pevalApplyTerm f arg+    goSome memo _ (SomeTerm (DivIntegralTerm arg1 arg2)) =+      goBinary memo pevalDivIntegralTerm arg1 arg2+    goSome memo _ (SomeTerm (ModIntegralTerm arg1 arg2)) =+      goBinary memo pevalModIntegralTerm arg1 arg2+    goSome memo _ (SomeTerm (QuotIntegralTerm arg1 arg2)) =+      goBinary memo pevalQuotIntegralTerm arg1 arg2+    goSome memo _ (SomeTerm (RemIntegralTerm arg1 arg2)) =+      goBinary memo pevalRemIntegralTerm arg1 arg2+    goSome memo _ (SomeTerm (FPTraitTerm trait arg)) =+      goUnary memo (pevalFPTraitTerm trait) arg+    goSome memo _ (SomeTerm (FdivTerm arg1 arg2)) =+      goBinary memo pevalFdivTerm arg1 arg2+    goSome memo _ (SomeTerm (RecipTerm arg)) =+      goUnary memo pevalRecipTerm arg+    goSome memo _ (SomeTerm (FloatingUnaryTerm op arg)) =+      goUnary memo (pevalFloatingUnaryTerm op) arg+    goSome memo _ (SomeTerm (PowerTerm arg1 arg2)) =+      goBinary memo pevalPowerTerm arg1 arg2+    goSome memo _ (SomeTerm (FPUnaryTerm op arg)) =+      goUnary memo (pevalFPUnaryTerm op) arg+    goSome memo _ (SomeTerm (FPBinaryTerm op arg1 arg2)) =+      goBinary memo (pevalFPBinaryTerm op) arg1 arg2+    goSome memo _ (SomeTerm (FPRoundingUnaryTerm op mode arg)) =+      goUnary memo (pevalFPRoundingUnaryTerm op mode) arg+    goSome memo _ (SomeTerm (FPRoundingBinaryTerm op mode arg1 arg2)) =+      goBinary memo (pevalFPRoundingBinaryTerm op mode) arg1 arg2+    goSome memo _ (SomeTerm (FPFMATerm mode arg1 arg2 arg3)) =+      SomeTerm $+        pevalFPFMATerm+          (go memo mode)+          (go memo arg1)+          (go memo arg2)+          (go memo arg3)+    goSome memo _ (SomeTerm (FromIntegralTerm (arg :: Term a) :: Term b)) =+      goUnary memo (pevalFromIntegralTerm @a @b) arg+    goSome memo _ (SomeTerm (FromFPOrTerm d mode arg)) =+      goTernary memo pevalFromFPOrTerm d mode arg+    goSome+      memo+      _+      (SomeTerm (ToFPTerm mode (arg :: Term a) (_ :: p eb) (_ :: q sb))) =+        goBinary memo (pevalToFPTerm @a @eb @sb) mode arg+    goUnary memo f a = SomeTerm $ f (go memo a)+    goBinary memo f a b = SomeTerm $ f (go memo a) (go memo b)+    goTernary memo f a b c =+      SomeTerm $ f (go memo a) (go memo b) (go memo c)++-- | Substitute a term for a symbol in a term.+substTerm ::+  forall knd a b.+  (SupportedPrim a, SupportedPrim b, IsSymbolKind knd) =>+  TypedSymbol knd a ->+  Term a ->+  HS.HashSet SomeTypedConstantSymbol ->+  Term b ->+  Term b+substTerm sym@SupportedTypedSymbol a =+  generalSubstSomeTerm+    ( \t ->+        if eqHeteroSymbol sym t+          then unsafeCoerce a+          else symTerm t+    )++supportedPrimFunUpTo+  [|buildGeneralFun (typedConstantSymbol "a") (conTerm defaultValue)|]+  [|+    \c t f -> case (t, f) of+      ( ConTerm (GeneralFun (ta :: TypedConstantSymbol a) a),+        ConTerm (GeneralFun tb b)+        ) ->+          conTerm $+            GeneralFun argSymbol $+              pevalITETerm+                c+                (substTerm ta (symTerm argSymbol) HS.empty a)+                (substTerm tb (symTerm argSymbol) HS.empty b)+          where+            argSymbol :: TypedConstantSymbol a+            argSymbol = freshArgSymbol [SomeTerm a, SomeTerm b]+      _ -> pevalITEBasicTerm c t f+    |]+  [|parseGeneralFunSMTModelResult|]+  ( \tyVars ->+      [|+        translateTypeError+          (Just "x")+          ( typeRep ::+              TypeRep+                $( foldl1 (\fty ty -> [t|$ty --> $fty|])+                     . reverse+                     $ tyVars+                 )+          )+        |]+  )+  "GeneralFun"+  "gfunc"+  ''(-->)+  8
+ src/Grisette/Internal/SymPrim/IntBitwidth.hs view
@@ -0,0 +1,17 @@+-- |+-- Module      :   Grisette.Internal.SymPrim.IntBitwidth+-- 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.SymPrim.IntBitwidth (intBitwidthQ) where++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))
+ src/Grisette/Internal/SymPrim/ModelRep.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}++-- |+-- Module      :   Grisette.Internal.SymPrim.ModelRep+-- 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.ModelRep (ModelSymPair (..)) where++import Grisette.Internal.Core.Data.Class.ModelOps+  ( ModelOps (emptyModel, insertValue),+    ModelRep (buildModel),+  )+import Grisette.Internal.SymPrim.Prim.Model (Model)+import Grisette.Internal.SymPrim.Prim.Term+  ( LinkedRep (underlyingTerm),+    pattern SymTerm,+  )++-- $setup+-- >>> import Grisette.Core+-- >>> import Grisette.SymPrim+-- >>> import Grisette.Backend+-- >>> import Data.Proxy++-- ModelRep++-- | A pair of a symbolic constant and its value.+-- This is used to build a model from a list of symbolic constants and their values.+--+-- >>> buildModel ("a" := (1 :: Integer), "b" := True) :: Model+-- Model {a -> 1 :: Integer, b -> true :: Bool}+data ModelSymPair ct st where+  (:=) :: (LinkedRep ct st) => st -> ct -> ModelSymPair ct st++instance ModelRep (ModelSymPair ct st) Model where+  buildModel (sym := val) =+    case underlyingTerm sym of+      SymTerm symbol -> insertValue symbol val emptyModel+      _ -> error "buildModel: should only use symbolic constants"
+ src/Grisette/Internal/SymPrim/Prim/Internal/Caches.hs view
@@ -0,0 +1,318 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Strict #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fno-cse #-}++-- |+-- Module      :   Grisette.Internal.SymPrim.Prim.Internal.Caches+-- 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.SymPrim.Prim.Internal.Caches+  ( SomeStableName (..),+    Id,+    StableIdent,+    Digest,+    CachedInfo (..),+    Interned (..),+    intern,+    haveCache,+    threadCacheSize,+    -- dumpThreadCache,+    threadCacheLiveSize,+  )+where++import Control.Concurrent+  ( MVar,+    ThreadId,+    myThreadId,+    newMVar,+    putMVar,+    takeMVar,+  )+import Control.Monad (replicateM)+import qualified Data.Array as A+import Data.Atomics (atomicModifyIORefCAS, atomicModifyIORefCAS_)+import Data.Data (Proxy (Proxy), Typeable, typeRepFingerprint)+import Data.Foldable (traverse_)+import qualified Data.HashMap.Strict as HM+import Data.Hashable (Hashable)+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.Maybe (isJust)+import qualified Data.Vector.Unboxed.Mutable as M+import Data.Word (Word32)+import GHC.Base (Any)+import GHC.Fingerprint (Fingerprint)+import GHC.IO (unsafePerformIO)+import GHC.StableName (makeStableName)+import GHC.Weak (Weak, deRefWeak, finalize)+import Grisette.Internal.SymPrim.Prim.Internal.Utils+  ( SomeStableName (SomeStableName),+    WeakThreadId,+    WeakThreadIdRef,+    mkWeakStableNameRefWithFinalizer,+    mkWeakThreadIdRefWithFinalizer,+    myWeakThreadId,+    weakThreadId,+  )+import System.Mem.StableName (StableName)+import Type.Reflection (someTypeRep)+import Unsafe.Coerce (unsafeCoerce)++-- | A unique identifier for a term.+type Id = Word32++-- | The identity of a term.+type StableIdent = StableName Any++-- | A digest of a term.+type Digest = Word32++-- | Information about a cached term.+data CachedInfo = CachedInfo+  { cachedThreadId :: {-# UNPACK #-} !WeakThreadId,+    cachedDigest :: {-# UNPACK #-} !Digest,+    cachedId :: {-# UNPACK #-} !Id,+    cachedStableIdent :: {-# UNPACK #-} !StableIdent+  }++data Cache t = Cache+  { getCache :: A.Array Int (CacheState t),+    idSem :: MVar (),+    nextId :: M.IOVector Id+  }++type HashTable k v = IORef (HM.HashMap k v)++data CacheState t where+  CacheState ::+    { _sem :: MVar (),+      _currentThread :: HashTable (Description t) (Id, Weak StableIdent)+    } ->+    CacheState t++finalizeCacheState :: CacheState t -> IO ()+finalizeCacheState (CacheState _ s) = do+  m <- readIORef s+  traverse_ (\(_, w) -> finalize w) m++finalizeCache :: Cache t -> IO ()+finalizeCache (Cache a _ _) = mapM_ finalizeCacheState (A.elems a)++-- | A class for interning terms.+class Interned t where+  data Description t+  type Uninterned t+  describe :: Uninterned t -> Description t+  identify :: CachedInfo -> Uninterned t -> t+  threadId :: t -> WeakThreadId+  descriptionDigest :: Description t -> Digest++{-# NOINLINE termCacheCell #-}+termCacheCell ::+  IORef+    ( HM.HashMap+        WeakThreadId+        ( WeakThreadIdRef,+          IORef (HM.HashMap Fingerprint (Cache Any))+        )+    )+termCacheCell = unsafePerformIO $ newIORef HM.empty++cacheWidth :: Word32+cacheWidth = 10+{-# INLINE cacheWidth #-}++mkCache :: forall t. (Interned t) => IO (Cache t)+mkCache = result+  where+    element =+      CacheState+        <$> newMVar ()+        <*> newIORef HM.empty+    result = do+      elements <- replicateM (fromIntegral cacheWidth) element+      idSem <- newMVar ()+      nextId <- M.replicate 1 0+      return $+        Cache (A.listArray (0, fromIntegral cacheWidth - 1) elements) idSem nextId++-- | 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) => ThreadId -> Fingerprint -> IO (Cache a)+typeMemoizedCache tid tyFingerprint = do+  caches <- readIORef termCacheCell+  let wtid = weakThreadId tid+  case HM.lookup wtid caches of+    Just (_, cref) -> do+      cache <- readIORef cref+      case HM.lookup tyFingerprint cache of+        Just d -> return $ unsafeCoerce d+        Nothing -> do+          r1 <- mkCache+          writeIORef cref $!+            HM.insert tyFingerprint (unsafeCoerce r1) cache+          return r1+    Nothing -> do+      r1 <- mkCache+      wtidRef <-+        mkWeakThreadIdRefWithFinalizer tid $ do+          finalizeCache r1+          atomicModifyIORefCAS_ termCacheCell (HM.delete wtid)+      r <- newIORef $ HM.singleton tyFingerprint (unsafeCoerce r1)+      atomicModifyIORefCAS termCacheCell $+        \m -> (HM.insert wtid (wtidRef, r) m, r1)++reclaimTerm ::+  forall t.+  (Interned t, Hashable (Description t), Eq (Description t)) =>+  WeakThreadId ->+  Fingerprint ->+  Int ->+  Description t ->+  IO ()+reclaimTerm id tyFingerprint grp dt = do+  caches <- readIORef termCacheCell+  case HM.lookup id caches of+    Just (_, cref) -> do+      cache <- readIORef cref+      case HM.lookup tyFingerprint cache of+        Just c -> do+          let Cache a _ _ = unsafeCoerce c :: Cache t+          let CacheState sem s = a A.! grp+          takeMVar sem+          current <- readIORef s+          case HM.lookup dt current of+            Nothing -> return ()+            Just (_, wr) -> do+              t <- deRefWeak wr+              case t of+                Nothing -> writeIORef s $ HM.delete dt current+                Just _ -> return ()+          putMVar sem ()+        Nothing -> return ()+    Nothing -> return ()++-- | Internalize a term.+intern ::+  forall t.+  (Interned t, Typeable t, Hashable (Description t), Eq (Description t)) =>+  Uninterned t ->+  IO t+intern !bt = do+  tid <- myThreadId+  let wtid = weakThreadId tid+  let fingerprint = typeRepFingerprint $ someTypeRep (Proxy @t)+  cache <- typeMemoizedCache tid fingerprint+  let !dt = describe bt :: Description t+      !hdt = descriptionDigest dt+      !r = hdt `mod` cacheWidth+      CacheState sem s = getCache cache A.! (fromIntegral r)+  takeMVar sem+  -- print ("intern", wtid, dt, r)+  current <- readIORef s+  case HM.lookup dt current of+    Nothing -> do+      takeMVar (idSem cache)+      newId0 <- M.unsafeRead (nextId cache) 0+      M.unsafeWrite (nextId cache) 0 (newId0 + 1)+      putMVar (idSem cache) ()+      let newId = newId0 * cacheWidth + r+      newIdent <- makeStableName dt+      let anyNewIdent = unsafeCoerce newIdent :: StableIdent+      identRef <-+        mkWeakStableNameRefWithFinalizer anyNewIdent $+          reclaimTerm wtid fingerprint (fromIntegral r) dt+      let !t = identify (CachedInfo (weakThreadId tid) hdt newId anyNewIdent) bt+      writeIORef s $ HM.insert dt (newId, identRef) current+      putMVar sem ()+      return t+    Just (oldId, oldIdentRef) -> do+      t1 <- deRefWeak oldIdentRef+      case t1 of+        Nothing -> do+          takeMVar (idSem cache)+          newId0 <- M.unsafeRead (nextId cache) 0+          M.unsafeWrite (nextId cache) 0 (newId0 + 1)+          putMVar (idSem cache) ()+          let newId = newId0 * cacheWidth + r+          newIdent <- makeStableName dt+          let anyNewIdent = unsafeCoerce newIdent :: StableIdent+          identRef <-+            mkWeakStableNameRefWithFinalizer anyNewIdent $+              reclaimTerm wtid fingerprint (fromIntegral r) dt+          let !term =+                identify+                  (CachedInfo (weakThreadId tid) hdt newId anyNewIdent)+                  bt+          writeIORef s $ HM.insert dt (newId, identRef) current+          putMVar sem ()+          return term+        Just t1 -> do+          putMVar sem ()+          return $! identify (CachedInfo (weakThreadId tid) hdt oldId t1) bt+{-# NOINLINE intern #-}++-- | Check if the current thread has a cache.+haveCache :: IO Bool+haveCache = do+  caches <- readIORef termCacheCell+  tid <- myWeakThreadId+  return $ HM.member tid caches++cacheStateSize :: CacheState t -> IO Int+cacheStateSize (CacheState _ s) = HM.size <$> readIORef s++cacheStateLiveSize :: CacheState t -> IO Int+cacheStateLiveSize (CacheState sem s) = do+  takeMVar sem+  v <- fmap snd . HM.toList <$> readIORef s+  r <-+    sum+      <$> mapM+        ( \(_, x) -> do+            x <- deRefWeak x+            if isJust x then return 1 else return 0+        )+        v+  putMVar sem ()+  return r++cacheSize :: Cache t -> IO Int+cacheSize (Cache a _ _) = sum <$> mapM cacheStateSize (A.elems a)++cacheLiveSize :: Cache t -> IO Int+cacheLiveSize (Cache a _ _) = sum <$> mapM cacheStateLiveSize (A.elems a)++-- | Get the size of the current thread's cache.+threadCacheSize :: WeakThreadId -> IO Int+threadCacheSize tid = do+  caches <- readIORef termCacheCell+  case HM.lookup tid caches of+    Just (_, cref) -> do+      cache <- readIORef cref+      sum <$> mapM cacheSize (HM.elems cache)+    Nothing -> return 0++-- | Get the live size of the current thread's cache.+threadCacheLiveSize :: WeakThreadId -> IO Int+threadCacheLiveSize tid = do+  caches <- readIORef termCacheCell+  case HM.lookup tid caches of+    Just (_, cref) -> do+      cache <- readIORef cref+      sum <$> mapM cacheLiveSize (HM.elems cache)+    Nothing -> return 0
+ src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalBitCastTerm.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalBitCastTerm+-- 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.Prim.Internal.Instances.PEvalBitCastTerm+  ( doPevalBitCast,+  )+where++import qualified Data.SBV as SBV+import GHC.TypeLits (KnownNat, type (+), type (<=))+import Grisette.Internal.Core.Data.Class.BitCast+  ( BitCast (bitCast),+    BitCastOr (bitCastOr),+  )+import Grisette.Internal.SymPrim.BV (IntN, WordN)+import Grisette.Internal.SymPrim.FP (FP, ValidFP, withValidFPProofs)+import Grisette.Internal.SymPrim.Prim.Internal.Term+  ( PEvalBitCastOrTerm (pevalBitCastOrTerm, sbvBitCastOr),+    PEvalBitCastTerm (pevalBitCastTerm, sbvBitCast),+    SupportedPrim,+    Term,+    bitCastOrTerm,+    bitCastTerm,+    conTerm,+    pattern BitCastTerm,+    pattern ConTerm,+    pattern DynTerm,+    pattern SupportedTerm,+  )+import Grisette.Internal.SymPrim.Prim.Internal.Unfold+  ( binaryUnfoldOnce,+    unaryUnfoldOnce,+  )++doPevalBitCastSameType ::+  forall x b. (SupportedPrim b) => Term x -> Maybe (Term b)+doPevalBitCastSameType (BitCastTerm (DynTerm (b :: Term b))) = Just b+doPevalBitCastSameType (BitCastTerm x) = doPevalBitCastSameType x+doPevalBitCastSameType _ = Nothing++-- | Partially evaluate a bitcast term. If no reduction is performed, return+-- Nothing.+doPevalBitCast :: (PEvalBitCastTerm a b, SupportedPrim b) => Term a -> Maybe (Term b)+doPevalBitCast (ConTerm v) = Just $ conTerm $ bitCast v+doPevalBitCast t = doPevalBitCastSameType t++pevalBitCastGeneral ::+  forall a b.+  (PEvalBitCastTerm a b, SupportedPrim b) =>+  Term a ->+  Term b+pevalBitCastGeneral = unaryUnfoldOnce doPevalBitCast bitCastTerm++doPevalBitCastOr ::+  (PEvalBitCastOrTerm a b) =>+  Term b ->+  Term a ->+  Maybe (Term b)+doPevalBitCastOr (ConTerm d) (ConTerm v) =+  Just $ conTerm $ bitCastOr d v+doPevalBitCastOr _ _ = Nothing++pevalBitCastOr ::+  forall a b.+  (PEvalBitCastOrTerm a b) =>+  Term b ->+  Term a ->+  Term b+pevalBitCastOr d@SupportedTerm =+  binaryUnfoldOnce doPevalBitCastOr bitCastOrTerm d++instance PEvalBitCastTerm Bool (IntN 1) where+  pevalBitCastTerm = pevalBitCastGeneral+  sbvBitCast x = SBV.ite x (SBV.literal 1) (SBV.literal 0)++instance PEvalBitCastTerm Bool (WordN 1) where+  pevalBitCastTerm = pevalBitCastGeneral+  sbvBitCast x = SBV.ite x (SBV.literal 1) (SBV.literal 0)++instance PEvalBitCastTerm (IntN 1) Bool where+  pevalBitCastTerm = pevalBitCastGeneral+  sbvBitCast x = SBV.sTestBit x 0++instance PEvalBitCastTerm (WordN 1) Bool where+  pevalBitCastTerm = pevalBitCastGeneral+  sbvBitCast x = SBV.sTestBit x 0++instance+  (n ~ (eb + sb), ValidFP eb sb, KnownNat n, 1 <= n) =>+  PEvalBitCastTerm (WordN n) (FP eb sb)+  where+  pevalBitCastTerm = pevalBitCastGeneral+  sbvBitCast = withValidFPProofs @eb @sb $ SBV.sWordAsSFloatingPoint++instance+  (n ~ (eb + sb), ValidFP eb sb, KnownNat n, 1 <= n) =>+  PEvalBitCastTerm (IntN n) (FP eb sb)+  where+  pevalBitCastTerm = pevalBitCastGeneral+  sbvBitCast =+    withValidFPProofs @eb @sb $ SBV.sWordAsSFloatingPoint . SBV.sFromIntegral++instance+  (n ~ (eb + sb), ValidFP eb sb, KnownNat n, 1 <= n) =>+  PEvalBitCastOrTerm (FP eb sb) (WordN n)+  where+  pevalBitCastOrTerm = pevalBitCastOr+  sbvBitCastOr d v =+    withValidFPProofs @eb @sb $+      SBV.ite+        (SBV.fpIsNaN v)+        d+        (SBV.sFloatingPointAsSWord v)++instance+  (n ~ (eb + sb), ValidFP eb sb, KnownNat n, 1 <= n) =>+  PEvalBitCastOrTerm (FP eb sb) (IntN n)+  where+  pevalBitCastOrTerm = pevalBitCastOr+  sbvBitCastOr d v =+    withValidFPProofs @eb @sb $+      SBV.ite+        (SBV.fpIsNaN v)+        d+        (SBV.sFromIntegral $ SBV.sFloatingPointAsSWord v)
+ src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalDivModIntegralTerm.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# HLINT ignore "Eta reduce" #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++-- |+-- Module      :   Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalDivModIntegralTerm+-- 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.Prim.Internal.Instances.PEvalDivModIntegralTerm+  ( pevalDefaultDivIntegralTerm,+    pevalDefaultDivBoundedIntegralTerm,+    pevalDefaultModIntegralTerm,+    pevalDefaultQuotIntegralTerm,+    pevalDefaultQuotBoundedIntegralTerm,+    pevalDefaultRemIntegralTerm,+  )+where++import GHC.TypeNats (KnownNat, type (<=))+import Grisette.Internal.SymPrim.BV (IntN, WordN)+import Grisette.Internal.SymPrim.Prim.Internal.Term+  ( PEvalDivModIntegralTerm+      ( pevalDivIntegralTerm,+        pevalModIntegralTerm,+        pevalQuotIntegralTerm,+        pevalRemIntegralTerm,+        withSbvDivModIntegralTermConstraint+      ),+    SupportedPrim (withPrim),+    Term,+    conTerm,+    divIntegralTerm,+    modIntegralTerm,+    quotIntegralTerm,+    remIntegralTerm,+    pattern ConTerm,+    pattern SupportedTerm,+  )+import Grisette.Internal.SymPrim.Prim.Internal.Unfold (binaryUnfoldOnce)++-- | Default partial evaluation of division operation for integral types.+pevalDefaultDivIntegralTerm ::+  (PEvalDivModIntegralTerm a, Integral a) => Term a -> Term a -> Term a+pevalDefaultDivIntegralTerm l@SupportedTerm r =+  binaryUnfoldOnce doPevalDefaultDivIntegralTerm divIntegralTerm l r++doPevalDefaultDivIntegralTerm ::+  (PEvalDivModIntegralTerm a, Integral a) => Term a -> Term a -> Maybe (Term a)+doPevalDefaultDivIntegralTerm (ConTerm a) (ConTerm b)+  | b /= 0 = Just $ conTerm $ a `div` b+doPevalDefaultDivIntegralTerm a (ConTerm 1) = Just a+doPevalDefaultDivIntegralTerm _ _ = Nothing++-- | Default partial evaluation of division operation for bounded integral+-- types.+pevalDefaultDivBoundedIntegralTerm ::+  (PEvalDivModIntegralTerm a, Bounded a, Integral a) =>+  Term a ->+  Term a ->+  Term a+pevalDefaultDivBoundedIntegralTerm l@SupportedTerm r =+  binaryUnfoldOnce doPevalDefaultDivBoundedIntegralTerm divIntegralTerm l r++doPevalDefaultDivBoundedIntegralTerm ::+  (PEvalDivModIntegralTerm a, Bounded a, Integral a) =>+  Term a ->+  Term a ->+  Maybe (Term a)+doPevalDefaultDivBoundedIntegralTerm (ConTerm a) (ConTerm b)+  | b /= 0 && (b /= -1 || a /= minBound) = Just $ conTerm $ a `div` b+doPevalDefaultDivBoundedIntegralTerm a (ConTerm 1) = Just a+doPevalDefaultDivBoundedIntegralTerm _ _ = Nothing++-- | Default partial evaluation of modulo operation for integral types.+pevalDefaultModIntegralTerm ::+  (PEvalDivModIntegralTerm a, Integral a) => Term a -> Term a -> Term a+pevalDefaultModIntegralTerm l@SupportedTerm r =+  binaryUnfoldOnce doPevalDefaultModIntegralTerm modIntegralTerm l r++doPevalDefaultModIntegralTerm ::+  (PEvalDivModIntegralTerm a, Integral a) => Term a -> Term a -> Maybe (Term a)+doPevalDefaultModIntegralTerm (ConTerm a) (ConTerm b)+  | b /= 0 = Just $ conTerm $ a `mod` b+doPevalDefaultModIntegralTerm _ (ConTerm 1) = Just $ conTerm 0+doPevalDefaultModIntegralTerm _ (ConTerm (-1)) = Just $ conTerm 0+doPevalDefaultModIntegralTerm _ _ = Nothing++-- | Default partial evaluation of quotient operation for integral types.+pevalDefaultQuotIntegralTerm ::+  (PEvalDivModIntegralTerm a, Integral a) => Term a -> Term a -> Term a+pevalDefaultQuotIntegralTerm l@SupportedTerm r =+  binaryUnfoldOnce doPevalDefaultQuotIntegralTerm quotIntegralTerm l r++doPevalDefaultQuotIntegralTerm ::+  (PEvalDivModIntegralTerm a, Integral a) => Term a -> Term a -> Maybe (Term a)+doPevalDefaultQuotIntegralTerm (ConTerm a) (ConTerm b)+  | b /= 0 = Just $ conTerm $ a `quot` b+doPevalDefaultQuotIntegralTerm a (ConTerm 1) = Just a+doPevalDefaultQuotIntegralTerm _ _ = Nothing++-- | Default partial evaluation of quotient operation for bounded integral+-- types.+pevalDefaultQuotBoundedIntegralTerm ::+  (PEvalDivModIntegralTerm a, Bounded a, Integral a) =>+  Term a ->+  Term a ->+  Term a+pevalDefaultQuotBoundedIntegralTerm l@SupportedTerm r =+  binaryUnfoldOnce doPevalDefaultQuotBoundedIntegralTerm quotIntegralTerm l r++doPevalDefaultQuotBoundedIntegralTerm ::+  (PEvalDivModIntegralTerm a, Bounded a, Integral a) =>+  Term a ->+  Term a ->+  Maybe (Term a)+doPevalDefaultQuotBoundedIntegralTerm (ConTerm a) (ConTerm b)+  | b /= 0 && (b /= -1 || a /= minBound) = Just $ conTerm $ a `quot` b+doPevalDefaultQuotBoundedIntegralTerm a (ConTerm 1) = Just a+doPevalDefaultQuotBoundedIntegralTerm _ _ = Nothing++-- | Default partial evaluation of remainder operation for integral types.+pevalDefaultRemIntegralTerm ::+  (PEvalDivModIntegralTerm a, Integral a) => Term a -> Term a -> Term a+pevalDefaultRemIntegralTerm l@SupportedTerm r =+  binaryUnfoldOnce doPevalDefaultRemIntegralTerm remIntegralTerm l r++doPevalDefaultRemIntegralTerm ::+  (PEvalDivModIntegralTerm a, Integral a) => Term a -> Term a -> Maybe (Term a)+doPevalDefaultRemIntegralTerm (ConTerm a) (ConTerm b)+  | b /= 0 = Just $ conTerm $ a `rem` b+doPevalDefaultRemIntegralTerm _ (ConTerm 1) = Just $ conTerm 0+doPevalDefaultRemIntegralTerm _ (ConTerm (-1)) = Just $ conTerm 0+doPevalDefaultRemIntegralTerm _ _ = Nothing++instance PEvalDivModIntegralTerm Integer where+  pevalDivIntegralTerm = pevalDefaultDivIntegralTerm+  pevalModIntegralTerm = pevalDefaultModIntegralTerm+  pevalQuotIntegralTerm = pevalDefaultQuotIntegralTerm+  pevalRemIntegralTerm = pevalDefaultRemIntegralTerm+  withSbvDivModIntegralTermConstraint r = r++instance (KnownNat n, 1 <= n) => PEvalDivModIntegralTerm (IntN n) where+  pevalDivIntegralTerm = pevalDefaultDivBoundedIntegralTerm+  pevalModIntegralTerm = pevalDefaultModIntegralTerm+  pevalQuotIntegralTerm = pevalDefaultQuotBoundedIntegralTerm+  pevalRemIntegralTerm = pevalDefaultRemIntegralTerm+  withSbvDivModIntegralTermConstraint r = withPrim @(IntN n) r++instance (KnownNat n, 1 <= n) => PEvalDivModIntegralTerm (WordN n) where+  pevalDivIntegralTerm = pevalDefaultDivIntegralTerm+  pevalModIntegralTerm = pevalDefaultModIntegralTerm+  pevalQuotIntegralTerm = pevalDefaultQuotIntegralTerm+  pevalRemIntegralTerm = pevalDefaultRemIntegralTerm+  withSbvDivModIntegralTermConstraint r = withPrim @(WordN n) r
+ src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalFP.hs view
@@ -0,0 +1,207 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PatternSynonyms #-}++-- |+-- Module      :   Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalFP+-- 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.Prim.Internal.Instances.PEvalFP () where++import qualified Data.SBV as SBV+import Grisette.Internal.Core.Data.Class.IEEEFP+  ( IEEEFPOp+      ( fpMaximum,+        fpMaximumNumber,+        fpMinimum,+        fpMinimumNumber,+        fpRem+      ),+    IEEEFPRoundingOp+      ( fpAdd,+        fpDiv,+        fpFMA,+        fpMul,+        fpRoundToIntegral,+        fpSqrt,+        fpSub+      ),+  )+import Grisette.Internal.SymPrim.FP (FP, ValidFP)+import Grisette.Internal.SymPrim.Prim.Internal.Term+  ( FPBinaryOp (FPMaximum, FPMaximumNumber, FPMinimum, FPMinimumNumber, FPRem),+    FPRoundingBinaryOp (FPAdd, FPDiv, FPMul, FPSub),+    FPRoundingUnaryOp (FPRoundToIntegral, FPSqrt),+    FPTrait+      ( FPIsInfinite,+        FPIsNaN,+        FPIsNegative,+        FPIsNegativeInfinite,+        FPIsNegativeZero,+        FPIsNormal,+        FPIsPoint,+        FPIsPositive,+        FPIsPositiveInfinite,+        FPIsPositiveZero,+        FPIsSubnormal,+        FPIsZero+      ),+    FPUnaryOp (FPAbs, FPNeg),+    PEvalFPTerm+      ( pevalFPBinaryTerm,+        pevalFPFMATerm,+        pevalFPRoundingBinaryTerm,+        pevalFPRoundingUnaryTerm,+        pevalFPTraitTerm,+        pevalFPUnaryTerm,+        sbvFPBinaryTerm,+        sbvFPFMATerm,+        sbvFPRoundingBinaryTerm,+        sbvFPRoundingUnaryTerm,+        sbvFPTraitTerm,+        sbvFPUnaryTerm+      ),+    conTerm,+    fpBinaryTerm,+    fpFMATerm,+    fpRoundingBinaryTerm,+    fpRoundingUnaryTerm,+    fpTraitTerm,+    fpUnaryTerm,+    pattern ConTerm,+  )+import Grisette.Internal.SymPrim.Prim.Internal.Unfold (unaryUnfoldOnce)++instance PEvalFPTerm FP where+  pevalFPTraitTerm trait =+    unaryUnfoldOnce doPevalFPTraitTerm (fpTraitTerm trait)+    where+      doPevalFPTraitTerm (ConTerm a) = case trait of+        FPIsNaN -> Just $ conTerm $ isNaN a+        FPIsPositive ->+          Just $+            conTerm $+              not (isNaN a) && a >= 0 && not (isNegativeZero a)+        FPIsNegative ->+          Just $ conTerm $ not (isNaN a) && (a < 0 || isNegativeZero a)+        FPIsInfinite -> Just $ conTerm $ isInfinite a+        FPIsPositiveInfinite -> Just $ conTerm $ isInfinite a && a > 0+        FPIsNegativeInfinite -> Just $ conTerm $ isInfinite a && a < 0+        FPIsPositiveZero ->+          Just $ conTerm $ a == 0 && not (isNegativeZero a)+        FPIsNegativeZero -> Just $ conTerm $ isNegativeZero a+        FPIsZero -> Just $ conTerm $ a == 0+        FPIsNormal ->+          Just $+            conTerm $+              not (a == 0 || isNaN a || isInfinite a || isDenormalized a)+        FPIsSubnormal -> Just $ conTerm $ isDenormalized a+        FPIsPoint -> Just $ conTerm $ not (isNaN a || isInfinite a)+      doPevalFPTraitTerm _ = Nothing+  pevalFPUnaryTerm = fpUnaryTerm+  {-# INLINE pevalFPUnaryTerm #-}+  pevalFPBinaryTerm bop (ConTerm l) (ConTerm r) =+    case bop of+      FPMaximum -> conTerm $ fpMaximum l r+      FPMaximumNumber -> conTerm $ fpMaximumNumber l r+      FPMinimum -> conTerm $ fpMinimum l r+      FPMinimumNumber -> conTerm $ fpMinimumNumber l r+      FPRem -> conTerm $ fpRem l r+  pevalFPBinaryTerm FPMaximum l r | l == r = l+  pevalFPBinaryTerm FPMaximumNumber l r | l == r = l+  pevalFPBinaryTerm FPMinimum l r | l == r = l+  pevalFPBinaryTerm FPMinimumNumber l r | l == r = l+  pevalFPBinaryTerm bop l r = fpBinaryTerm bop l r+  {-# INLINE pevalFPBinaryTerm #-}+  pevalFPRoundingUnaryTerm uop (ConTerm rd) (ConTerm l) =+    case uop of+      FPSqrt -> conTerm $ fpSqrt rd l+      FPRoundToIntegral -> conTerm $ fpRoundToIntegral rd l+  pevalFPRoundingUnaryTerm uop rd l = fpRoundingUnaryTerm uop rd l+  {-# INLINE pevalFPRoundingUnaryTerm #-}+  pevalFPRoundingBinaryTerm bop (ConTerm rd) (ConTerm l) (ConTerm r) =+    case bop of+      FPAdd -> conTerm $ fpAdd rd l r+      FPSub -> conTerm $ fpSub rd l r+      FPMul -> conTerm $ fpMul rd l r+      FPDiv -> conTerm $ fpDiv rd l r+  pevalFPRoundingBinaryTerm bop rd l r = fpRoundingBinaryTerm bop rd l r+  {-# INLINE pevalFPRoundingBinaryTerm #-}+  pevalFPFMATerm (ConTerm rd) (ConTerm x) (ConTerm y) (ConTerm z) =+    conTerm $ fpFMA rd x y z+  pevalFPFMATerm rd x y z = fpFMATerm rd x y z+  {-# INLINE pevalFPFMATerm #-}++  sbvFPTraitTerm FPIsNaN = SBV.fpIsNaN+  sbvFPTraitTerm FPIsPositive = goodFpIsPositive+  sbvFPTraitTerm FPIsNegative = goodFpIsNegative+  sbvFPTraitTerm FPIsInfinite = SBV.fpIsInfinite+  sbvFPTraitTerm FPIsPositiveInfinite = \f ->+    SBV.fpIsInfinite f SBV..&& goodFpIsPositive f+  sbvFPTraitTerm FPIsNegativeInfinite = \f ->+    SBV.fpIsInfinite f SBV..&& goodFpIsNegative f+  sbvFPTraitTerm FPIsPositiveZero =+    \f -> SBV.fpIsZero f SBV..&& goodFpIsPositive f+  sbvFPTraitTerm FPIsNegativeZero =+    \f -> SBV.fpIsZero f SBV..&& goodFpIsNegative f+  sbvFPTraitTerm FPIsZero = SBV.fpIsZero+  sbvFPTraitTerm FPIsNormal = SBV.fpIsNormal+  sbvFPTraitTerm FPIsSubnormal = SBV.fpIsSubnormal+  sbvFPTraitTerm FPIsPoint = SBV.fpIsPoint++  sbvFPUnaryTerm FPAbs = SBV.fpAbs+  sbvFPUnaryTerm FPNeg = SBV.fpNeg+  {-# INLINE sbvFPUnaryTerm #-}++  sbvFPBinaryTerm FPRem x y = SBV.fpRem x y+  sbvFPBinaryTerm FPMinimum x y =+    SBV.ite (SBV.fpIsNaN x SBV..|| SBV.fpIsNaN y) SBV.nan $+      SBV.ite (sbvCmpHandleNegZero x y) x y+  sbvFPBinaryTerm FPMinimumNumber x y =+    SBV.ite (SBV.fpIsNaN x) y $+      SBV.ite (SBV.fpIsNaN y) x $+        SBV.ite (sbvCmpHandleNegZero x y) x y+  sbvFPBinaryTerm FPMaximum x y =+    SBV.ite (SBV.fpIsNaN x SBV..|| SBV.fpIsNaN y) SBV.nan $+      SBV.ite (sbvCmpHandleNegZero x y) y x+  sbvFPBinaryTerm FPMaximumNumber x y =+    SBV.ite (SBV.fpIsNaN x) y $+      SBV.ite (SBV.fpIsNaN y) x $+        SBV.ite (sbvCmpHandleNegZero x y) y x+  {-# INLINE sbvFPBinaryTerm #-}++  sbvFPRoundingUnaryTerm FPSqrt = SBV.fpSqrt+  sbvFPRoundingUnaryTerm FPRoundToIntegral = SBV.fpRoundToIntegral+  {-# INLINE sbvFPRoundingUnaryTerm #-}++  sbvFPRoundingBinaryTerm FPAdd = SBV.fpAdd+  sbvFPRoundingBinaryTerm FPSub = SBV.fpSub+  sbvFPRoundingBinaryTerm FPMul = SBV.fpMul+  sbvFPRoundingBinaryTerm FPDiv = SBV.fpDiv+  {-# INLINE sbvFPRoundingBinaryTerm #-}++  sbvFPFMATerm = SBV.fpFMA+  {-# INLINE sbvFPFMATerm #-}++goodFpIsPositive :: (ValidFP eb sb) => SBV.SFloatingPoint eb sb -> SBV.SBool+goodFpIsPositive x = SBV.sNot (SBV.fpIsNaN x) SBV..&& SBV.fpIsPositive x+{-# INLINE goodFpIsPositive #-}++goodFpIsNegative :: (ValidFP eb sb) => SBV.SFloatingPoint eb sb -> SBV.SBool+goodFpIsNegative x = SBV.sNot (SBV.fpIsNaN x) SBV..&& SBV.fpIsNegative x+{-# INLINE goodFpIsNegative #-}++sbvCmpHandleNegZero ::+  (ValidFP eb sb) =>+  SBV.SFloatingPoint eb sb ->+  SBV.SFloatingPoint eb sb ->+  SBV.SBool+sbvCmpHandleNegZero x y =+  SBV.ite+    (SBV.fpIsZero x SBV..&& SBV.fpIsZero y)+    (SBV.fpIsNegativeZero x)+    (x SBV..< y)+{-# INLINE sbvCmpHandleNegZero #-}
+ src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalFloatingTerm.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# HLINT ignore "Eta reduce" #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++-- |+-- Module      :   Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalFloatingTerm+-- 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.Prim.Internal.Instances.PEvalFloatingTerm () where++import Grisette.Internal.SymPrim.AlgReal (AlgReal)+import Grisette.Internal.SymPrim.FP (FP, ValidFP)+import Grisette.Internal.SymPrim.Prim.Internal.Term+  ( FloatingUnaryOp (FloatingAcosh, FloatingAsinh, FloatingAtanh, FloatingSqrt),+    PEvalFloatingTerm+      ( pevalFloatingUnaryTerm,+        pevalPowerTerm,+        withSbvFloatingTermConstraint+      ),+    SupportedPrim (withPrim),+    floatingUnaryTerm,+    powerTerm,+  )+import Grisette.Internal.SymPrim.Prim.Internal.Unfold+  ( generalUnaryUnfolded,+  )++instance (ValidFP eb sb) => PEvalFloatingTerm (FP eb sb) where+  pevalFloatingUnaryTerm op =+    case op of+      FloatingSqrt -> generalUnaryUnfolded sqrt $ floatingUnaryTerm op+      _ -> error $ "operation " <> show op <> " not supported for FP"+  pevalPowerTerm = error "power operation not supported for FP"+  withSbvFloatingTermConstraint r = withPrim @(FP eb sb) r++instance PEvalFloatingTerm AlgReal where+  pevalFloatingUnaryTerm op =+    case op of+      FloatingAsinh ->+        error "operation asinh not supported by sbv for AlgReal"+      FloatingAcosh ->+        error "operation acosh not supported by sbv for AlgReal"+      FloatingAtanh ->+        error "operation atanh not supported by sbv for AlgReal"+      _ -> floatingUnaryTerm op+  pevalPowerTerm = powerTerm+  withSbvFloatingTermConstraint r = withPrim @AlgReal r
+ src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalFractionalTerm.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Eta reduce" #-}++-- |+-- Module      :   Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalFractionalTerm+-- 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.Prim.Internal.Instances.PEvalFractionalTerm () where++import Grisette.Internal.SymPrim.AlgReal (AlgReal)+import Grisette.Internal.SymPrim.FP (FP, ValidFP)+import Grisette.Internal.SymPrim.Prim.Internal.Term+  ( PEvalFractionalTerm+      ( pevalFdivTerm,+        pevalRecipTerm,+        withSbvFractionalTermConstraint+      ),+    SupportedPrim (withPrim),+    Term,+    conTerm,+    fdivTerm,+    recipTerm,+    pattern ConTerm,+    pattern SupportedTerm,+  )+import Grisette.Internal.SymPrim.Prim.Internal.Unfold+  ( binaryUnfoldOnce,+    generalBinaryUnfolded,+    generalUnaryUnfolded,+    unaryUnfoldOnce,+  )++instance (ValidFP eb sb) => PEvalFractionalTerm (FP eb sb) where+  pevalFdivTerm = generalBinaryUnfolded (/) fdivTerm+  pevalRecipTerm = generalUnaryUnfolded recip recipTerm+  withSbvFractionalTermConstraint r = withPrim @(FP eb sb) r++pevalDefaultFdivTerm ::+  (PEvalFractionalTerm a, Eq a) => Term a -> Term a -> Term a+pevalDefaultFdivTerm l@SupportedTerm r =+  binaryUnfoldOnce doPevalDefaultFdivTerm fdivTerm l r++doPevalDefaultFdivTerm ::+  (PEvalFractionalTerm a, Eq a) => Term a -> Term a -> Maybe (Term a)+doPevalDefaultFdivTerm (ConTerm a) (ConTerm b)+  | b /= 0 = Just $ conTerm $ a / b+doPevalDefaultFdivTerm a (ConTerm 1) = Just a+doPevalDefaultFdivTerm _ _ = Nothing++pevalDefaultRecipTerm ::+  (PEvalFractionalTerm a, Eq a) => Term a -> Term a+pevalDefaultRecipTerm l@SupportedTerm =+  unaryUnfoldOnce doPevalDefaultRecipTerm recipTerm l++doPevalDefaultRecipTerm ::+  (PEvalFractionalTerm a, Eq a) => Term a -> Maybe (Term a)+doPevalDefaultRecipTerm (ConTerm n) | n /= 0 = Just $ conTerm $ recip n+doPevalDefaultRecipTerm _ = Nothing++instance PEvalFractionalTerm AlgReal where+  pevalFdivTerm = pevalDefaultFdivTerm+  pevalRecipTerm = pevalDefaultRecipTerm+  withSbvFractionalTermConstraint r = withPrim @AlgReal r
+ src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalFromIntegralTerm.hs view
@@ -0,0 +1,182 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalFromIntegralTerm+-- 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.Prim.Internal.Instances.PEvalFromIntegralTerm () where++import Data.Proxy (Proxy (Proxy))+import qualified Data.SBV as SBV+import qualified Data.SBV.Internals as SBVI+import GHC.TypeLits (KnownNat, type (<=))+import Grisette.Internal.SymPrim.AlgReal (AlgReal)+import Grisette.Internal.SymPrim.BV (IntN, WordN)+import Grisette.Internal.SymPrim.FP (FP, ValidFP)+import Grisette.Internal.SymPrim.Prim.Internal.Term+  ( PEvalFromIntegralTerm (pevalFromIntegralTerm, sbvFromIntegralTerm),+    SupportedNonFuncPrim (withNonFuncPrim),+    SupportedPrim,+    Term,+    bvIsNonZeroFromGEq1,+    conTerm,+    fromIntegralTerm,+    pattern ConTerm,+  )+import Grisette.Internal.SymPrim.Prim.Internal.Unfold (unaryUnfoldOnce)++pevalFromIntegralTermGeneric ::+  (PEvalFromIntegralTerm a b, SupportedPrim b) => Term a -> Term b+pevalFromIntegralTermGeneric =+  unaryUnfoldOnce doPEvalFromIntegralTerm fromIntegralTerm+  where+    doPEvalFromIntegralTerm (ConTerm a) = Just $ conTerm $ fromIntegral a+    doPEvalFromIntegralTerm _ = Nothing++instance PEvalFromIntegralTerm Integer Integer where+  pevalFromIntegralTerm = id+  sbvFromIntegralTerm = id++instance PEvalFromIntegralTerm Integer AlgReal where+  pevalFromIntegralTerm = pevalFromIntegralTermGeneric+  sbvFromIntegralTerm l = withNonFuncPrim @Integer $ SBV.sFromIntegral l++instance (KnownNat n, 1 <= n) => PEvalFromIntegralTerm Integer (WordN n) where+  pevalFromIntegralTerm = pevalFromIntegralTermGeneric+  sbvFromIntegralTerm l =+    bvIsNonZeroFromGEq1 (Proxy @n) $+      withNonFuncPrim @Integer $+        SBV.sFromIntegral l++instance (KnownNat n, 1 <= n) => PEvalFromIntegralTerm Integer (IntN n) where+  pevalFromIntegralTerm = pevalFromIntegralTermGeneric+  sbvFromIntegralTerm l =+    bvIsNonZeroFromGEq1 (Proxy @n) $+      withNonFuncPrim @Integer $+        SBV.sFromIntegral l++genericFPCast ::+  forall a r.+  (SBV.HasKind a, SBV.HasKind r) =>+  SBV.SRoundingMode ->+  SBV.SBV a ->+  SBV.SBV r+genericFPCast rm f = SBVI.SBV (SBVI.SVal kTo (Right (SBVI.cache r)))+  where+    kFrom = SBVI.kindOf f+    kTo = SBVI.kindOf (Proxy @r)+    r st = do+      msv <- SBVI.sbvToSV st rm+      xsv <- SBVI.sbvToSV st f+      SBVI.newExpr st kTo $+        SBVI.SBVApp+          (SBVI.IEEEFP (SBVI.FP_Cast kFrom kTo msv))+          [xsv]++instance (ValidFP eb sb) => PEvalFromIntegralTerm Integer (FP eb sb) where+  pevalFromIntegralTerm = pevalFromIntegralTermGeneric+  sbvFromIntegralTerm l =+    withNonFuncPrim @Integer $+      SBV.toSFloatingPoint SBV.sRoundNearestTiesToEven l++instance (KnownNat n, 1 <= n) => PEvalFromIntegralTerm (WordN n) Integer where+  pevalFromIntegralTerm = pevalFromIntegralTermGeneric+  sbvFromIntegralTerm l =+    bvIsNonZeroFromGEq1 (Proxy @n) $+      withNonFuncPrim @Integer $+        SBV.sFromIntegral l++instance+  (KnownNat n, 1 <= n, KnownNat m, 1 <= m) =>+  PEvalFromIntegralTerm (WordN n) (WordN m)+  where+  pevalFromIntegralTerm = pevalFromIntegralTermGeneric+  sbvFromIntegralTerm l =+    bvIsNonZeroFromGEq1 (Proxy @n) $+      bvIsNonZeroFromGEq1 (Proxy @m) $+        withNonFuncPrim @Integer $+          SBV.sFromIntegral l++instance+  (KnownNat n, 1 <= n, KnownNat m, 1 <= m) =>+  PEvalFromIntegralTerm (WordN n) (IntN m)+  where+  pevalFromIntegralTerm = pevalFromIntegralTermGeneric+  sbvFromIntegralTerm l =+    bvIsNonZeroFromGEq1 (Proxy @n) $+      bvIsNonZeroFromGEq1 (Proxy @m) $+        withNonFuncPrim @Integer $+          SBV.sFromIntegral l++instance (KnownNat n, 1 <= n) => PEvalFromIntegralTerm (WordN n) AlgReal where+  pevalFromIntegralTerm = pevalFromIntegralTermGeneric+  sbvFromIntegralTerm l =+    bvIsNonZeroFromGEq1+      (Proxy @n)+      (SBV.sFromIntegral (SBV.sFromIntegral l :: SBV.SInteger))++instance+  (KnownNat n, 1 <= n, ValidFP eb sb) =>+  PEvalFromIntegralTerm (WordN n) (FP eb sb)+  where+  pevalFromIntegralTerm = pevalFromIntegralTermGeneric+  sbvFromIntegralTerm l =+    bvIsNonZeroFromGEq1 (Proxy @n) $+      genericFPCast SBV.sRoundNearestTiesToEven l++instance (KnownNat n, 1 <= n) => PEvalFromIntegralTerm (IntN n) Integer where+  pevalFromIntegralTerm = pevalFromIntegralTermGeneric+  sbvFromIntegralTerm l =+    bvIsNonZeroFromGEq1 (Proxy @n) $+      withNonFuncPrim @Integer $+        SBV.sFromIntegral l++instance+  (KnownNat n, 1 <= n, KnownNat m, 1 <= m) =>+  PEvalFromIntegralTerm (IntN n) (WordN m)+  where+  pevalFromIntegralTerm = pevalFromIntegralTermGeneric+  sbvFromIntegralTerm l =+    bvIsNonZeroFromGEq1 (Proxy @n) $+      bvIsNonZeroFromGEq1 (Proxy @m) $+        withNonFuncPrim @Integer $+          SBV.sFromIntegral l++instance+  (KnownNat n, 1 <= n, KnownNat m, 1 <= m) =>+  PEvalFromIntegralTerm (IntN n) (IntN m)+  where+  pevalFromIntegralTerm = pevalFromIntegralTermGeneric+  sbvFromIntegralTerm l =+    bvIsNonZeroFromGEq1 (Proxy @n) $+      bvIsNonZeroFromGEq1 (Proxy @m) $+        withNonFuncPrim @Integer $+          SBV.sFromIntegral l++instance (KnownNat n, 1 <= n) => PEvalFromIntegralTerm (IntN n) AlgReal where+  pevalFromIntegralTerm = pevalFromIntegralTermGeneric+  sbvFromIntegralTerm l =+    bvIsNonZeroFromGEq1+      (Proxy @n)+      (SBV.sFromIntegral (SBV.sFromIntegral l :: SBV.SInteger))++instance+  (KnownNat n, 1 <= n, ValidFP eb sb) =>+  PEvalFromIntegralTerm (IntN n) (FP eb sb)+  where+  pevalFromIntegralTerm = pevalFromIntegralTermGeneric+  sbvFromIntegralTerm l =+    bvIsNonZeroFromGEq1 (Proxy @n) $+      genericFPCast SBV.sRoundNearestTiesToEven l
+ src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalIEEEFPConvertibleTerm.hs view
@@ -0,0 +1,305 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalIEEEFPConvertibleTerm+-- 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.Prim.Internal.Instances.PEvalIEEEFPConvertibleTerm+  ( genericFPCast,+  )+where++import Data.Proxy (Proxy (Proxy))+import qualified Data.SBV as SBV+import qualified Data.SBV.Internals as SBVI+import GHC.TypeLits (KnownNat, Nat, type (<=))+import Grisette.Internal.Core.Data.Class.IEEEFP+  ( IEEEFPConstants+      ( fpNaN,+        fpNegativeInfinite,+        fpNegativeZero,+        fpPositiveInfinite,+        fpPositiveZero+      ),+    IEEEFPConvertible (fromFPOr, toFP),+    fpIsInfinite,+    fpIsNaN,+    fpIsNegativeInfinite,+    fpIsNegativeZero,+    fpIsPositiveInfinite,+    fpIsPositiveZero,+  )+import Grisette.Internal.SymPrim.AlgReal (AlgReal)+import Grisette.Internal.SymPrim.BV (IntN, WordN)+import Grisette.Internal.SymPrim.FP+  ( ConvertibleBound (convertibleLowerBound, convertibleUpperBound),+    FP,+    FPRoundingMode (RNA, RNE, RTN, RTP, RTZ),+    ValidFP,+  )+import Grisette.Internal.SymPrim.Prim.Internal.Term+  ( PEvalIEEEFPConvertibleTerm+      ( pevalFromFPOrTerm,+        pevalToFPTerm,+        sbvFromFPOrTerm,+        sbvToFPTerm+      ),+    SBVRep (SBVType),+    SupportedPrim (conSBVTerm),+    Term,+    bvIsNonZeroFromGEq1,+    conTerm,+    fromFPOrTerm,+    toFPTerm,+    pattern ConTerm,+  )+import Grisette.Internal.SymPrim.Prim.Internal.Unfold (binaryUnfoldOnce)++-- | Generic implementation for floating-point casting operators for sbv.+genericFPCast ::+  forall a r.+  (SBV.HasKind a, SBV.HasKind r) =>+  SBV.SRoundingMode ->+  SBV.SBV a ->+  SBV.SBV r+genericFPCast rm f = SBVI.SBV (SBVI.SVal kTo (Right (SBVI.cache r)))+  where+    kFrom = SBVI.kindOf f+    kTo = SBVI.kindOf (Proxy @r)+    r st = do+      msv <- SBVI.sbvToSV st rm+      xsv <- SBVI.sbvToSV st f+      SBVI.newExpr st kTo $+        SBVI.SBVApp+          (SBVI.IEEEFP (SBVI.FP_Cast kFrom kTo msv))+          [xsv]++boundedSBVFromFPTerm ::+  forall bv (n :: Nat) eb sb r.+  ( ValidFP eb sb,+    SBVI.HasKind r,+    SBVI.SymVal r,+    Bounded r,+    Num r,+    Ord r,+    SBVI.SBV r ~ SBVType (bv n),+    KnownNat n,+    1 <= n,+    ConvertibleBound bv+  ) =>+  SBVI.SBV r ->+  SBVType FPRoundingMode ->+  SBVType (FP eb sb) ->+  SBVI.SBV r+boundedSBVFromFPTerm d mode l =+  SBV.ite+    ( SBV.fpIsNaN l+        SBV..|| SBV.fpIsInfinite l+        SBV..|| l SBV..< bound convertibleLowerBound+        SBV..|| l SBV..> bound convertibleUpperBound+    )+    d+    $ genericFPCast mode l+  where+    lst =+      [ (SBV.sRTP, RTP),+        (SBV.sRTN, RTN),+        (SBV.sRTZ, RTZ),+        (SBV.sRNE, RNE),+        (SBV.sRNA, RNA)+      ]+    bound f =+      foldl+        ( \acc (srm, rm) ->+            SBV.ite+              (mode SBV..== srm)+              (conSBVTerm (f (undefined :: bv n) rm :: FP eb sb))+              acc+        )+        (0 :: SBVType (FP eb sb))+        lst++generalPevalFromFPOrTerm ::+  ( PEvalIEEEFPConvertibleTerm a,+    ValidFP eb sb,+    SupportedPrim a,+    IEEEFPConvertible a (FP eb sb) FPRoundingMode+  ) =>+  Term a ->+  Term FPRoundingMode ->+  Term (FP eb sb) ->+  Term a+generalPevalFromFPOrTerm (ConTerm d) (ConTerm rd) (ConTerm f) =+  conTerm $ fromFPOr d rd f+generalPevalFromFPOrTerm d _ (ConTerm f) | fpIsNaN f || fpIsInfinite f = d+generalPevalFromFPOrTerm d rd f = fromFPOrTerm d rd f++algRealPevalFromFPOrTerm ::+  ( PEvalIEEEFPConvertibleTerm AlgReal,+    ValidFP eb sb,+    IEEEFPConvertible AlgReal (FP eb sb) FPRoundingMode+  ) =>+  Term AlgReal ->+  Term FPRoundingMode ->+  Term (FP eb sb) ->+  Term AlgReal+algRealPevalFromFPOrTerm (ConTerm d) _ (ConTerm f) =+  conTerm $ fromFPOr d RNE f+algRealPevalFromFPOrTerm d _ (ConTerm f) | fpIsNaN f || fpIsInfinite f = d+algRealPevalFromFPOrTerm d _ f = fromFPOrTerm d (conTerm RNE) f++generalDoPevalToFPTerm ::+  ( PEvalIEEEFPConvertibleTerm a,+    ValidFP eb sb,+    IEEEFPConvertible a (FP eb sb) FPRoundingMode+  ) =>+  Term FPRoundingMode ->+  Term a ->+  Maybe (Term (FP eb sb))+generalDoPevalToFPTerm (ConTerm rd) (ConTerm f) =+  Just $ conTerm $ toFP rd f+generalDoPevalToFPTerm _ _ = Nothing++generalPevalToFPTerm ::+  ( PEvalIEEEFPConvertibleTerm a,+    ValidFP eb sb,+    IEEEFPConvertible a (FP eb sb) FPRoundingMode+  ) =>+  Term FPRoundingMode ->+  Term a ->+  Term (FP eb sb)+generalPevalToFPTerm = binaryUnfoldOnce generalDoPevalToFPTerm toFPTerm++fpDoPevalToFPTerm ::+  ( ValidFP eb sb,+    ValidFP eb1 sb1,+    IEEEFPConvertible (FP eb1 sb1) (FP eb sb) FPRoundingMode+  ) =>+  Term FPRoundingMode ->+  Term (FP eb1 sb1) ->+  Maybe (Term (FP eb sb))+fpDoPevalToFPTerm (ConTerm rd) (ConTerm f) =+  Just $ conTerm $ toFP rd f+fpDoPevalToFPTerm _ (ConTerm f)+  | fpIsNaN f = Just $ conTerm fpNaN+  | fpIsPositiveInfinite f = Just $ conTerm fpPositiveInfinite+  | fpIsNegativeInfinite f = Just $ conTerm fpNegativeInfinite+  | fpIsPositiveZero f = Just $ conTerm fpPositiveZero+  | fpIsNegativeZero f = Just $ conTerm fpNegativeZero+fpDoPevalToFPTerm _ _ = Nothing++fpPevalToFPTerm ::+  ( ValidFP eb sb,+    ValidFP eb1 sb1,+    IEEEFPConvertible (FP eb1 sb1) (FP eb sb) FPRoundingMode+  ) =>+  Term FPRoundingMode ->+  Term (FP eb1 sb1) ->+  Term (FP eb sb)+fpPevalToFPTerm = binaryUnfoldOnce fpDoPevalToFPTerm toFPTerm++instance PEvalIEEEFPConvertibleTerm Integer where+  pevalFromFPOrTerm = generalPevalFromFPOrTerm+  pevalToFPTerm = generalPevalToFPTerm+  sbvFromFPOrTerm d mode l =+    SBV.ite (SBV.fpIsNaN l SBV..|| SBV.fpIsInfinite l) d $+      let r = SBV.fromSFloatingPoint mode l :: SBV.SReal+          ifloor = SBV.sRealToSInteger r+          diff = r - SBV.sFromIntegral ifloor+       in SBV.ite (diff SBV..== 0) ifloor+            $ SBV.ite (mode SBV..== SBV.sRTN) ifloor+            $ SBV.ite (mode SBV..== SBV.sRTP) (ifloor + 1)+            $ SBV.ite+              (mode SBV..== SBV.sRTZ)+              (SBV.ite (ifloor SBV..< 0) (ifloor + 1) ifloor)+            $ SBV.ite+              (diff SBV..== 0.5)+              ( SBV.ite+                  (mode SBV..== SBV.sRNE)+                  ( SBV.ite+                      (SBV.sMod ifloor 2 SBV..== 0)+                      ifloor+                      (ifloor + 1)+                  )+                  (SBV.ite (ifloor SBV..< 0) ifloor (ifloor + 1))+              )+            $ SBV.ite+              (diff SBV..< 0.5)+              ifloor+              (ifloor + 1)+  sbvToFPTerm mode l =+    case SBV.unliteral l of+      Nothing -> SBV.toSFloatingPoint mode l+      Just _ ->+        error $+          "SBV's toSFloatingPoint does not regard the rounding mode for "+            ++ "integers. This should never be called. "++instance PEvalIEEEFPConvertibleTerm AlgReal where+  pevalFromFPOrTerm = algRealPevalFromFPOrTerm+  pevalToFPTerm = generalPevalToFPTerm+  sbvFromFPOrTerm d mode l =+    SBV.ite (SBV.fpIsNaN l SBV..|| SBV.fpIsInfinite l) d $+      SBV.fromSFloatingPoint mode l+  sbvToFPTerm rm l =+    case SBV.unliteral l of+      Nothing -> SBV.toSFloatingPoint rm l+      Just _ ->+        error $+          "SBV is buggy on converting literal AlgReal to an FP. "+            ++ "This should never be called. "+            ++ "https://github.com/LeventErkok/sbv/pull/718"++instance (KnownNat n, 1 <= n) => PEvalIEEEFPConvertibleTerm (WordN n) where+  pevalFromFPOrTerm = generalPevalFromFPOrTerm+  pevalToFPTerm = generalPevalToFPTerm+  sbvFromFPOrTerm = bvIsNonZeroFromGEq1 (Proxy @n) $ boundedSBVFromFPTerm @WordN+  sbvToFPTerm mode l = bvIsNonZeroFromGEq1 (Proxy @n) $ genericFPCast mode l++instance (KnownNat n, 1 <= n) => PEvalIEEEFPConvertibleTerm (IntN n) where+  pevalFromFPOrTerm = generalPevalFromFPOrTerm+  pevalToFPTerm = generalPevalToFPTerm+  sbvFromFPOrTerm = bvIsNonZeroFromGEq1 (Proxy @n) $ boundedSBVFromFPTerm @IntN+  sbvToFPTerm mode l = bvIsNonZeroFromGEq1 (Proxy @n) $ genericFPCast mode l++instance (ValidFP eb sb) => PEvalIEEEFPConvertibleTerm (FP eb sb) where+  pevalFromFPOrTerm _ = fpPevalToFPTerm+  pevalToFPTerm = fpPevalToFPTerm+  sbvFromFPOrTerm _ rm v = case (SBV.unliteral rm, SBV.unliteral v) of+    (Just _, Just _) ->+      error $+        "SBV is buggy on converting literal FP to another FP with different "+          ++ "precision. This should never be called. "+          ++ "https://github.com/LeventErkok/sbv/pull/717"+    _ ->+      SBV.ite (SBV.fpIsNaN v) (conSBVTerm (fpNaN :: FP eb sb)) $+        SBV.toSFloatingPoint rm v+  sbvToFPTerm ::+    forall eb1 sb1.+    (ValidFP eb sb, ValidFP eb1 sb1) =>+    SBVType FPRoundingMode ->+    SBVType (FP eb sb) ->+    SBVType (FP eb1 sb1)+  sbvToFPTerm rm v = case (SBV.unliteral rm, SBV.unliteral v) of+    (Just _, Just _) ->+      error $+        "SBV is buggy on converting literal FP to another FP with different "+          ++ "precision. This should never be called. "+          ++ "https://github.com/LeventErkok/sbv/pull/717"+    _ ->+      SBV.ite (SBV.fpIsNaN v) (conSBVTerm (fpNaN :: FP eb1 sb1)) $+        SBV.toSFloatingPoint rm v
+ src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalNumTerm.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# HLINT ignore "Eta reduce" #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++-- |+-- Module      :   Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalNumTerm+-- 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.Prim.Internal.Instances.PEvalNumTerm () where++import Grisette.Internal.SymPrim.AlgReal (AlgReal)+import Grisette.Internal.SymPrim.FP (FP, ValidFP)+import Grisette.Internal.SymPrim.Prim.Internal.Term+  ( PEvalNumTerm+      ( pevalAbsNumTerm,+        pevalAddNumTerm,+        pevalMulNumTerm,+        pevalNegNumTerm,+        pevalSignumNumTerm,+        withSbvNumTermConstraint+      ),+    SupportedPrim (withPrim),+    absNumTerm,+    addNumTerm,+    doPevalNoOverflowAbsNumTerm,+    doPevalNoOverflowSignumNumTerm,+    mulNumTerm,+    negNumTerm,+    pevalDefaultAddNumTerm,+    pevalDefaultMulNumTerm,+    pevalDefaultNegNumTerm,+    signumNumTerm,+  )+import Grisette.Internal.SymPrim.Prim.Internal.Unfold+  ( generalBinaryUnfolded,+    generalUnaryUnfolded,+    unaryUnfoldOnce,+  )++instance PEvalNumTerm Integer where+  pevalAddNumTerm = pevalDefaultAddNumTerm+  pevalNegNumTerm = pevalDefaultNegNumTerm+  pevalMulNumTerm = pevalDefaultMulNumTerm+  pevalAbsNumTerm = unaryUnfoldOnce doPevalNoOverflowAbsNumTerm absNumTerm+  pevalSignumNumTerm =+    unaryUnfoldOnce doPevalNoOverflowSignumNumTerm signumNumTerm+  withSbvNumTermConstraint r = r++instance (ValidFP eb sb) => PEvalNumTerm (FP eb sb) where+  pevalAddNumTerm = generalBinaryUnfolded (+) addNumTerm+  pevalNegNumTerm = generalUnaryUnfolded negate negNumTerm+  pevalMulNumTerm = generalBinaryUnfolded (*) mulNumTerm+  pevalAbsNumTerm = generalUnaryUnfolded abs absNumTerm+  pevalSignumNumTerm = generalUnaryUnfolded signum signumNumTerm+  withSbvNumTermConstraint r = withPrim @(FP eb sb) r++instance PEvalNumTerm AlgReal where+  pevalAddNumTerm = pevalDefaultAddNumTerm+  pevalNegNumTerm = pevalDefaultNegNumTerm+  pevalMulNumTerm = pevalDefaultMulNumTerm+  pevalAbsNumTerm = unaryUnfoldOnce doPevalNoOverflowAbsNumTerm absNumTerm+  pevalSignumNumTerm =+    unaryUnfoldOnce doPevalNoOverflowSignumNumTerm signumNumTerm+  withSbvNumTermConstraint r = withPrim @AlgReal r
+ src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalOrdTerm.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Eta reduce" #-}++-- |+-- Module      :   Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalOrdTerm+-- 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.Prim.Internal.Instances.PEvalOrdTerm+  ( pevalGeneralLtOrdTerm,+    pevalGeneralLeOrdTerm,+  )+where++import Control.Monad (msum)+import qualified Data.SBV as SBV+import GHC.TypeNats (KnownNat, type (<=))+import Grisette.Internal.SymPrim.AlgReal (AlgReal)+import Grisette.Internal.SymPrim.BV (IntN, WordN)+import Grisette.Internal.SymPrim.FP+  ( FP,+    FPRoundingMode,+    ValidFP,+    allFPRoundingMode,+  )+import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalNumTerm ()+import Grisette.Internal.SymPrim.Prim.Internal.Term+  ( PEvalNumTerm (pevalNegNumTerm),+    PEvalOrdTerm+      ( pevalLeOrdTerm,+        pevalLtOrdTerm,+        sbvLeOrdTerm,+        sbvLtOrdTerm,+        withSbvOrdTermConstraint+      ),+    SupportedPrim (conSBVTerm, withPrim),+    Term,+    conTerm,+    leOrdTerm,+    ltOrdTerm,+    pevalSubNumTerm,+    pattern AddNumTerm,+    pattern ConTerm,+  )+import Grisette.Internal.SymPrim.Prim.Internal.Unfold (binaryUnfoldOnce)++-- | General partially evaluation of less than operation.+pevalGeneralLtOrdTerm :: (PEvalOrdTerm a, Ord a) => Term a -> Term a -> Term Bool+pevalGeneralLtOrdTerm = binaryUnfoldOnce doPevalGeneralLtOrdTerm ltOrdTerm++doPevalGeneralLtOrdTerm ::+  (PEvalOrdTerm a, Ord a) => Term a -> Term a -> Maybe (Term Bool)+doPevalGeneralLtOrdTerm (ConTerm a) (ConTerm b) = Just $ conTerm $ a < b+doPevalGeneralLtOrdTerm _ _ = Nothing++-- | General partially evaluation of less than or equal to operation.+pevalGeneralLeOrdTerm :: (PEvalOrdTerm a, Ord a) => Term a -> Term a -> Term Bool+pevalGeneralLeOrdTerm = binaryUnfoldOnce doPevalGeneralLeOrdTerm leOrdTerm++doPevalGeneralLeOrdTerm ::+  (PEvalOrdTerm a, Ord a) => Term a -> Term a -> Maybe (Term Bool)+doPevalGeneralLeOrdTerm (ConTerm a) (ConTerm b) = Just $ conTerm $ a <= b+doPevalGeneralLeOrdTerm _ _ = Nothing++instance PEvalOrdTerm Integer where+  pevalLtOrdTerm = binaryUnfoldOnce doPevalLtOrdTerm ltOrdTerm+    where+      doPevalLtOrdTerm l r =+        msum+          [ doPevalGeneralLtOrdTerm l r,+            case (l, r) of+              (ConTerm l, AddNumTerm (ConTerm j) k) ->+                Just $ pevalLtOrdTerm (conTerm $ l - j) k+              (AddNumTerm (ConTerm i) j, ConTerm k) ->+                Just $ pevalLtOrdTerm j (conTerm $ k - i)+              ((AddNumTerm (ConTerm j) k), l) ->+                Just $+                  pevalLtOrdTerm+                    (conTerm j)+                    (pevalSubNumTerm l k)+              (j, (AddNumTerm (ConTerm k) l)) ->+                Just $ pevalLtOrdTerm (conTerm $ -k) (pevalSubNumTerm l j)+              (l, ConTerm r) ->+                Just $ pevalLtOrdTerm (conTerm $ -r) (pevalNegNumTerm l)+              _ -> Nothing+          ]+  pevalLeOrdTerm = binaryUnfoldOnce doPevalLeOrdTerm leOrdTerm+    where+      doPevalLeOrdTerm l r =+        msum+          [ doPevalGeneralLeOrdTerm l r,+            case (l, r) of+              (ConTerm l, AddNumTerm (ConTerm j) k) ->+                Just $ pevalLeOrdTerm (conTerm $ l - j) k+              (AddNumTerm (ConTerm i) j, ConTerm k) ->+                Just $ pevalLeOrdTerm j (conTerm $ k - i)+              (AddNumTerm (ConTerm j) k, l) ->+                Just $ pevalLeOrdTerm (conTerm j) (pevalSubNumTerm l k)+              (j, AddNumTerm (ConTerm k) l) ->+                Just $ pevalLeOrdTerm (conTerm $ -k) (pevalSubNumTerm l j)+              (l, ConTerm r) ->+                Just $ pevalLeOrdTerm (conTerm $ -r) (pevalNegNumTerm l)+              _ -> Nothing+          ]+  withSbvOrdTermConstraint r = r++instance (KnownNat n, 1 <= n) => PEvalOrdTerm (WordN n) where+  pevalLtOrdTerm = pevalGeneralLtOrdTerm+  pevalLeOrdTerm = pevalGeneralLeOrdTerm+  withSbvOrdTermConstraint r = withPrim @(WordN n) r++instance (KnownNat n, 1 <= n) => PEvalOrdTerm (IntN n) where+  pevalLtOrdTerm = pevalGeneralLtOrdTerm+  pevalLeOrdTerm = pevalGeneralLeOrdTerm+  withSbvOrdTermConstraint r = withPrim @(IntN n) r++instance (ValidFP eb sb) => PEvalOrdTerm (FP eb sb) where+  pevalLtOrdTerm = pevalGeneralLtOrdTerm+  pevalLeOrdTerm = pevalGeneralLeOrdTerm+  withSbvOrdTermConstraint r = withPrim @(FP eb sb) r+  sbvLeOrdTerm x y =+    (SBV.sNot (SBV.fpIsNaN x) SBV..&& SBV.sNot (SBV.fpIsNaN y))+      SBV..&& (x SBV..<= y)++-- Use this table to avoid accidental breakage introduced by sbv.+fpRoundingModeLtTable :: [(SBV.SRoundingMode, SBV.SRoundingMode)]+fpRoundingModeLtTable =+  [ ( conSBVTerm @FPRoundingMode a,+      conSBVTerm @FPRoundingMode b+    )+  | a <- allFPRoundingMode,+    b <- allFPRoundingMode,+    a < b+  ]++fpRoundingModeLeTable :: [(SBV.SRoundingMode, SBV.SRoundingMode)]+fpRoundingModeLeTable =+  [ ( conSBVTerm @FPRoundingMode a,+      conSBVTerm @FPRoundingMode b+    )+  | a <- allFPRoundingMode,+    b <- allFPRoundingMode,+    a <= b+  ]++sbvTableLookup ::+  [(SBV.SRoundingMode, SBV.SRoundingMode)] ->+  SBV.SRoundingMode ->+  SBV.SRoundingMode ->+  SBV.SBV Bool+sbvTableLookup tbl lhs rhs =+  foldl+    (\acc (a, b) -> acc SBV..|| ((lhs SBV..== a) SBV..&& (rhs SBV..== b)))+    SBV.sFalse+    tbl++instance PEvalOrdTerm FPRoundingMode where+  pevalLtOrdTerm = pevalGeneralLtOrdTerm+  pevalLeOrdTerm = pevalGeneralLeOrdTerm+  withSbvOrdTermConstraint r = withPrim @FPRoundingMode r+  sbvLtOrdTerm = sbvTableLookup fpRoundingModeLtTable+  sbvLeOrdTerm = sbvTableLookup fpRoundingModeLeTable++instance PEvalOrdTerm AlgReal where+  pevalLtOrdTerm = pevalGeneralLtOrdTerm+  pevalLeOrdTerm = pevalGeneralLeOrdTerm+  withSbvOrdTermConstraint r = withPrim @AlgReal r
+ src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalRotateTerm.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalRotateTerm+-- 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.Prim.Internal.Instances.PEvalRotateTerm+  ( pevalFiniteBitsSymRotateRotateLeftTerm,+    pevalFiniteBitsSymRotateRotateRightTerm,+  )+where++import Data.Bits (Bits (rotateR), FiniteBits (finiteBitSize))+import Data.Proxy (Proxy (Proxy))+import qualified Data.SBV as SBV+import GHC.TypeLits (KnownNat, type (<=))+import Grisette.Internal.Core.Data.Class.SymRotate (SymRotate (symRotate))+import Grisette.Internal.SymPrim.BV (IntN, WordN)+import Grisette.Internal.SymPrim.Prim.Internal.Term+  ( PEvalRotateTerm+      ( pevalRotateLeftTerm,+        pevalRotateRightTerm,+        sbvRotateLeftTerm,+        sbvRotateRightTerm,+        withSbvRotateTermConstraint+      ),+    SupportedNonFuncPrim (withNonFuncPrim),+    Term,+    bvIsNonZeroFromGEq1,+    conTerm,+    rotateLeftTerm,+    rotateRightTerm,+    pattern ConTerm,+    pattern SupportedTerm,+  )+import Grisette.Internal.SymPrim.Prim.Internal.Unfold (unaryUnfoldOnce)++-- | Partial evaluation of symbolic rotate left term for finite bits types.+pevalFiniteBitsSymRotateRotateLeftTerm ::+  forall a.+  (Integral a, SymRotate a, FiniteBits a, PEvalRotateTerm a) =>+  Term a ->+  Term a ->+  Term a+pevalFiniteBitsSymRotateRotateLeftTerm t@SupportedTerm n =+  unaryUnfoldOnce+    (`doPevalFiniteBitsSymRotateRotateLeftTerm` n)+    (`rotateLeftTerm` n)+    t++doPevalFiniteBitsSymRotateRotateLeftTerm ::+  forall a.+  (Integral a, SymRotate a, FiniteBits a, PEvalRotateTerm a) =>+  Term a ->+  Term a ->+  Maybe (Term a)+doPevalFiniteBitsSymRotateRotateLeftTerm (ConTerm a) (ConTerm n)+  | n >= 0 = Just $ conTerm $ symRotate a n -- Just $ conTerm $ rotateL a (fromIntegral n)+doPevalFiniteBitsSymRotateRotateLeftTerm x (ConTerm 0) = Just x+-- doPevalFiniteBitsSymRotateRotateLeftTerm (RotateLeftTerm _ x (ConTerm  n)) (ConTerm  n1)+--   | n >= 0 && n1 >= 0 = Just $ pevalFiniteBitsSymRotateRotateLeftTerm x (conTerm $ n + n1)+doPevalFiniteBitsSymRotateRotateLeftTerm x (ConTerm n)+  | n >= 0 && (fromIntegral n :: Integer) >= fromIntegral bs =+      Just $+        pevalFiniteBitsSymRotateRotateLeftTerm+          x+          (conTerm $ n `mod` fromIntegral bs)+  where+    bs = finiteBitSize n+doPevalFiniteBitsSymRotateRotateLeftTerm _ _ = Nothing++-- | Partial evaluation of symbolic rotate right term for finite bits types.+pevalFiniteBitsSymRotateRotateRightTerm ::+  forall a.+  (Integral a, SymRotate a, FiniteBits a, PEvalRotateTerm a) =>+  Term a ->+  Term a ->+  Term a+pevalFiniteBitsSymRotateRotateRightTerm t@SupportedTerm n =+  unaryUnfoldOnce+    (`doPevalFiniteBitsSymRotateRotateRightTerm` n)+    (`rotateRightTerm` n)+    t++doPevalFiniteBitsSymRotateRotateRightTerm ::+  forall a.+  (Integral a, SymRotate a, FiniteBits a, PEvalRotateTerm a) =>+  Term a ->+  Term a ->+  Maybe (Term a)+doPevalFiniteBitsSymRotateRotateRightTerm (ConTerm a) (ConTerm n)+  | n >= 0 =+      Just . conTerm $+        rotateR+          a+          ( fromIntegral $+              (fromIntegral n :: Integer)+                `mod` fromIntegral (finiteBitSize n)+          )+doPevalFiniteBitsSymRotateRotateRightTerm x (ConTerm 0) = Just x+-- doPevalFiniteBitsSymRotateRotateRightTerm (RotateRightTerm _ x (ConTerm  n)) (ConTerm  n1)+--   | n >= 0 && n1 >= 0 = Just $ pevalFiniteBitsSymRotateRotateRightTerm x (conTerm $ n + n1)+doPevalFiniteBitsSymRotateRotateRightTerm x (ConTerm n)+  | n >= 0 && (fromIntegral n :: Integer) >= fromIntegral bs =+      Just $+        pevalFiniteBitsSymRotateRotateRightTerm+          x+          (conTerm $ n `mod` fromIntegral bs)+  where+    bs = finiteBitSize n+doPevalFiniteBitsSymRotateRotateRightTerm _ _ = Nothing++instance (KnownNat n, 1 <= n) => PEvalRotateTerm (IntN n) where+  pevalRotateLeftTerm = pevalFiniteBitsSymRotateRotateLeftTerm+  pevalRotateRightTerm = pevalFiniteBitsSymRotateRotateRightTerm+  withSbvRotateTermConstraint r =+    bvIsNonZeroFromGEq1 (Proxy @n) $+      withNonFuncPrim @(IntN n) r++  -- SBV's rotateLeft and rotateRight are broken for signed values, so we have to+  -- do this+  -- https://github.com/LeventErkok/sbv/issues/673+  sbvRotateLeftTerm l r =+    withNonFuncPrim @(IntN n) $+      withSbvRotateTermConstraint @(IntN n) $+        SBV.sFromIntegral $+          SBV.sRotateLeft+            (SBV.sFromIntegral l :: SBV.SWord n)+            (SBV.sFromIntegral r :: SBV.SWord n)+  sbvRotateRightTerm l r =+    withNonFuncPrim @(IntN n) $+      withSbvRotateTermConstraint @(IntN n) $+        SBV.sFromIntegral $+          SBV.sRotateRight+            (SBV.sFromIntegral l :: SBV.SWord n)+            (SBV.sFromIntegral r :: SBV.SWord n)++instance (KnownNat n, 1 <= n) => PEvalRotateTerm (WordN n) where+  pevalRotateLeftTerm = pevalFiniteBitsSymRotateRotateLeftTerm+  pevalRotateRightTerm = pevalFiniteBitsSymRotateRotateRightTerm+  withSbvRotateTermConstraint r =+    bvIsNonZeroFromGEq1 (Proxy @n) $+      withNonFuncPrim @(WordN n) r
+ src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalShiftTerm.hs view
@@ -0,0 +1,214 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalShiftTerm+-- 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.Prim.Internal.Instances.PEvalShiftTerm+  ( pevalFiniteBitsSymShiftShiftLeftTerm,+    pevalFiniteBitsSymShiftShiftRightTerm,+  )+where++import Data.Bits (Bits (isSigned, shiftR, zeroBits), FiniteBits (finiteBitSize))+import Data.Proxy (Proxy (Proxy))+import Data.Typeable ((:~:) (Refl))+import GHC.TypeLits (KnownNat, type (+), type (<=))+import Grisette.Internal.Core.Data.Class.SymShift (SymShift (symShift))+import Grisette.Internal.SymPrim.BV (IntN, WordN)+import Grisette.Internal.SymPrim.Prim.Internal.Term+  ( PEvalBVTerm (pevalBVConcatTerm, pevalBVExtendTerm),+    PEvalShiftTerm+      ( pevalShiftLeftTerm,+        pevalShiftRightTerm,+        withSbvShiftTermConstraint+      ),+    SupportedNonFuncPrim (withNonFuncPrim),+    SupportedPrim,+    Term,+    bvIsNonZeroFromGEq1,+    conTerm,+    shiftLeftTerm,+    shiftRightTerm,+    unsafePevalBVSelectTerm,+    pattern ConTerm,+    pattern SupportedTerm,+  )+import Grisette.Internal.SymPrim.Prim.Internal.Unfold (unaryUnfoldOnce)+import Grisette.Internal.Utils.Parameterized+  ( LeqProof (LeqProof),+    NatRepr,+    SomePositiveNatRepr (SomePositiveNatRepr),+    mkPositiveNatRepr,+    natRepr,+    subNat,+    unsafeAxiom,+    unsafeLeqProof,+  )++-- | Partial evaluation of symbolic shift left term for finite bits types.+pevalFiniteBitsSymShiftShiftLeftTerm ::+  forall bv n.+  ( forall m. (KnownNat m, 1 <= m) => Integral (bv m),+    forall m. (KnownNat m, 1 <= m) => SymShift (bv m),+    forall m. (KnownNat m, 1 <= m) => SupportedPrim (bv m),+    forall m. (KnownNat m, 1 <= m) => PEvalShiftTerm (bv m),+    PEvalBVTerm bv,+    KnownNat n,+    1 <= n+  ) =>+  Term (bv n) ->+  Term (bv n) ->+  Term (bv n)+pevalFiniteBitsSymShiftShiftLeftTerm t@SupportedTerm n =+  unaryUnfoldOnce+    (`doPevalFiniteBitsSymShiftShiftLeftTerm` n)+    (`shiftLeftTerm` n)+    t++doPevalFiniteBitsSymShiftShiftLeftTerm ::+  forall bv n.+  ( forall m. (KnownNat m, 1 <= m) => Integral (bv m),+    forall m. (KnownNat m, 1 <= m) => SymShift (bv m),+    forall m. (KnownNat m, 1 <= m) => SupportedPrim (bv m),+    forall m. (KnownNat m, 1 <= m) => PEvalShiftTerm (bv m),+    PEvalBVTerm bv,+    KnownNat n,+    1 <= n+  ) =>+  Term (bv n) ->+  Term (bv n) ->+  Maybe (Term (bv n))+doPevalFiniteBitsSymShiftShiftLeftTerm (ConTerm a) (ConTerm n)+  | n >= 0 =+      if (fromIntegral n :: Integer) >= fromIntegral (finiteBitSize n)+        then Just $ conTerm zeroBits+        else Just $ conTerm $ symShift a n+doPevalFiniteBitsSymShiftShiftLeftTerm x (ConTerm 0) = Just x+-- TODO: Need to handle the overflow case.+-- doPevalShiftLeftTerm (ShiftLeftTerm _ x (ConTerm  n)) (ConTerm  n1)+--   | n >= 0 && n1 >= 0 = Just $ pevalShiftLeftTerm x (conTerm $ n + n1)+doPevalFiniteBitsSymShiftShiftLeftTerm _ (ConTerm n)+  | n > 0 && (fromIntegral n :: Integer) >= fromIntegral (finiteBitSize n) =+      Just $ conTerm zeroBits+doPevalFiniteBitsSymShiftShiftLeftTerm x (ConTerm shiftAmount)+  | shiftAmount > 0 =+      case (namount, nremaining) of+        ( SomePositiveNatRepr (_ :: NatRepr amount),+          SomePositiveNatRepr (nremaining :: NatRepr remaining)+          ) ->+            case ( unsafeLeqProof @remaining @n,+                   unsafeAxiom @(remaining + amount) @n+                 ) of+              (LeqProof, Refl) ->+                Just $+                  pevalBVConcatTerm+                    (unsafePevalBVSelectTerm nn (natRepr @0) nremaining x)+                    (conTerm zeroBits :: Term (bv amount))+  where+    nn = natRepr @n+    namount = mkPositiveNatRepr $ fromIntegral shiftAmount+    nremaining =+      mkPositiveNatRepr $+        fromIntegral (finiteBitSize shiftAmount) - fromIntegral shiftAmount+doPevalFiniteBitsSymShiftShiftLeftTerm _ _ = Nothing++-- | Partial evaluation of symbolic shift right term for finite bits types.+pevalFiniteBitsSymShiftShiftRightTerm ::+  forall bv n.+  ( forall m. (KnownNat m, 1 <= m) => Integral (bv m),+    forall m. (KnownNat m, 1 <= m) => SymShift (bv m),+    forall m. (KnownNat m, 1 <= m) => SupportedPrim (bv m),+    forall m. (KnownNat m, 1 <= m) => PEvalShiftTerm (bv m),+    PEvalBVTerm bv,+    KnownNat n,+    1 <= n+  ) =>+  Term (bv n) ->+  Term (bv n) ->+  Term (bv n)+pevalFiniteBitsSymShiftShiftRightTerm t@SupportedTerm n =+  unaryUnfoldOnce+    (`doPevalFiniteBitsSymShiftShiftRightTerm` n)+    (`shiftRightTerm` n)+    t++doPevalFiniteBitsSymShiftShiftRightTerm ::+  forall bv n.+  ( forall m. (KnownNat m, 1 <= m) => Integral (bv m),+    forall m. (KnownNat m, 1 <= m) => SymShift (bv m),+    forall m. (KnownNat m, 1 <= m) => SupportedPrim (bv m),+    forall m. (KnownNat m, 1 <= m) => PEvalShiftTerm (bv m),+    PEvalBVTerm bv,+    KnownNat n,+    1 <= n+  ) =>+  Term (bv n) ->+  Term (bv n) ->+  Maybe (Term (bv n))+doPevalFiniteBitsSymShiftShiftRightTerm (ConTerm a) (ConTerm n)+  | n >= 0 && not (isSigned a) =+      if (fromIntegral n :: Integer) >= fromIntegral (finiteBitSize n)+        then Just $ conTerm zeroBits+        else Just $ conTerm $ shiftR a (fromIntegral n)+doPevalFiniteBitsSymShiftShiftRightTerm (ConTerm a) (ConTerm n)+  -- if n >= 0 then -n must be in the range+  | n >= 0 = Just $ conTerm $ symShift a (-n)+doPevalFiniteBitsSymShiftShiftRightTerm x (ConTerm 0) = Just x+-- doPevalFiniteBitsSymShiftShiftRightTerm (ShiftRightTerm _ x (ConTerm  n)) (ConTerm  n1)+--   | n >= 0 && n1 >= 0 = Just $ pevalFiniteBitsSymShiftShiftRightTerm x (conTerm $ n + n1)+doPevalFiniteBitsSymShiftShiftRightTerm x (ConTerm shiftAmount)+  | not (isSigned shiftAmount)+      && (fromIntegral shiftAmount :: Integer) >= fromIntegral (finiteBitSize shiftAmount) =+      Just $ conTerm zeroBits+  | isSigned shiftAmount+      && (fromIntegral shiftAmount :: Integer) >= fromIntegral (finiteBitSize shiftAmount) =+      Just $ pevalBVExtendTerm True nn $ unsafePevalBVSelectTerm nn nnp1 none x+  where+    nn = natRepr @n+    none = natRepr @1+    nnp1 = subNat nn none+doPevalFiniteBitsSymShiftShiftRightTerm x (ConTerm shiftAmount)+  | shiftAmount > 0 =+      case (namount, nremaining) of+        ( SomePositiveNatRepr namount,+          SomePositiveNatRepr (nremaining :: NatRepr remaining)+          ) ->+            case unsafeLeqProof @remaining @n of+              LeqProof ->+                Just $+                  pevalBVExtendTerm (isSigned shiftAmount) nn $+                    unsafePevalBVSelectTerm nn namount nremaining x+  where+    nn = natRepr @n+    namount = mkPositiveNatRepr $ fromIntegral shiftAmount+    nremaining =+      mkPositiveNatRepr $+        fromIntegral (finiteBitSize shiftAmount) - fromIntegral shiftAmount+doPevalFiniteBitsSymShiftShiftRightTerm _ _ = Nothing++instance (KnownNat n, 1 <= n) => PEvalShiftTerm (IntN n) where+  pevalShiftLeftTerm = pevalFiniteBitsSymShiftShiftLeftTerm+  pevalShiftRightTerm = pevalFiniteBitsSymShiftShiftRightTerm+  withSbvShiftTermConstraint r =+    bvIsNonZeroFromGEq1 (Proxy @n) $+      withNonFuncPrim @(IntN n) r++instance (KnownNat n, 1 <= n) => PEvalShiftTerm (WordN n) where+  pevalShiftLeftTerm = pevalFiniteBitsSymShiftShiftLeftTerm+  pevalShiftRightTerm = pevalFiniteBitsSymShiftShiftRightTerm+  withSbvShiftTermConstraint r =+    bvIsNonZeroFromGEq1 (Proxy @n) $+      withNonFuncPrim @(WordN n) r
+ src/Grisette/Internal/SymPrim/Prim/Internal/PartialEval.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++-- |+-- Module      :   Grisette.Internal.SymPrim.Prim.PartialEval.PartialEval+-- 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.SymPrim.Prim.Internal.PartialEval+  ( PartialFun,+    PartialRuleUnary,+    TotalRuleUnary,+    PartialRuleBinary,+    TotalRuleBinary,+    totalize,+    totalize2,+    UnaryPartialStrategy (..),+    unaryPartial,+    BinaryCommPartialStrategy (..),+    BinaryPartialStrategy (..),+    binaryPartial,+  )+where++import Control.Monad.Except (MonadError (catchError))+import Grisette.Internal.SymPrim.Prim.Internal.Term (Term)++-- | A partial function from a to b.+type PartialFun a b = a -> Maybe b++-- | A partial rule for unary operations.+type PartialRuleUnary a b = PartialFun (Term a) (Term b)++-- | A total rule for unary operations.+type TotalRuleUnary a b = Term a -> Term b++-- | A partial rule for binary operations.+type PartialRuleBinary a b c = Term a -> PartialFun (Term b) (Term c)++-- | A total rule for binary operations.+type TotalRuleBinary a b c = Term a -> Term b -> Term c++-- | Totalize a partial function with a fallback function.+totalize :: PartialFun a b -> (a -> b) -> a -> b+totalize partial fallback a =+  case partial a of+    Just b -> b+    Nothing -> fallback a++-- | Totalize a binary partial function with a fallback function.+totalize2 :: (a -> PartialFun b c) -> (a -> b -> c) -> a -> b -> c+totalize2 partial fallback a b =+  case partial a b of+    Just c -> c+    Nothing -> fallback a b++-- | A strategy for partially evaluating unary operations.+class UnaryPartialStrategy tag a b | tag a -> b where+  extractor :: tag -> Term a -> Maybe a+  constantHandler :: tag -> a -> Maybe (Term b)+  nonConstantHandler :: tag -> Term a -> Maybe (Term b)++-- | Partially evaluate a unary operation.+unaryPartial :: forall tag a b. (UnaryPartialStrategy tag a b) => tag -> PartialRuleUnary a b+unaryPartial tag a = case extractor tag a of+  Nothing -> nonConstantHandler tag a+  Just a' -> constantHandler tag a'++-- | A strategy for partially evaluating commutative binary operations.+class BinaryCommPartialStrategy tag a c | tag a -> c where+  singleConstantHandler :: tag -> a -> Term a -> Maybe (Term c)++-- | A strategy for partially evaluating operations.+class BinaryPartialStrategy tag a b c | tag a b -> c where+  extractora :: tag -> Term a -> Maybe a+  extractorb :: tag -> Term b -> Maybe b+  allConstantHandler :: tag -> a -> b -> Maybe (Term c)+  leftConstantHandler :: tag -> a -> Term b -> Maybe (Term c)+  default leftConstantHandler :: (a ~ b, BinaryCommPartialStrategy tag a c) => tag -> a -> Term b -> Maybe (Term c)+  leftConstantHandler = singleConstantHandler @tag @a+  rightConstantHandler :: tag -> Term a -> b -> Maybe (Term c)+  default rightConstantHandler :: (a ~ b, BinaryCommPartialStrategy tag a c) => tag -> Term a -> b -> Maybe (Term c)+  rightConstantHandler tag = flip $ singleConstantHandler @tag @a tag+  nonBinaryConstantHandler :: tag -> Term a -> Term b -> Maybe (Term c)++-- | Partially evaluate a binary operation.+binaryPartial :: forall tag a b c. (BinaryPartialStrategy tag a b c) => tag -> PartialRuleBinary a b c+binaryPartial tag a b = case (extractora @tag @a @b @c tag a, extractorb @tag @a @b @c tag b) of+  (Nothing, Nothing) -> nonBinaryConstantHandler @tag @a @b @c tag a b+  (Just a', Nothing) ->+    leftConstantHandler @tag @a @b @c tag a' b+      `catchError` \_ -> nonBinaryConstantHandler @tag @a @b @c tag a b+  (Nothing, Just b') ->+    rightConstantHandler @tag @a @b @c tag a b'+      `catchError` \_ -> nonBinaryConstantHandler @tag @a @b @c tag a b+  (Just a', Just b') ->+    allConstantHandler @tag @a @b @c tag a' b'
+ src/Grisette/Internal/SymPrim/Prim/Internal/Serialize.hs view
@@ -0,0 +1,2196 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.SymPrim.Prim.Internal.Serialize+-- 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.Prim.Internal.Serialize () where++import Control.Monad (replicateM, unless, when)+import Control.Monad.State (StateT, evalStateT)+import qualified Control.Monad.State as State+import qualified Data.Binary as Binary+import Data.Bytes.Get (MonadGet (getWord8))+import Data.Bytes.Put (MonadPut (putWord8))+import Data.Bytes.Serial (Serial (deserialize, serialize))+import Data.Foldable (traverse_)+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS+import Data.Hashable (Hashable (hashWithSalt))+import Data.List (intercalate)+import Data.List.NonEmpty (NonEmpty ((:|)))+import Data.Proxy (Proxy (Proxy))+import qualified Data.Serialize as Cereal+import Data.Word (Word8)+import GHC.Generics (Generic)+import GHC.Natural (Natural)+import GHC.Stack (HasCallStack)+import GHC.TypeNats (KnownNat, natVal, type (+), type (<=))+import Grisette.Internal.SymPrim.AlgReal (AlgReal)+import Grisette.Internal.SymPrim.BV (IntN, WordN)+import Grisette.Internal.SymPrim.FP+  ( FP,+    FPRoundingMode,+    ValidFP,+    checkDynamicValidFP,+    invalidFPMessage,+    withUnsafeValidFP,+  )+import Grisette.Internal.SymPrim.GeneralFun (type (-->) (GeneralFun))+import Grisette.Internal.SymPrim.Prim.Internal.Caches (Id)+import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalBitCastTerm ()+import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalDivModIntegralTerm ()+import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalFloatingTerm ()+import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalFractionalTerm ()+import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalFromIntegralTerm ()+import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalIEEEFPConvertibleTerm ()+import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalNumTerm ()+import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalOrdTerm ()+import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalRotateTerm ()+import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalShiftTerm ()+import Grisette.Internal.SymPrim.Prim.Internal.Term+  ( FPBinaryOp,+    FPRoundingBinaryOp,+    FPRoundingUnaryOp,+    FPTrait,+    FPUnaryOp,+    IsSymbolKind (decideSymbolKind),+    ModelValue (ModelValue),+    PEvalBitCastTerm,+    PEvalBitwiseTerm,+    PEvalDivModIntegralTerm,+    PEvalFloatingTerm,+    PEvalFractionalTerm,+    PEvalFromIntegralTerm,+    PEvalIEEEFPConvertibleTerm,+    PEvalNumTerm,+    PEvalOrdTerm,+    PEvalRotateTerm,+    PEvalShiftTerm,+    SomeTypedAnySymbol,+    SomeTypedSymbol (SomeTypedSymbol),+    SupportedNonFuncPrim,+    SupportedPrim (primTypeRep, withPrim),+    Term,+    TypedAnySymbol,+    TypedConstantSymbol,+    TypedSymbol (TypedSymbol),+    absNumTerm,+    addNumTerm,+    andBitsTerm,+    andTerm,+    applyTerm,+    bitCastOrTerm,+    bitCastTerm,+    bvConcatTerm,+    bvExtendTerm,+    bvSelectTerm,+    complementBitsTerm,+    conTerm,+    distinctTerm,+    divIntegralTerm,+    eqTerm,+    existsTerm,+    fdivTerm,+    floatingUnaryTerm,+    forallTerm,+    fpBinaryTerm,+    fpFMATerm,+    fpRoundingBinaryTerm,+    fpRoundingUnaryTerm,+    fpTraitTerm,+    fpUnaryTerm,+    fromFPOrTerm,+    fromIntegralTerm,+    iteTerm,+    leOrdTerm,+    ltOrdTerm,+    modIntegralTerm,+    mulNumTerm,+    negNumTerm,+    notTerm,+    orBitsTerm,+    orTerm,+    powerTerm,+    quotIntegralTerm,+    recipTerm,+    remIntegralTerm,+    rotateLeftTerm,+    rotateRightTerm,+    shiftLeftTerm,+    shiftRightTerm,+    signumNumTerm,+    someTypedSymbol,+    symTerm,+    termId,+    toFPTerm,+    xorBitsTerm,+    pattern AbsNumTerm,+    pattern AddNumTerm,+    pattern AndBitsTerm,+    pattern AndTerm,+    pattern ApplyTerm,+    pattern BVConcatTerm,+    pattern BVExtendTerm,+    pattern BVSelectTerm,+    pattern BitCastOrTerm,+    pattern BitCastTerm,+    pattern ComplementBitsTerm,+    pattern ConTerm,+    pattern DistinctTerm,+    pattern DivIntegralTerm,+    pattern EqTerm,+    pattern ExistsTerm,+    pattern FPBinaryTerm,+    pattern FPFMATerm,+    pattern FPRoundingBinaryTerm,+    pattern FPRoundingUnaryTerm,+    pattern FPTraitTerm,+    pattern FPUnaryTerm,+    pattern FdivTerm,+    pattern FloatingUnaryTerm,+    pattern ForallTerm,+    pattern FromFPOrTerm,+    pattern FromIntegralTerm,+    pattern ITETerm,+    pattern LeOrdTerm,+    pattern LtOrdTerm,+    pattern ModIntegralTerm,+    pattern MulNumTerm,+    pattern NegNumTerm,+    pattern NotTerm,+    pattern OrBitsTerm,+    pattern OrTerm,+    pattern PowerTerm,+    pattern QuotIntegralTerm,+    pattern RecipTerm,+    pattern RemIntegralTerm,+    pattern RotateLeftTerm,+    pattern RotateRightTerm,+    pattern ShiftLeftTerm,+    pattern ShiftRightTerm,+    pattern SignumNumTerm,+    pattern SupportedTerm,+    pattern SymTerm,+    pattern ToFPTerm,+    pattern XorBitsTerm,+  )+import Grisette.Internal.SymPrim.Prim.SomeTerm+  ( SomeTerm (SomeTerm),+    someTerm,+  )+import Grisette.Internal.SymPrim.Prim.TermUtils (castTerm)+import Grisette.Internal.SymPrim.TabularFun (type (=->))+import Grisette.Internal.Utils.Parameterized+  ( KnownProof (KnownProof),+    LeqProof (LeqProof),+    NatRepr,+    SomeNatRepr (SomeNatRepr),+    SomePositiveNatRepr (SomePositiveNatRepr),+    mkNatRepr,+    mkPositiveNatRepr,+    unsafeAxiom,+    unsafeKnownProof,+    unsafeLeqProof,+  )+import Type.Reflection+  ( SomeTypeRep (SomeTypeRep),+    TypeRep,+    Typeable,+    eqTypeRep,+    someTypeRep,+    typeRep,+    pattern App,+    pattern Con,+    type (:~:) (Refl),+    type (:~~:) (HRefl),+  )++data KnownNonFuncType where+  BoolType :: KnownNonFuncType+  IntegerType :: KnownNonFuncType+  WordNType :: (KnownNat n, 1 <= n) => Proxy n -> KnownNonFuncType+  IntNType :: (KnownNat n, 1 <= n) => Proxy n -> KnownNonFuncType+  FPType :: (ValidFP eb sb) => Proxy eb -> Proxy sb -> KnownNonFuncType+  FPRoundingModeType :: KnownNonFuncType+  AlgRealType :: KnownNonFuncType++instance Eq KnownNonFuncType where+  BoolType == BoolType = True+  IntegerType == IntegerType = True+  WordNType p == WordNType q = natVal p == natVal q+  IntNType p == IntNType q = natVal p == natVal q+  FPType p q == FPType r s = natVal p == natVal r && natVal q == natVal s+  FPRoundingModeType == FPRoundingModeType = True+  AlgRealType == AlgRealType = True+  _ == _ = False++instance Hashable KnownNonFuncType where+  hashWithSalt s BoolType = s `hashWithSalt` (0 :: Int)+  hashWithSalt s IntegerType = s `hashWithSalt` (1 :: Int)+  hashWithSalt s (WordNType p) =+    s `hashWithSalt` (2 :: Int) `hashWithSalt` natVal p+  hashWithSalt s (IntNType p) =+    s `hashWithSalt` (3 :: Int) `hashWithSalt` natVal p+  hashWithSalt s (FPType p q) =+    s `hashWithSalt` (4 :: Int) `hashWithSalt` natVal p `hashWithSalt` natVal q+  hashWithSalt s FPRoundingModeType = s `hashWithSalt` (5 :: Int)+  hashWithSalt s AlgRealType = s `hashWithSalt` (6 :: Int)++data KnownNonFuncTypeWitness where+  KnownNonFuncTypeWitness ::+    ( SupportedNonFuncPrim a,+      Eq a,+      Show a,+      Hashable a,+      Typeable a,+      Serial a+    ) =>+    Proxy a ->+    KnownNonFuncTypeWitness++witnessKnownNonFuncType :: KnownNonFuncType -> KnownNonFuncTypeWitness+witnessKnownNonFuncType BoolType = KnownNonFuncTypeWitness (Proxy @Bool)+witnessKnownNonFuncType IntegerType = KnownNonFuncTypeWitness (Proxy @Integer)+witnessKnownNonFuncType (WordNType (Proxy :: Proxy n)) =+  KnownNonFuncTypeWitness (Proxy @(WordN n))+witnessKnownNonFuncType (IntNType (Proxy :: Proxy n)) =+  KnownNonFuncTypeWitness (Proxy @(IntN n))+witnessKnownNonFuncType (FPType (Proxy :: Proxy eb) (Proxy :: Proxy sb)) =+  KnownNonFuncTypeWitness (Proxy @(FP eb sb))+witnessKnownNonFuncType FPRoundingModeType =+  KnownNonFuncTypeWitness (Proxy @FPRoundingMode)+witnessKnownNonFuncType AlgRealType = KnownNonFuncTypeWitness (Proxy @AlgReal)++data KnownType where+  NonFuncType :: KnownNonFuncType -> KnownType+  TabularFunType :: [KnownNonFuncType] -> KnownType+  GeneralFunType :: [KnownNonFuncType] -> KnownType+  deriving (Eq, Generic, Hashable)++data KnownTypeWitness where+  KnownTypeWitness ::+    ( SupportedPrim a,+      Eq a,+      Show a,+      Hashable a,+      Typeable a,+      Serial a+    ) =>+    Proxy a ->+    KnownTypeWitness++witnessKnownType :: KnownType -> KnownTypeWitness+witnessKnownType (NonFuncType nf) = case witnessKnownNonFuncType nf of+  KnownNonFuncTypeWitness (Proxy :: Proxy a) -> KnownTypeWitness (Proxy @a)+witnessKnownType (TabularFunType [a, b]) =+  case (witnessKnownNonFuncType a, witnessKnownNonFuncType b) of+    ( KnownNonFuncTypeWitness (Proxy :: Proxy a),+      KnownNonFuncTypeWitness (Proxy :: Proxy b)+      ) -> KnownTypeWitness (Proxy @(a =-> b))+witnessKnownType (TabularFunType [a, b, c]) =+  case ( witnessKnownNonFuncType a,+         witnessKnownNonFuncType b,+         witnessKnownNonFuncType c+       ) of+    ( KnownNonFuncTypeWitness (Proxy :: Proxy a),+      KnownNonFuncTypeWitness (Proxy :: Proxy b),+      KnownNonFuncTypeWitness (Proxy :: Proxy c)+      ) -> KnownTypeWitness (Proxy @(a =-> b =-> c))+witnessKnownType (TabularFunType [a, b, c, d]) =+  case ( witnessKnownNonFuncType a,+         witnessKnownNonFuncType b,+         witnessKnownNonFuncType c,+         witnessKnownNonFuncType d+       ) of+    ( KnownNonFuncTypeWitness (Proxy :: Proxy a),+      KnownNonFuncTypeWitness (Proxy :: Proxy b),+      KnownNonFuncTypeWitness (Proxy :: Proxy c),+      KnownNonFuncTypeWitness (Proxy :: Proxy d)+      ) -> KnownTypeWitness (Proxy @(a =-> b =-> c =-> d))+witnessKnownType (TabularFunType [a, b, c, d, e]) =+  case ( witnessKnownNonFuncType a,+         witnessKnownNonFuncType b,+         witnessKnownNonFuncType c,+         witnessKnownNonFuncType d,+         witnessKnownNonFuncType e+       ) of+    ( KnownNonFuncTypeWitness (Proxy :: Proxy a),+      KnownNonFuncTypeWitness (Proxy :: Proxy b),+      KnownNonFuncTypeWitness (Proxy :: Proxy c),+      KnownNonFuncTypeWitness (Proxy :: Proxy d),+      KnownNonFuncTypeWitness (Proxy :: Proxy e)+      ) -> KnownTypeWitness (Proxy @(a =-> b =-> c =-> d =-> e))+witnessKnownType (TabularFunType [a, b, c, d, e, f]) =+  case ( witnessKnownNonFuncType a,+         witnessKnownNonFuncType b,+         witnessKnownNonFuncType c,+         witnessKnownNonFuncType d,+         witnessKnownNonFuncType e,+         witnessKnownNonFuncType f+       ) of+    ( KnownNonFuncTypeWitness (Proxy :: Proxy a),+      KnownNonFuncTypeWitness (Proxy :: Proxy b),+      KnownNonFuncTypeWitness (Proxy :: Proxy c),+      KnownNonFuncTypeWitness (Proxy :: Proxy d),+      KnownNonFuncTypeWitness (Proxy :: Proxy e),+      KnownNonFuncTypeWitness (Proxy :: Proxy f)+      ) -> KnownTypeWitness (Proxy @(a =-> b =-> c =-> d =-> e =-> f))+witnessKnownType (TabularFunType [a, b, c, d, e, f, g]) =+  case ( witnessKnownNonFuncType a,+         witnessKnownNonFuncType b,+         witnessKnownNonFuncType c,+         witnessKnownNonFuncType d,+         witnessKnownNonFuncType e,+         witnessKnownNonFuncType f,+         witnessKnownNonFuncType g+       ) of+    ( KnownNonFuncTypeWitness (Proxy :: Proxy a),+      KnownNonFuncTypeWitness (Proxy :: Proxy b),+      KnownNonFuncTypeWitness (Proxy :: Proxy c),+      KnownNonFuncTypeWitness (Proxy :: Proxy d),+      KnownNonFuncTypeWitness (Proxy :: Proxy e),+      KnownNonFuncTypeWitness (Proxy :: Proxy f),+      KnownNonFuncTypeWitness (Proxy :: Proxy g)+      ) -> KnownTypeWitness (Proxy @(a =-> b =-> c =-> d =-> e =-> f =-> g))+witnessKnownType (TabularFunType [a, b, c, d, e, f, g, h]) =+  case ( witnessKnownNonFuncType a,+         witnessKnownNonFuncType b,+         witnessKnownNonFuncType c,+         witnessKnownNonFuncType d,+         witnessKnownNonFuncType e,+         witnessKnownNonFuncType f,+         witnessKnownNonFuncType g,+         witnessKnownNonFuncType h+       ) of+    ( KnownNonFuncTypeWitness (Proxy :: Proxy a),+      KnownNonFuncTypeWitness (Proxy :: Proxy b),+      KnownNonFuncTypeWitness (Proxy :: Proxy c),+      KnownNonFuncTypeWitness (Proxy :: Proxy d),+      KnownNonFuncTypeWitness (Proxy :: Proxy e),+      KnownNonFuncTypeWitness (Proxy :: Proxy f),+      KnownNonFuncTypeWitness (Proxy :: Proxy g),+      KnownNonFuncTypeWitness (Proxy :: Proxy h)+      ) ->+        KnownTypeWitness (Proxy @(a =-> b =-> c =-> d =-> e =-> f =-> g =-> h))+witnessKnownType (GeneralFunType [a, b]) =+  case (witnessKnownNonFuncType a, witnessKnownNonFuncType b) of+    ( KnownNonFuncTypeWitness (Proxy :: Proxy a),+      KnownNonFuncTypeWitness (Proxy :: Proxy b)+      ) -> KnownTypeWitness (Proxy @(a --> b))+witnessKnownType (GeneralFunType [a, b, c]) =+  case ( witnessKnownNonFuncType a,+         witnessKnownNonFuncType b,+         witnessKnownNonFuncType c+       ) of+    ( KnownNonFuncTypeWitness (Proxy :: Proxy a),+      KnownNonFuncTypeWitness (Proxy :: Proxy b),+      KnownNonFuncTypeWitness (Proxy :: Proxy c)+      ) -> KnownTypeWitness (Proxy @(a --> b --> c))+witnessKnownType (GeneralFunType [a, b, c, d]) =+  case ( witnessKnownNonFuncType a,+         witnessKnownNonFuncType b,+         witnessKnownNonFuncType c,+         witnessKnownNonFuncType d+       ) of+    ( KnownNonFuncTypeWitness (Proxy :: Proxy a),+      KnownNonFuncTypeWitness (Proxy :: Proxy b),+      KnownNonFuncTypeWitness (Proxy :: Proxy c),+      KnownNonFuncTypeWitness (Proxy :: Proxy d)+      ) -> KnownTypeWitness (Proxy @(a --> b --> c --> d))+witnessKnownType (GeneralFunType [a, b, c, d, e]) =+  case ( witnessKnownNonFuncType a,+         witnessKnownNonFuncType b,+         witnessKnownNonFuncType c,+         witnessKnownNonFuncType d,+         witnessKnownNonFuncType e+       ) of+    ( KnownNonFuncTypeWitness (Proxy :: Proxy a),+      KnownNonFuncTypeWitness (Proxy :: Proxy b),+      KnownNonFuncTypeWitness (Proxy :: Proxy c),+      KnownNonFuncTypeWitness (Proxy :: Proxy d),+      KnownNonFuncTypeWitness (Proxy :: Proxy e)+      ) -> KnownTypeWitness (Proxy @(a --> b --> c --> d --> e))+witnessKnownType (GeneralFunType [a, b, c, d, e, f]) =+  case ( witnessKnownNonFuncType a,+         witnessKnownNonFuncType b,+         witnessKnownNonFuncType c,+         witnessKnownNonFuncType d,+         witnessKnownNonFuncType e,+         witnessKnownNonFuncType f+       ) of+    ( KnownNonFuncTypeWitness (Proxy :: Proxy a),+      KnownNonFuncTypeWitness (Proxy :: Proxy b),+      KnownNonFuncTypeWitness (Proxy :: Proxy c),+      KnownNonFuncTypeWitness (Proxy :: Proxy d),+      KnownNonFuncTypeWitness (Proxy :: Proxy e),+      KnownNonFuncTypeWitness (Proxy :: Proxy f)+      ) -> KnownTypeWitness (Proxy @(a --> b --> c --> d --> e --> f))+witnessKnownType (GeneralFunType [a, b, c, d, e, f, g]) =+  case ( witnessKnownNonFuncType a,+         witnessKnownNonFuncType b,+         witnessKnownNonFuncType c,+         witnessKnownNonFuncType d,+         witnessKnownNonFuncType e,+         witnessKnownNonFuncType f,+         witnessKnownNonFuncType g+       ) of+    ( KnownNonFuncTypeWitness (Proxy :: Proxy a),+      KnownNonFuncTypeWitness (Proxy :: Proxy b),+      KnownNonFuncTypeWitness (Proxy :: Proxy c),+      KnownNonFuncTypeWitness (Proxy :: Proxy d),+      KnownNonFuncTypeWitness (Proxy :: Proxy e),+      KnownNonFuncTypeWitness (Proxy :: Proxy f),+      KnownNonFuncTypeWitness (Proxy :: Proxy g)+      ) -> KnownTypeWitness (Proxy @(a --> b --> c --> d --> e --> f --> g))+witnessKnownType (GeneralFunType [a, b, c, d, e, f, g, h]) =+  case ( witnessKnownNonFuncType a,+         witnessKnownNonFuncType b,+         witnessKnownNonFuncType c,+         witnessKnownNonFuncType d,+         witnessKnownNonFuncType e,+         witnessKnownNonFuncType f,+         witnessKnownNonFuncType g,+         witnessKnownNonFuncType h+       ) of+    ( KnownNonFuncTypeWitness (Proxy :: Proxy a),+      KnownNonFuncTypeWitness (Proxy :: Proxy b),+      KnownNonFuncTypeWitness (Proxy :: Proxy c),+      KnownNonFuncTypeWitness (Proxy :: Proxy d),+      KnownNonFuncTypeWitness (Proxy :: Proxy e),+      KnownNonFuncTypeWitness (Proxy :: Proxy f),+      KnownNonFuncTypeWitness (Proxy :: Proxy g),+      KnownNonFuncTypeWitness (Proxy :: Proxy h)+      ) ->+        KnownTypeWitness (Proxy @(a --> b --> c --> d --> e --> f --> g --> h))+witnessKnownType l = error $ "witnessKnownType: unsupported type: " <> show l++instance Show KnownNonFuncType where+  show BoolType = "Bool"+  show IntegerType = "Integer"+  show (WordNType (_ :: p n)) = "WordN " <> show (natVal (Proxy @n))+  show (IntNType (_ :: p n)) = "IntN " <> show (natVal (Proxy @n))+  show (FPType (_ :: p eb) (_ :: q sb)) =+    "FP "+      <> show (natVal (Proxy @eb))+      <> " "+      <> show (natVal (Proxy @sb))+  show FPRoundingModeType = "FPRoundingMode"+  show AlgRealType = "AlgReal"++instance Show KnownType where+  show (NonFuncType t) = show t+  show (TabularFunType ts) = intercalate " =-> " $ show <$> ts+  show (GeneralFunType ts) = intercalate " --> " $ show <$> ts++knownNonFuncType ::+  forall a p. (SupportedNonFuncPrim a) => p a -> KnownNonFuncType+knownNonFuncType _ =+  case tr of+    _ | SomeTypeRep tr == someTypeRep (Proxy @Bool) -> BoolType+    _ | SomeTypeRep tr == someTypeRep (Proxy @Integer) -> IntegerType+    _+      | SomeTypeRep tr == someTypeRep (Proxy @FPRoundingMode) ->+          FPRoundingModeType+    _ | SomeTypeRep tr == someTypeRep (Proxy @AlgReal) -> AlgRealType+    App (ta@(Con _) :: TypeRep w) (_ :: TypeRep n) ->+      case ( eqTypeRep ta (typeRep @WordN),+             eqTypeRep ta (typeRep @IntN)+           ) of+        (Just HRefl, _) -> withPrim @a $ WordNType (Proxy @n)+        (_, Just HRefl) -> withPrim @a $ IntNType (Proxy @n)+        _ -> err+    App (App (tf :: TypeRep f) (_ :: TypeRep a0)) (_ :: TypeRep a1) ->+      case eqTypeRep tf (typeRep @FP) of+        Just HRefl -> withPrim @a $ FPType (Proxy @a0) (Proxy @a1)+        _ -> err+    _ -> err+  where+    tr = primTypeRep @a+    err = error $ "knownNonFuncType: unsupported type: " <> show tr++knownType ::+  forall a p. (SupportedPrim a) => p a -> KnownType+knownType _ =+  case tr of+    _ | SomeTypeRep tr == someTypeRep (Proxy @Bool) -> NonFuncType BoolType+    _+      | SomeTypeRep tr == someTypeRep (Proxy @Integer) ->+          NonFuncType IntegerType+    _+      | SomeTypeRep tr == someTypeRep (Proxy @FPRoundingMode) ->+          NonFuncType FPRoundingModeType+    _+      | SomeTypeRep tr == someTypeRep (Proxy @AlgReal) ->+          NonFuncType AlgRealType+    App (ta@(Con _) :: TypeRep w) (_ :: TypeRep n) ->+      case ( eqTypeRep ta (typeRep @WordN),+             eqTypeRep ta (typeRep @IntN)+           ) of+        (Just HRefl, _) -> withPrim @a $ NonFuncType $ WordNType (Proxy @n)+        (_, Just HRefl) -> withPrim @a $ NonFuncType $ IntNType (Proxy @n)+        _ -> err+    App (App (tf :: TypeRep f) (_ :: TypeRep a0)) (_ :: TypeRep a1) ->+      case ( eqTypeRep tf (typeRep @FP),+             eqTypeRep tf (typeRep @(=->)),+             eqTypeRep tf (typeRep @(-->))+           ) of+        (Just HRefl, _, _) ->+          withPrim @a $ NonFuncType $ FPType (Proxy @a0) (Proxy @a1)+        (_, Just HRefl, _) ->+          withPrim @a $+            let arg = knownType (Proxy @a0)+                ret = knownType (Proxy @a1)+             in case arg of+                  NonFuncType n -> case ret of+                    NonFuncType m -> TabularFunType [n, m]+                    TabularFunType ns -> TabularFunType (n : ns)+                    _ -> err+                  _ -> err+        (_, _, Just HRefl) ->+          withPrim @a $+            let arg = knownType (Proxy @a0)+                ret = knownType (Proxy @a1)+             in case arg of+                  NonFuncType n -> case ret of+                    NonFuncType m -> GeneralFunType [n, m]+                    GeneralFunType ns -> GeneralFunType (n : ns)+                    _ -> err+                  _ -> err+        _ -> err+    _ -> err+  where+    tr = primTypeRep @a+    err = error $ "knownType: unsupported type: " <> show tr++-- Bool: 0+-- Integer: 1+-- WordN: 2+-- IntN: 3+-- FP: 4+-- FPRoundingMode: 5+-- AlgReal: 6+serializeKnownNonFuncType :: (MonadPut m) => KnownNonFuncType -> m ()+serializeKnownNonFuncType BoolType = putWord8 0+serializeKnownNonFuncType IntegerType = putWord8 1+serializeKnownNonFuncType (WordNType (Proxy :: Proxy n)) =+  putWord8 2 >> serialize (natVal (Proxy @n))+serializeKnownNonFuncType (IntNType (Proxy :: Proxy n)) =+  putWord8 3 >> serialize (natVal (Proxy @n))+serializeKnownNonFuncType (FPType (Proxy :: Proxy eb) (Proxy :: Proxy sb)) =+  putWord8 4 >> serialize (natVal (Proxy @eb)) >> serialize (natVal (Proxy @sb))+serializeKnownNonFuncType FPRoundingModeType = putWord8 5+serializeKnownNonFuncType AlgRealType = putWord8 6++serializeKnownType :: (MonadPut m) => KnownType -> m ()+serializeKnownType (NonFuncType t) = putWord8 0 >> serializeKnownNonFuncType t+serializeKnownType (TabularFunType ts) =+  putWord8 1+    >> putWord8 (fromIntegral $ length ts)+    >> traverse_ serializeKnownNonFuncType ts+serializeKnownType (GeneralFunType ts) =+  putWord8 2+    >> putWord8 (fromIntegral $ length ts)+    >> traverse_ serializeKnownNonFuncType ts++deserializeKnownNonFuncType :: (MonadGet m) => m KnownNonFuncType+deserializeKnownNonFuncType = do+  tag <- getWord8+  case tag of+    0 -> return BoolType+    1 -> return IntegerType+    2 -> do+      n <- deserialize @Natural+      when (n == 0) $ fail "deserializeKnownNonFuncType: WordN 0 is not allowed"+      case mkPositiveNatRepr n of+        SomePositiveNatRepr (_ :: NatRepr n) -> return $ WordNType (Proxy @n)+    3 -> do+      n <- deserialize @Natural+      when (n == 0) $ fail "deserializeKnownNonFuncType: IntN 0 is not allowed"+      case mkPositiveNatRepr n of+        SomePositiveNatRepr (_ :: NatRepr n) -> return $ IntNType (Proxy @n)+    4 -> do+      eb <- deserialize @Natural+      sb <- deserialize @Natural+      unless (checkDynamicValidFP eb sb) $ fail invalidFPMessage+      case (mkPositiveNatRepr eb, mkPositiveNatRepr sb) of+        ( SomePositiveNatRepr (_ :: NatRepr eb),+          SomePositiveNatRepr (_ :: NatRepr sb)+          ) ->+            withUnsafeValidFP @eb @sb $ return $ FPType (Proxy @eb) (Proxy @sb)+    5 -> return FPRoundingModeType+    6 -> return AlgRealType+    _ -> fail "deserializeKnownNonFuncType: Unknown type tag"++deserializeKnownType :: (MonadGet m) => m KnownType+deserializeKnownType = do+  tag <- getWord8+  case tag of+    0 -> NonFuncType <$> deserializeKnownNonFuncType+    1 -> do+      n <- getWord8+      nfs <- replicateM (fromIntegral n) deserializeKnownNonFuncType+      return $ TabularFunType nfs+    2 -> do+      n <- getWord8+      nfs <- replicateM (fromIntegral n) deserializeKnownNonFuncType+      return $ GeneralFunType nfs+    _ -> fail "deserializeKnownType: Unknown type tag"++instance Serial KnownType where+  serialize = serializeKnownType+  deserialize = deserializeKnownType++instance Cereal.Serialize KnownType where+  put = serialize+  get = deserialize++instance Binary.Binary KnownType where+  put = serialize+  get = deserialize++instance Serial KnownNonFuncType where+  serialize = serializeKnownNonFuncType+  deserialize = deserializeKnownNonFuncType++instance Cereal.Serialize KnownNonFuncType where+  put = serialize+  get = deserialize++instance Binary.Binary KnownNonFuncType where+  put = serialize+  get = deserialize++instance (IsSymbolKind knd) => Serial (SomeTypedSymbol knd) where+  serialize (SomeTypedSymbol tsb@(TypedSymbol sb)) =+    case decideSymbolKind @knd of+      Left HRefl -> do+        serializeKnownNonFuncType $ knownNonFuncType tsb+        serialize sb+      Right HRefl -> do+        serializeKnownType $ knownType tsb+        serialize sb+  deserialize = case decideSymbolKind @knd of+    Left HRefl -> do+      kt <- deserializeKnownNonFuncType+      case witnessKnownNonFuncType kt of+        KnownNonFuncTypeWitness (Proxy :: Proxy a) -> do+          sb <- deserialize+          return $ SomeTypedSymbol $ TypedSymbol @a sb+    Right HRefl -> do+      kt <- deserializeKnownType+      case witnessKnownType kt of+        KnownTypeWitness (Proxy :: Proxy a) -> do+          sb <- deserialize+          return $ SomeTypedSymbol $ TypedSymbol @a sb++instance (IsSymbolKind knd) => Cereal.Serialize (SomeTypedSymbol knd) where+  put = serialize+  get = deserialize++instance (IsSymbolKind knd) => Binary.Binary (SomeTypedSymbol knd) where+  put = serialize+  get = deserialize++instance (IsSymbolKind knd, Typeable a) => Serial (TypedSymbol knd a) where+  serialize tsb = serialize $ someTypedSymbol tsb+  deserialize = do+    SomeTypedSymbol (tsb@TypedSymbol {} :: TypedSymbol knd b) <- deserialize+    case eqTypeRep (typeRep @a) (primTypeRep @b) of+      Just HRefl -> return tsb+      Nothing -> fail "deserialize TypedSymbol: type mismatch"++instance+  (IsSymbolKind knd, Typeable a) =>+  Cereal.Serialize (TypedSymbol knd a)+  where+  put = serialize+  get = deserialize++instance+  (IsSymbolKind knd, Typeable a) =>+  Binary.Binary (TypedSymbol knd a)+  where+  put = serialize+  get = deserialize++conTermTag :: Word8+conTermTag = 0++symTermTag :: Word8+symTermTag = 1++forallTermTag :: Word8+forallTermTag = 2++existsTermTag :: Word8+existsTermTag = 3++notTermTag :: Word8+notTermTag = 4++orTermTag :: Word8+orTermTag = 5++andTermTag :: Word8+andTermTag = 6++eqTermTag :: Word8+eqTermTag = 7++distinctTermTag :: Word8+distinctTermTag = 8++iteTermTag :: Word8+iteTermTag = 9++addNumTermTag :: Word8+addNumTermTag = 10++negNumTermTag :: Word8+negNumTermTag = 11++mulNumTermTag :: Word8+mulNumTermTag = 12++absNumTermTag :: Word8+absNumTermTag = 13++signumNumTermTag :: Word8+signumNumTermTag = 14++ltOrdTermTag :: Word8+ltOrdTermTag = 15++leOrdTermTag :: Word8+leOrdTermTag = 16++andBitsTermTag :: Word8+andBitsTermTag = 17++orBitsTermTag :: Word8+orBitsTermTag = 18++xorBitsTermTag :: Word8+xorBitsTermTag = 19++complementBitsTermTag :: Word8+complementBitsTermTag = 20++shiftLeftTermTag :: Word8+shiftLeftTermTag = 21++shiftRightTermTag :: Word8+shiftRightTermTag = 22++rotateLeftTermTag :: Word8+rotateLeftTermTag = 23++rotateRightTermTag :: Word8+rotateRightTermTag = 24++bitCastTermTag :: Word8+bitCastTermTag = 25++bitCastOrTermTag :: Word8+bitCastOrTermTag = 26++bvConcatTermTag :: Word8+bvConcatTermTag = 27++bvSelectTermTag :: Word8+bvSelectTermTag = 28++bvExtendTermTag :: Word8+bvExtendTermTag = 29++applyTermTag :: Word8+applyTermTag = 30++divIntegralTermTag :: Word8+divIntegralTermTag = 31++modIntegralTermTag :: Word8+modIntegralTermTag = 32++quotIntegralTermTag :: Word8+quotIntegralTermTag = 33++remIntegralTermTag :: Word8+remIntegralTermTag = 34++fpTraitTermTag :: Word8+fpTraitTermTag = 35++fdivTermTag :: Word8+fdivTermTag = 36++recipTermTag :: Word8+recipTermTag = 37++floatingUnaryTermTag :: Word8+floatingUnaryTermTag = 38++powerTermTag :: Word8+powerTermTag = 39++fpUnaryTermTag :: Word8+fpUnaryTermTag = 40++fpBinaryTermTag :: Word8+fpBinaryTermTag = 41++fpRoundingUnaryTermTag :: Word8+fpRoundingUnaryTermTag = 42++fpRoundingBinaryTermTag :: Word8+fpRoundingBinaryTermTag = 43++fpFMATermTag :: Word8+fpFMATermTag = 44++fromIntegralTermTag :: Word8+fromIntegralTermTag = 45++fromFPOrTermTag :: Word8+fromFPOrTermTag = 46++toFPTermTag :: Word8+toFPTermTag = 47++terminalTag :: Word8+terminalTag = 255++asBoolTerm :: (HasCallStack) => SomeTerm -> Term Bool+asBoolTerm (SomeTerm (t :: Term a)) =+  case eqTypeRep (primTypeRep @Bool) (primTypeRep @a) of+    Just HRefl -> t+    Nothing -> error "asBoolTerm: type mismatch"++asSameTypeNonEmptyTermList ::+  (HasCallStack) =>+  NonEmpty SomeTerm ->+  (forall b. NonEmpty (Term b) -> r) ->+  r+asSameTypeNonEmptyTermList (SomeTerm (t :: Term a) :| ts) f =+  f $ t :| fmap (unsafeCastTerm t) ts+  where+    unsafeCastTerm :: Term a -> SomeTerm -> Term a+    unsafeCastTerm _ (SomeTerm b) =+      case castTerm b of+        Just r -> r+        Nothing -> error "asSameTypeNonEmptyTermList: type mismatch"++asNumTypeTerm ::+  (HasCallStack) =>+  SomeTerm ->+  (forall n. (PEvalNumTerm n, PEvalIEEEFPConvertibleTerm n) => Term n -> r) ->+  r+asNumTypeTerm (SomeTerm (t1 :: Term a)) f =+  case ( eqTypeRep ta (typeRep @Integer),+         eqTypeRep ta (typeRep @AlgReal)+       ) of+    (Just HRefl, _) -> f t1+    (_, Just HRefl) -> f t1+    _ ->+      case ta of+        App (ta@(Con _) :: TypeRep w) (_ :: TypeRep n) ->+          case ( eqTypeRep ta (typeRep @WordN),+                 eqTypeRep ta (typeRep @IntN)+               ) of+            (Just HRefl, _) -> withPrim @a $ f t1+            (_, Just HRefl) -> withPrim @a $ f t1+            _ -> err+        App (App (tf :: TypeRep f) (_ :: TypeRep a0)) (_ :: TypeRep a1) ->+          case eqTypeRep tf (typeRep @FP) of+            Just HRefl ->+              withPrim @a $ withPrim @a $ f t1+            _ -> err+        _ -> err+  where+    ta = primTypeRep @a+    err = error $ "asNumTypeTerm: unsupported type: " <> show ta++asOrdTypeTerm ::+  (HasCallStack) => SomeTerm -> (forall n. (PEvalOrdTerm n) => Term n -> r) -> r+asOrdTypeTerm (SomeTerm (t1 :: Term a)) f =+  case ( eqTypeRep ta (typeRep @Integer),+         eqTypeRep ta (typeRep @AlgReal),+         eqTypeRep ta (typeRep @FPRoundingMode)+       ) of+    (Just HRefl, _, _) -> f t1+    (_, Just HRefl, _) -> f t1+    (_, _, Just HRefl) -> f t1+    _ ->+      case ta of+        App (ta@(Con _) :: TypeRep w) (_ :: TypeRep n) ->+          case ( eqTypeRep ta (typeRep @WordN),+                 eqTypeRep ta (typeRep @IntN)+               ) of+            (Just HRefl, _) -> withPrim @a $ f t1+            (_, Just HRefl) -> withPrim @a $ f t1+            _ -> err+        App (App (tf :: TypeRep f) (_ :: TypeRep a0)) (_ :: TypeRep a1) ->+          case eqTypeRep tf (typeRep @FP) of+            Just HRefl ->+              withPrim @a $ withPrim @a $ f t1+            _ -> err+        _ -> err+  where+    ta = primTypeRep @a+    err = error $ "asOrdTypeTerm: unsupported type: " <> show ta++asBitsTypeTerm ::+  (HasCallStack) =>+  SomeTerm ->+  ( forall n.+    (PEvalBitwiseTerm n, PEvalShiftTerm n, PEvalRotateTerm n) =>+    Term n ->+    r+  ) ->+  r+asBitsTypeTerm (SomeTerm (t1 :: Term a)) f =+  case ta of+    App (ta@(Con _) :: TypeRep w) (_ :: TypeRep n) ->+      case ( eqTypeRep ta (typeRep @WordN),+             eqTypeRep ta (typeRep @IntN)+           ) of+        (Just HRefl, _) -> withPrim @a $ f t1+        (_, Just HRefl) -> withPrim @a $ f t1+        _ -> err+    _ -> err+  where+    ta = primTypeRep @a+    err = error $ "asBitsTypeTerm: unsupported type: " <> show ta++asIntegralTypeTerm ::+  (HasCallStack) =>+  SomeTerm ->+  (forall n. (PEvalDivModIntegralTerm n) => Term n -> r) ->+  r+asIntegralTypeTerm (SomeTerm (t1 :: Term a)) f =+  case eqTypeRep ta (typeRep @Integer) of+    Just HRefl -> f t1+    _ -> case ta of+      App (ta@(Con _) :: TypeRep w) (_ :: TypeRep n) ->+        case (eqTypeRep ta (typeRep @WordN), eqTypeRep ta (typeRep @IntN)) of+          (Just HRefl, _) -> withPrim @a $ f t1+          (_, Just HRefl) -> withPrim @a $ f t1+          _ -> err+      _ -> err+  where+    ta = primTypeRep @a+    err = error $ "asOrdTypeTerm: unsupported type: " <> show ta++asFloatingFractionalTypeTerm ::+  (HasCallStack) =>+  SomeTerm ->+  (forall n. (PEvalFloatingTerm n, PEvalFractionalTerm n) => Term n -> r) ->+  r+asFloatingFractionalTypeTerm (SomeTerm (t1 :: Term a)) f =+  case eqTypeRep ta (typeRep @AlgReal) of+    Just HRefl -> f t1+    _ -> case ta of+      App (App (tf :: TypeRep f) (_ :: TypeRep a0)) (_ :: TypeRep a1) ->+        case eqTypeRep tf (typeRep @FP) of+          Just HRefl -> withPrim @a $ f t1+          _ -> err+      _ -> err+  where+    ta = primTypeRep @a+    err = error $ "asFloatingFractionalTypeTerm: unsupported type: " <> show ta++asFPTypeTerm ::+  (HasCallStack) =>+  SomeTerm ->+  (forall eb sb. (ValidFP eb sb) => Term (FP eb sb) -> r) ->+  r+asFPTypeTerm (SomeTerm (t1 :: Term a)) f =+  case ta of+    App (App (tf :: TypeRep f) (_ :: TypeRep a0)) (_ :: TypeRep a1) ->+      case eqTypeRep tf (typeRep @FP) of+        Just HRefl -> withPrim @a $ f t1+        _ -> err+    _ -> err+  where+    ta = primTypeRep @a+    err = error $ "asFPTypeTerm: unsupported type: " <> show ta++asSameType ::+  (HasCallStack) => Term a -> SomeTerm -> (Term a -> r) -> r+asSameType (SupportedTerm :: Term a) (SomeTerm (t2 :: Term b)) f =+  case eqTypeRep (primTypeRep @a) (primTypeRep @b) of+    Just HRefl -> f t2+    Nothing -> error "asSameType: type mismatch"++asFPRoundingTerm ::+  (HasCallStack) => SomeTerm -> (Term FPRoundingMode -> r) -> r+asFPRoundingTerm (SomeTerm (t1 :: Term a)) f =+  case eqTypeRep ta (typeRep @FPRoundingMode) of+    Just HRefl -> f t1+    _ -> err+  where+    ta = primTypeRep @a+    err = error $ "asFPRoundingTerm: unsupported type: " <> show ta++constructBitCastOrTerm :: (HasCallStack) => SomeTerm -> SomeTerm -> SomeTerm+constructBitCastOrTerm (SomeTerm (td :: Term d)) (SomeTerm (tv :: Term v)) =+  withPrim @d $+    withPrim @v $+      case (trv, trd) of+        ( App+            (App (trfp@(Con _) :: TypeRep fp) (treb :: TypeRep eb))+            (trsb :: TypeRep sb),+          App (trbv@(Con _) :: TypeRep bv) (trn :: TypeRep n)+          ) ->+            case ( eqTypeRep trfp (typeRep @FP),+                   eqTypeRep trbv (typeRep @WordN),+                   eqTypeRep trbv (typeRep @IntN)+                 ) of+              (Just HRefl, Just HRefl, _) ->+                if natVal treb + natVal trsb == natVal trn+                  then case unsafeAxiom @n @(eb + sb) of+                    Refl -> someTerm (bitCastOrTerm td tv :: Term d)+                  else err+              (Just HRefl, _, Just HRefl) ->+                if natVal treb + natVal trsb == natVal trn+                  then case unsafeAxiom @n @(eb + sb) of+                    Refl -> someTerm (bitCastOrTerm td tv :: Term d)+                  else err+              _ -> err+        _ -> err+  where+    trd = primTypeRep @d+    trv = primTypeRep @v+    err :: r+    err =+      error $+        "constructBitCastOrTerm: unsupported type: " <> show trd <> show trv++constructBitCastTerm :: (HasCallStack) => SomeTerm -> KnownType -> SomeTerm+constructBitCastTerm (SomeTerm (t1 :: Term a)) retType =+  case witnessKnownType retType of+    KnownTypeWitness (_ :: Proxy b) -> do+      let tb = primTypeRep @b+      withPrim @a $ withPrim @b $ case (eqTypeRep ta (typeRep @Bool), ta) of+        (Just HRefl, _) -> case tb of+          App (tw@(Con _) :: TypeRep w) (tn :: TypeRep n) ->+            case ( eqTypeRep tw (typeRep @WordN),+                   eqTypeRep tw (typeRep @IntN),+                   eqTypeRep tn (typeRep @1)+                 ) of+              (Just HRefl, _, Just HRefl) -> someTerm (bitCastTerm t1 :: Term b)+              (_, Just HRefl, Just HRefl) -> someTerm (bitCastTerm t1 :: Term b)+              _ -> err+          _ -> err+        (_, App (tw@(Con _) :: TypeRep w) (tn :: TypeRep n)) ->+          case (eqTypeRep tw (typeRep @WordN), eqTypeRep tw (typeRep @IntN)) of+            (Just HRefl, _) -> fromBV t1 tn tb (typeRep @IntN)+            (_, Just HRefl) -> fromBV t1 tn tb (typeRep @WordN)+            _ -> err+        _ -> err+  where+    ta = primTypeRep @a+    err :: r+    err =+      error $+        "constructBitCastTerm: unsupported type: "+          <> show ta+          <> show retType+    fromBV ::+      forall bv n b bv2.+      ( forall n. (KnownNat n, 1 <= n) => PEvalBitCastTerm (bv n) (bv2 n),+        PEvalBitCastTerm (bv 1) Bool,+        forall n eb sb.+        (KnownNat n, 1 <= n, ValidFP eb sb, (eb + sb) ~ n) =>+        PEvalBitCastTerm (bv n) (FP eb sb),+        KnownNat n,+        1 <= n,+        SupportedPrim b,+        forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv2 n)+      ) =>+      Term (bv n) ->+      TypeRep n ->+      TypeRep b ->+      TypeRep bv2 ->+      SomeTerm+    fromBV t1 tn tb tbv2 =+      case (eqTypeRep tn (typeRep @1), eqTypeRep tb (typeRep @Bool)) of+        (Just HRefl, Just HRefl) -> someTerm (bitCastTerm t1 :: Term b)+        _ -> case tb of+          (App (tw'@(Con _) :: TypeRep w') (tn' :: TypeRep n')) ->+            case ( eqTypeRep tw' tbv2,+                   eqTypeRep tn tn'+                 ) of+              (Just HRefl, Just HRefl) ->+                someTerm (bitCastTerm t1 :: Term b)+              _ -> err+          ( App+              (App (tw' :: TypeRep f) (teb :: TypeRep eb))+              (tsb :: TypeRep sb)+            ) ->+              withPrim @b $+                case (eqTypeRep tw' (typeRep @FP)) of+                  Just HRefl ->+                    if natVal teb + natVal tsb == natVal tn+                      then case unsafeAxiom @n @(eb + sb) of+                        Refl -> someTerm (bitCastTerm t1 :: Term b)+                      else err+                  _ -> err+          _ -> err++constructBVConcatTerm :: (HasCallStack) => SomeTerm -> SomeTerm -> SomeTerm+constructBVConcatTerm (SomeTerm (ta :: Term a)) (SomeTerm (tb :: Term b)) =+  withPrim @a $+    withPrim @b $+      case (tra, trb) of+        ( App (trbv0@(Con _) :: TypeRep bv0) (trn0 :: TypeRep n0),+          App (trbv1@(Con _) :: TypeRep bv1) (trn1 :: TypeRep n1)+          ) ->+            case ( eqTypeRep trbv0 trbv1,+                   eqTypeRep trbv0 (typeRep @WordN),+                   eqTypeRep trbv0 (typeRep @IntN)+                 ) of+              (Just HRefl, Just HRefl, _) ->+                case ( unsafeLeqProof @1 @(n0 + n1),+                       unsafeKnownProof @(n0 + n1) (natVal trn0 + natVal trn1)+                     ) of+                  (LeqProof, KnownProof) -> someTerm $ bvConcatTerm ta tb+              (Just HRefl, _, Just HRefl) ->+                case ( unsafeLeqProof @1 @(n0 + n1),+                       unsafeKnownProof @(n0 + n1) (natVal trn0 + natVal trn1)+                     ) of+                  (LeqProof, KnownProof) -> someTerm $ bvConcatTerm ta tb+              _ -> err+        _ -> err+  where+    tra = primTypeRep @a+    trb = primTypeRep @b+    err :: SomeTerm+    err =+      error $+        "constructBVConcatTerm: unsupported type: "+          <> show (primTypeRep @a)++constructBVSelectTerm ::+  (HasCallStack) => Natural -> Natural -> SomeTerm -> SomeTerm+constructBVSelectTerm ix w (SomeTerm (ta :: Term a)) =+  withPrim @a $+    case tra of+      (App (trbv@(Con _) :: TypeRep bv) (trn :: TypeRep n)) ->+        case ( eqTypeRep trbv (typeRep @WordN),+               eqTypeRep trbv (typeRep @IntN)+             ) of+          (Just HRefl, _) -> case (mkNatRepr ix, mkPositiveNatRepr w) of+            ( SomeNatRepr (nix :: NatRepr ix),+              SomePositiveNatRepr (nw :: NatRepr w)+              ) ->+                if ix + w <= natVal trn+                  then case unsafeLeqProof @(ix + w) @n of+                    LeqProof -> someTerm $ bvSelectTerm nix nw ta+                  else err+          (_, Just HRefl) -> case (mkNatRepr ix, mkPositiveNatRepr w) of+            ( SomeNatRepr (nix :: NatRepr ix),+              SomePositiveNatRepr (nw :: NatRepr w)+              ) ->+                if ix + w <= natVal trn+                  then case unsafeLeqProof @(ix + w) @n of+                    LeqProof -> someTerm $ bvSelectTerm nix nw ta+                  else err+          _ -> err+      _ -> err+  where+    tra = primTypeRep @a+    err :: SomeTerm+    err =+      error $+        "constructBVSelectTerm: unsupported type: "+          <> show (primTypeRep @a)++constructBVExtendTerm ::+  (HasCallStack) => Bool -> Natural -> SomeTerm -> SomeTerm+constructBVExtendTerm signed r (SomeTerm (ta :: Term a)) =+  withPrim @a $+    case tra of+      (App (trbv@(Con _) :: TypeRep bv) (trn :: TypeRep n)) ->+        case ( eqTypeRep trbv (typeRep @WordN),+               eqTypeRep trbv (typeRep @IntN)+             ) of+          (Just HRefl, _) -> case (mkPositiveNatRepr r) of+            (SomePositiveNatRepr (nr :: NatRepr r)) ->+              if natVal trn <= r+                then case unsafeLeqProof @n @r of+                  LeqProof -> someTerm $ bvExtendTerm signed nr ta+                else err+          (_, Just HRefl) -> case (mkPositiveNatRepr r) of+            (SomePositiveNatRepr (nr :: NatRepr r)) ->+              if natVal trn <= r+                then case unsafeLeqProof @n @r of+                  LeqProof -> someTerm $ bvExtendTerm signed nr ta+                else err+          _ -> err+      _ -> err+  where+    tra = primTypeRep @a+    err :: SomeTerm+    err =+      error $+        "constructBVExtendTerm: unsupported type: "+          <> show (primTypeRep @a)++constructApplyTerm ::+  (HasCallStack) => SomeTerm -> SomeTerm -> SomeTerm+constructApplyTerm (SomeTerm (tf :: Term f)) (SomeTerm (ta :: Term a)) =+  withPrim @f $+    withPrim @a $+      case trf of+        (App (App (trft :: TypeRep ft) (trarg :: TypeRep arg)) _) ->+          case ( eqTypeRep trft (typeRep @(=->)),+                 eqTypeRep trft (typeRep @(-->))+               ) of+            (Just HRefl, _) -> case eqTypeRep trarg tra of+              Just HRefl -> someTerm $ applyTerm tf ta+              Nothing -> err+            (_, Just HRefl) -> case eqTypeRep trarg tra of+              Just HRefl -> someTerm $ applyTerm tf ta+              Nothing -> err+            _ -> err+        _ -> err+  where+    trf = primTypeRep @f+    tra = primTypeRep @a+    err :: SomeTerm+    err =+      error $+        "constructApplyTerm: unsupported type: " <> show trf <> show tra++constructFromIntegralTerm' ::+  forall a.+  ( HasCallStack,+    PEvalFromIntegralTerm a Integer,+    PEvalFromIntegralTerm a AlgReal,+    forall n. (KnownNat n, 1 <= n) => PEvalFromIntegralTerm a (WordN n),+    forall n. (KnownNat n, 1 <= n) => PEvalFromIntegralTerm a (IntN n),+    forall eb sb. (ValidFP eb sb) => PEvalFromIntegralTerm a (FP eb sb)+  ) =>+  Term a ->+  KnownType ->+  SomeTerm+constructFromIntegralTerm' ta@SupportedTerm retType =+  case witnessKnownType retType of+    KnownTypeWitness (_ :: Proxy b) -> do+      let tb = primTypeRep @b+      withPrim @a $+        withPrim @b $+          case ( eqTypeRep tb (typeRep @Integer),+                 eqTypeRep tb (typeRep @AlgReal),+                 tb+               ) of+            (Just HRefl, _, _) -> someTerm (fromIntegralTerm ta :: Term b)+            (_, Just HRefl, _) -> someTerm (fromIntegralTerm ta :: Term b)+            (_, _, App tw@Con {} _) ->+              case ( eqTypeRep tw (typeRep @WordN),+                     eqTypeRep tw (typeRep @IntN)+                   ) of+                (Just HRefl, _) -> someTerm (fromIntegralTerm ta :: Term b)+                (_, Just HRefl) -> someTerm (fromIntegralTerm ta :: Term b)+                _ -> err+            (_, _, App (App tw@Con {} _) _) ->+              case eqTypeRep tw (typeRep @FP) of+                Just HRefl -> someTerm (fromIntegralTerm ta :: Term b)+                _ -> err+            _ -> err+  where+    err :: SomeTerm+    err =+      error $+        "constructFromIntegralTerm: unsupported type: "+          <> show (primTypeRep @a)+          <> show retType++constructFromIntegralTerm ::+  (HasCallStack) => SomeTerm -> KnownType -> SomeTerm+constructFromIntegralTerm (SomeTerm (t1 :: Term a)) retType =+  withPrim @a $+    case (eqTypeRep tra (typeRep @Integer), tra) of+      (Just HRefl, _) -> constructFromIntegralTerm' t1 retType+      (_, App (trbv :: TypeRep bv) _) ->+        case ( eqTypeRep trbv (typeRep @WordN),+               eqTypeRep trbv (typeRep @IntN)+             ) of+          (Just HRefl, _) -> constructFromIntegralTerm' t1 retType+          (_, Just HRefl) -> constructFromIntegralTerm' t1 retType+          _ -> err+      _ -> err+  where+    tra = primTypeRep @a+    err :: SomeTerm+    err = error $ "constructFromIntegralTerm: unsupported type: " <> show tra++knownTypeTermId :: Term a -> (KnownType, Id)+knownTypeTermId t@SupportedTerm = (knownType t, termId t)++statefulDeserializeSomeTerm ::+  (MonadGet m) =>+  StateT (HM.HashMap (KnownType, Id) SomeTerm, SomeTerm) m SomeTerm+statefulDeserializeSomeTerm = do+  r <- do+    ktTmId <- deserialize+    tag <- getWord8+    if+      | tag == conTermTag -> do+          knownType <- deserializeKnownType+          case witnessKnownType knownType of+            KnownTypeWitness (Proxy :: Proxy a) -> do+              tm <- someTerm . conTerm <$> deserialize @a+              return $ Just (tm, ktTmId)+      | tag == symTermTag -> do+          SomeTypedSymbol sb <- deserialize @SomeTypedAnySymbol+          return $ Just (someTerm $ symTerm sb, ktTmId)+      | tag == forallTermTag -> deserializeQuantified ktTmId forallTerm+      | tag == existsTermTag -> deserializeQuantified ktTmId existsTerm+      | tag == notTermTag -> do+          t <- deserializeTerm+          return $ Just (someTerm $ notTerm $ asBoolTerm t, ktTmId)+      | tag == orTermTag -> deserializeBoolBinary ktTmId orTerm+      | tag == andTermTag -> deserializeBoolBinary ktTmId andTerm+      | tag == eqTermTag -> do+          SomeTerm t1' <- deserializeTerm+          t2 <- deserializeTerm+          asSameType t1' t2 $ \t2' ->+            return $ Just (someTerm $ eqTerm t1' t2', ktTmId)+      | tag == distinctTermTag -> do+          ts <- deserializeNonEmptyTermList+          asSameTypeNonEmptyTermList ts $ \ts' ->+            return $ Just (someTerm $ distinctTerm ts', ktTmId)+      | tag == iteTermTag -> do+          t1 <- deserializeTerm+          SomeTerm t2' <- deserializeTerm+          t3 <- deserializeTerm+          asSameType t2' t3 $ \t3' ->+            return $ Just (someTerm $ iteTerm (asBoolTerm t1) t2' t3', ktTmId)+      | tag == addNumTermTag -> deserializeNumBinary ktTmId addNumTerm+      | tag == negNumTermTag -> deserializeNumUnary ktTmId negNumTerm+      | tag == mulNumTermTag -> deserializeNumBinary ktTmId mulNumTerm+      | tag == absNumTermTag -> deserializeNumUnary ktTmId absNumTerm+      | tag == signumNumTermTag -> deserializeNumUnary ktTmId signumNumTerm+      | tag == ltOrdTermTag -> deserializeOrdBinary ktTmId ltOrdTerm+      | tag == leOrdTermTag -> deserializeOrdBinary ktTmId leOrdTerm+      | tag == andBitsTermTag -> deserializeBitsBinary ktTmId andBitsTerm+      | tag == orBitsTermTag -> deserializeBitsBinary ktTmId orBitsTerm+      | tag == xorBitsTermTag -> deserializeBitsBinary ktTmId xorBitsTerm+      | tag == complementBitsTermTag ->+          deserializeBitsUnary ktTmId complementBitsTerm+      | tag == shiftLeftTermTag -> deserializeBitsBinary ktTmId shiftLeftTerm+      | tag == shiftRightTermTag -> deserializeBitsBinary ktTmId shiftRightTerm+      | tag == rotateLeftTermTag -> deserializeBitsBinary ktTmId rotateLeftTerm+      | tag == rotateRightTermTag -> deserializeBitsBinary ktTmId rotateRightTerm+      | tag == bitCastTermTag -> do+          kt <- deserializeKnownType+          t1 <- deserializeTerm+          return $ Just (constructBitCastTerm t1 kt, ktTmId)+      | tag == bitCastOrTermTag -> do+          td <- deserializeTerm+          tv <- deserializeTerm+          return $ Just (constructBitCastOrTerm td tv, ktTmId)+      | tag == bvConcatTermTag -> do+          t1 <- deserializeTerm+          t2 <- deserializeTerm+          return $ Just (constructBVConcatTerm t1 t2, ktTmId)+      | tag == bvSelectTermTag -> do+          ix <- deserialize @Natural+          w <- deserialize @Natural+          t1 <- deserializeTerm+          return $ Just (constructBVSelectTerm ix w t1, ktTmId)+      | tag == bvExtendTermTag -> do+          signed <- deserialize @Bool+          r <- deserialize @Natural+          t1 <- deserializeTerm+          return $ Just (constructBVExtendTerm signed r t1, ktTmId)+      | tag == applyTermTag -> do+          tf <- deserializeTerm+          ta <- deserializeTerm+          return $ Just (constructApplyTerm tf ta, ktTmId)+      | tag == divIntegralTermTag ->+          deserializeIntegralBinary ktTmId divIntegralTerm+      | tag == modIntegralTermTag ->+          deserializeIntegralBinary ktTmId modIntegralTerm+      | tag == quotIntegralTermTag ->+          deserializeIntegralBinary ktTmId quotIntegralTerm+      | tag == remIntegralTermTag ->+          deserializeIntegralBinary ktTmId remIntegralTerm+      | tag == terminalTag -> return Nothing+      | tag == fpTraitTermTag -> do+          trait <- deserialize @FPTrait+          t <- deserializeTerm+          asFPTypeTerm t $ \t' ->+            return $ Just (someTerm $ fpTraitTerm trait t', ktTmId)+      | tag == fdivTermTag -> do+          t1 <- deserializeTerm+          t2 <- deserializeTerm+          asFloatingFractionalTypeTerm t1 $ \t1' -> asSameType t1' t2 $ \t2' ->+            return $ Just (someTerm $ fdivTerm t1' t2', ktTmId)+      | tag == recipTermTag -> do+          t <- deserializeTerm+          asFloatingFractionalTypeTerm t $ \t' ->+            return $ Just (someTerm $ recipTerm t', ktTmId)+      | tag == floatingUnaryTermTag -> do+          op <- deserialize+          t <- deserializeTerm+          asFloatingFractionalTypeTerm t $ \t' ->+            return $ Just (someTerm $ floatingUnaryTerm op t', ktTmId)+      | tag == powerTermTag -> do+          t1 <- deserializeTerm+          t2 <- deserializeTerm+          asFloatingFractionalTypeTerm t1 $ \t1' -> asSameType t1' t2 $ \t2' ->+            return $ Just (someTerm $ powerTerm t1' t2', ktTmId)+      | tag == fpUnaryTermTag -> do+          op <- deserialize @FPUnaryOp+          t <- deserializeTerm+          asFPTypeTerm t $ \t' ->+            return $ Just (someTerm $ fpUnaryTerm op t', ktTmId)+      | tag == fpBinaryTermTag -> do+          op <- deserialize @FPBinaryOp+          t1 <- deserializeTerm+          t2 <- deserializeTerm+          asFPTypeTerm t1 $ \t1' -> asSameType t1' t2 $ \t2' ->+            return $ Just (someTerm $ fpBinaryTerm op t1' t2', ktTmId)+      | tag == fpRoundingUnaryTermTag -> do+          op <- deserialize @FPRoundingUnaryOp+          trd <- deserializeTerm+          t <- deserializeTerm+          asFPRoundingTerm trd $ \trd' ->+            asFPTypeTerm t $ \t' ->+              return $ Just (someTerm $ fpRoundingUnaryTerm op trd' t', ktTmId)+      | tag == fpRoundingBinaryTermTag -> do+          op <- deserialize @FPRoundingBinaryOp+          trd <- deserializeTerm+          t1 <- deserializeTerm+          t2 <- deserializeTerm+          asFPRoundingTerm trd $ \trd' ->+            asFPTypeTerm t1 $ \t1' -> asSameType t1' t2 $ \t2' ->+              return $+                Just (someTerm $ fpRoundingBinaryTerm op trd' t1' t2', ktTmId)+      | tag == fpFMATermTag -> do+          trd <- deserializeTerm+          t1 <- deserializeTerm+          t2 <- deserializeTerm+          t3 <- deserializeTerm+          asFPRoundingTerm trd $ \trd' -> asFPTypeTerm t1 $ \t1' ->+            asSameType t1' t2 $ \t2' -> asSameType t1' t3 $ \t3' ->+              return $ Just (someTerm $ fpFMATerm trd' t1' t2' t3', ktTmId)+      | tag == fromIntegralTermTag -> do+          kt <- deserializeKnownType+          t <- deserializeTerm+          return $ Just (constructFromIntegralTerm t kt, ktTmId)+      | tag == fromFPOrTermTag -> do+          td <- deserializeTerm+          trd <- deserializeTerm+          tt <- deserializeTerm+          asNumTypeTerm td $ \td' -> asFPRoundingTerm trd $ \trd' ->+            asFPTypeTerm tt $ \tt' ->+              return $ Just (someTerm $ fromFPOrTerm td' trd' tt', ktTmId)+      | tag == toFPTermTag -> do+          eb <- deserialize @Natural+          sb <- deserialize @Natural+          trd <- deserializeTerm+          tt <- deserializeTerm+          if checkDynamicValidFP eb sb+            then case (mkNatRepr eb, mkNatRepr sb) of+              ( SomeNatRepr (_ :: NatRepr eb),+                SomeNatRepr (_ :: NatRepr sb)+                ) ->+                  withUnsafeValidFP @eb @sb $+                    asFPRoundingTerm trd $ \trd' -> asNumTypeTerm tt $ \tt' ->+                      return $+                        Just+                          ( someTerm (toFPTerm trd' tt' :: Term (FP eb sb)),+                            ktTmId+                          )+            else error "statefulDeserializeSomeTerm: invalid FP type"+      | otherwise ->+          error $ "statefulDeserializeSomeTerm: unknown tag: " <> show tag+  case r of+    Just (tm, ktTmId) -> do+      State.modify' $ \(m, _) -> (HM.insert ktTmId tm m, tm)+      statefulDeserializeSomeTerm+    Nothing -> State.gets snd+  where+    deserializeNonEmptyTermList ::+      (MonadGet m) =>+      StateT+        (HM.HashMap (KnownType, Id) SomeTerm, SomeTerm)+        m+        (NonEmpty SomeTerm)+    deserializeNonEmptyTermList = do+      ids <- deserialize @[(KnownType, Id)]+      case ids of+        [] -> fail "statefulDeserializeSomeTerm: empty list"+        (x : xs) -> do+          x' <- queryTerm x+          xs' <- traverse queryTerm xs+          return $ x' :| xs'+    deserializeTerm ::+      (MonadGet m) =>+      StateT (HM.HashMap (KnownType, Id) SomeTerm, SomeTerm) m SomeTerm+    deserializeTerm = do+      ktTmId <- deserialize+      queryTerm ktTmId+    queryTerm ::+      (MonadGet m) =>+      (KnownType, Id) ->+      StateT (HM.HashMap (KnownType, Id) SomeTerm, SomeTerm) m SomeTerm+    queryTerm ktTmId = do+      tm <- State.gets $ HM.lookup ktTmId . fst+      case tm of+        Nothing -> fail "statefulDeserializeSomeTerm: unknown term id"+        Just tm' -> return tm'+    deserializeBoolBinary tmId f = do+      t1 <- deserializeTerm+      t2 <- deserializeTerm+      return $+        Just (someTerm $ f (asBoolTerm t1) (asBoolTerm t2), tmId)+    deserializeQuantified+      tmId+      (f :: forall t. TypedConstantSymbol t -> Term Bool -> Term Bool) = do+        SomeTypedSymbol sb <- deserialize+        t <- deserializeTerm+        return $ Just (someTerm $ f sb $ asBoolTerm t, tmId)+    deserializeNumUnary+      tmId+      (f :: forall t. (PEvalNumTerm t) => Term t -> Term t) = do+        t1 <- deserializeTerm+        asNumTypeTerm t1 $ \t1' -> return $ Just (someTerm $ f t1', tmId)+    deserializeBitsUnary+      tmId+      (f :: forall t. (PEvalBitwiseTerm t) => Term t -> Term t) = do+        t1 <- deserializeTerm+        asBitsTypeTerm t1 $ \t1' -> return $ Just (someTerm $ f t1', tmId)+    deserializeNumBinary+      tmId+      (f :: forall t. (PEvalNumTerm t) => Term t -> Term t -> Term t) = do+        t1 <- deserializeTerm+        t2 <- deserializeTerm+        asNumTypeTerm t1 $ \t1' -> asSameType t1' t2 $ \t2' ->+          return $ Just (someTerm $ f t1' t2', tmId)+    deserializeOrdBinary+      tmId+      (f :: forall t. (PEvalOrdTerm t) => Term t -> Term t -> Term Bool) = do+        t1 <- deserializeTerm+        t2 <- deserializeTerm+        asOrdTypeTerm t1 $ \t1' -> asSameType t1' t2 $ \t2' ->+          return $ Just (someTerm $ f t1' t2', tmId)+    deserializeBitsBinary+      tmId+      ( f ::+          forall t.+          ( PEvalBitwiseTerm t,+            PEvalShiftTerm t,+            PEvalRotateTerm t+          ) =>+          Term t ->+          Term t ->+          Term t+        ) = do+        t1 <- deserializeTerm+        t2 <- deserializeTerm+        asBitsTypeTerm t1 $ \t1' -> asSameType t1' t2 $ \t2' ->+          return $ Just (someTerm $ f t1' t2', tmId)+    deserializeIntegralBinary+      tmId+      ( f ::+          forall t.+          (PEvalDivModIntegralTerm t) =>+          Term t ->+          Term t ->+          Term t+        ) = do+        t1 <- deserializeTerm+        t2 <- deserializeTerm+        asIntegralTypeTerm t1 $ \t1' -> asSameType t1' t2 $ \t2' ->+          return $ Just (someTerm $ f t1' t2', tmId)++deserializeSomeTerm :: (MonadGet m) => m SomeTerm+deserializeSomeTerm =+  evalStateT+    statefulDeserializeSomeTerm+    ( HM.empty,+      error $+        "deserializeSomeTerm: should not happen: started with the terminal "+          <> "value"+    )++serializeSingleSomeTerm ::+  (MonadPut m) => SomeTerm -> StateT (HS.HashSet (KnownType, Id)) m ()+serializeSingleSomeTerm (SomeTerm (tm :: Term t)) = do+  st <- State.get+  let kt = knownType tm+  let tmId = termId tm+  let ktTmId = (kt, tmId)+  if HS.member ktTmId st+    then return ()+    else do+      case tm of+        ConTerm (v :: v) -> do+          serialize ktTmId+          putWord8 conTermTag+          let kt = knownType (Proxy @v)+          case witnessKnownType kt of+            KnownTypeWitness (Proxy :: Proxy v1) ->+              case eqTypeRep (primTypeRep @v) (typeRep @v1) of+                Just HRefl -> do+                  serializeKnownType kt+                  serialize v+                Nothing ->+                  error+                    "serializeSingleSomeTerm: should not happen: type mismatch"+        SymTerm (v :: TypedAnySymbol v) -> do+          serialize ktTmId+          putWord8 symTermTag+          serialize $ someTypedSymbol v+        ForallTerm ts t -> serializeQuantified ktTmId forallTermTag ts t+        ExistsTerm ts t -> serializeQuantified ktTmId existsTermTag ts t+        NotTerm t -> do+          serializeSingleSomeTerm $ someTerm t+          serialize ktTmId+          putWord8 notTermTag+          serialize $ knownTypeTermId t+        OrTerm t1 t2 -> serializeBinary ktTmId orTermTag t1 t2+        AndTerm t1 t2 -> serializeBinary ktTmId andTermTag t1 t2+        EqTerm t1 t2 -> serializeBinary ktTmId eqTermTag t1 t2+        DistinctTerm ts -> do+          traverse_ (serializeSingleSomeTerm . someTerm) ts+          serialize ktTmId+          putWord8 distinctTermTag+          serialize $ fmap knownTypeTermId ts+        ITETerm t1 t2 t3 -> serializeTernary ktTmId iteTermTag t1 t2 t3+        AddNumTerm t1 t2 -> serializeBinary ktTmId addNumTermTag t1 t2+        NegNumTerm t -> serializeUnary ktTmId negNumTermTag t+        MulNumTerm t1 t2 -> serializeBinary ktTmId mulNumTermTag t1 t2+        AbsNumTerm t -> serializeUnary ktTmId absNumTermTag t+        SignumNumTerm t -> serializeUnary ktTmId signumNumTermTag t+        LtOrdTerm t1 t2 -> serializeBinary ktTmId ltOrdTermTag t1 t2+        LeOrdTerm t1 t2 -> serializeBinary ktTmId leOrdTermTag t1 t2+        AndBitsTerm t1 t2 -> serializeBinary ktTmId andBitsTermTag t1 t2+        OrBitsTerm t1 t2 -> serializeBinary ktTmId orBitsTermTag t1 t2+        XorBitsTerm t1 t2 -> serializeBinary ktTmId xorBitsTermTag t1 t2+        ComplementBitsTerm t ->+          serializeUnary ktTmId complementBitsTermTag t+        ShiftLeftTerm t1 t2 ->+          serializeBinary ktTmId shiftLeftTermTag t1 t2+        ShiftRightTerm t1 t2 ->+          serializeBinary ktTmId shiftRightTermTag t1 t2+        RotateLeftTerm t1 t2 ->+          serializeBinary ktTmId rotateLeftTermTag t1 t2+        RotateRightTerm t1 t2 ->+          serializeBinary ktTmId rotateRightTermTag t1 t2+        BitCastTerm t -> do+          serializeSingleSomeTerm $ someTerm t+          serialize ktTmId+          serialize bitCastTermTag+          let kt = knownType (Proxy @t)+          serializeKnownType kt+          serialize $ knownTypeTermId t+        BitCastOrTerm d t -> serializeBinary ktTmId bitCastOrTermTag d t+        BVConcatTerm t1 t2 -> serializeBinary ktTmId bvConcatTermTag t1 t2+        BVSelectTerm ix w t -> do+          serializeSingleSomeTerm $ someTerm t+          serialize ktTmId+          serialize bvSelectTermTag+          serialize $ natVal ix+          serialize $ natVal w+          serialize $ knownTypeTermId t+        BVExtendTerm signed r t -> do+          serializeSingleSomeTerm $ someTerm t+          serialize ktTmId+          serialize bvExtendTermTag+          serialize signed+          serialize $ natVal r+          serialize $ knownTypeTermId t+        ApplyTerm f ts -> serializeBinary ktTmId applyTermTag f ts+        DivIntegralTerm t1 t2 ->+          serializeBinary ktTmId divIntegralTermTag t1 t2+        ModIntegralTerm t1 t2 ->+          serializeBinary ktTmId modIntegralTermTag t1 t2+        QuotIntegralTerm t1 t2 ->+          serializeBinary ktTmId quotIntegralTermTag t1 t2+        RemIntegralTerm t1 t2 ->+          serializeBinary ktTmId remIntegralTermTag t1 t2+        FPTraitTerm trait t -> do+          serializeSingleSomeTerm $ someTerm t+          serialize ktTmId+          serialize fpTraitTermTag+          serialize trait+          serialize $ knownTypeTermId t+        FdivTerm t1 t2 -> serializeBinary ktTmId fdivTermTag t1 t2+        RecipTerm t -> serializeUnary ktTmId recipTermTag t+        FloatingUnaryTerm op t -> do+          serializeSingleSomeTerm $ someTerm t+          serialize ktTmId+          serialize floatingUnaryTermTag+          serialize op+          serialize $ knownTypeTermId t+        PowerTerm t1 t2 -> serializeBinary ktTmId powerTermTag t1 t2+        FPUnaryTerm op t -> do+          serializeSingleSomeTerm $ someTerm t+          serialize ktTmId+          serialize fpUnaryTermTag+          serialize op+          serialize $ knownTypeTermId t+        FPBinaryTerm op t1 t2 -> do+          serializeSingleSomeTerm $ someTerm t1+          serializeSingleSomeTerm $ someTerm t2+          serialize ktTmId+          serialize fpBinaryTermTag+          serialize op+          serialize $ knownTypeTermId t1+          serialize $ knownTypeTermId t2+        FPRoundingUnaryTerm op rd t -> do+          serializeSingleSomeTerm $ someTerm rd+          serializeSingleSomeTerm $ someTerm t+          serialize ktTmId+          serialize fpRoundingUnaryTermTag+          serialize op+          serialize $ knownTypeTermId rd+          serialize $ knownTypeTermId t+        FPRoundingBinaryTerm op rd t1 t2 -> do+          serializeSingleSomeTerm $ someTerm rd+          serializeSingleSomeTerm $ someTerm t1+          serializeSingleSomeTerm $ someTerm t2+          serialize ktTmId+          serialize fpRoundingBinaryTermTag+          serialize op+          serialize $ knownTypeTermId rd+          serialize $ knownTypeTermId t1+          serialize $ knownTypeTermId t2+        FPFMATerm rd t1 t2 t3 -> do+          serializeSingleSomeTerm $ someTerm rd+          serializeSingleSomeTerm $ someTerm t1+          serializeSingleSomeTerm $ someTerm t2+          serializeSingleSomeTerm $ someTerm t3+          serialize ktTmId+          serialize fpFMATermTag+          serialize $ knownTypeTermId rd+          serialize $ knownTypeTermId t1+          serialize $ knownTypeTermId t2+          serialize $ knownTypeTermId t3+        FromIntegralTerm t -> do+          serializeSingleSomeTerm $ someTerm t+          serialize ktTmId+          serialize fromIntegralTermTag+          let kt = knownType (Proxy @t)+          serializeKnownType kt+          serialize $ knownTypeTermId t+        FromFPOrTerm d rd t ->+          serializeTernary ktTmId fromFPOrTermTag d rd t+        ToFPTerm rd t eb sb -> do+          serializeSingleSomeTerm $ someTerm rd+          serializeSingleSomeTerm $ someTerm t+          serialize ktTmId+          serialize toFPTermTag+          serialize $ natVal eb+          serialize $ natVal sb+          serialize $ knownTypeTermId rd+          serialize $ knownTypeTermId t+  State.put $ HS.insert ktTmId st+  where+    serializeQuantified ::+      (MonadPut m) =>+      (KnownType, Id) ->+      Word8 ->+      TypedConstantSymbol v ->+      Term b ->+      StateT (HS.HashSet (KnownType, Id)) m ()+    serializeQuantified ktTmId tag v t = do+      serializeSingleSomeTerm $ someTerm t+      serialize ktTmId+      serialize tag+      serialize $ someTypedSymbol v+      serialize $ knownTypeTermId t+    serializeUnary ktTmId tag t1 = do+      serializeSingleSomeTerm $ someTerm t1+      serialize ktTmId+      serialize tag+      serialize $ knownTypeTermId t1+    serializeBinary ktTmId tag t1 t2 = do+      serializeSingleSomeTerm $ someTerm t1+      serializeSingleSomeTerm $ someTerm t2+      serialize ktTmId+      serialize tag+      serialize $ knownTypeTermId t1+      serialize $ knownTypeTermId t2+    serializeTernary ktTmId tag t1 t2 t3 = do+      serializeSingleSomeTerm $ someTerm t1+      serializeSingleSomeTerm $ someTerm t2+      serializeSingleSomeTerm $ someTerm t3+      serialize ktTmId+      serialize tag+      serialize $ knownTypeTermId t1+      serialize $ knownTypeTermId t2+      serialize $ knownTypeTermId t3++serializeSomeTerm :: (MonadPut m) => SomeTerm -> m ()+serializeSomeTerm t = do+  flip evalStateT HS.empty $ serializeSingleSomeTerm t+  serialize (NonFuncType BoolType, 0 :: Id)+  putWord8 terminalTag++instance Serial SomeTerm where+  serialize = serializeSomeTerm+  deserialize = deserializeSomeTerm++instance Cereal.Serialize SomeTerm where+  put = serializeSomeTerm+  get = deserializeSomeTerm++instance Binary.Binary SomeTerm where+  put = serializeSomeTerm+  get = deserializeSomeTerm++instance (SupportedPrim a) => Serial (Term a) where+  serialize = serializeSomeTerm . someTerm+  deserialize = do+    SomeTerm tm <- deserialize+    case castTerm tm of+      Just r -> return r+      Nothing -> fail "deserialize Term: type mismatch"++instance (SupportedPrim a) => Cereal.Serialize (Term a) where+  put = serialize+  get = deserialize++instance (SupportedPrim a) => Binary.Binary (Term a) where+  put = serialize+  get = deserialize++instance Serial ModelValue where+  serialize (ModelValue (v :: v)) = do+    let kt = knownType (Proxy @v)+    serializeKnownType kt+    case witnessKnownType kt of+      KnownTypeWitness (Proxy :: Proxy v1) ->+        case eqTypeRep (primTypeRep @v) (typeRep @v1) of+          Just HRefl -> serialize v+          Nothing ->+            error+              "serialize ModelValue: should not happen: type mismatch"+  deserialize = do+    kt <- deserializeKnownType+    case witnessKnownType kt of+      KnownTypeWitness (Proxy :: Proxy v) -> do+        v <- deserialize @v+        return $ ModelValue v++instance Cereal.Serialize ModelValue where+  put = serialize+  get = deserialize++instance Binary.Binary ModelValue where+  put = serialize+  get = deserialize++instance (GeneralFunArg a, GeneralFunArg b) => Serial (a --> b) where+  serialize (GeneralFun ts tm) = serialize ts >> serialize tm+  deserialize = GeneralFun <$> deserialize <*> deserialize++instance (GeneralFunArg a, GeneralFunArg b) => Cereal.Serialize (a --> b) where+  put = serialize+  get = deserialize++instance (GeneralFunArg a, GeneralFunArg b) => Binary.Binary (a --> b) where+  put = serialize+  get = deserialize++type GeneralFunArg t = (SupportedNonFuncPrim t, Typeable t, Show t, Hashable t)++instance+  {-# OVERLAPPING #-}+  (GeneralFunArg a, GeneralFunArg b, GeneralFunArg c) =>+  Serial (a --> b --> c)+  where+  serialize (GeneralFun ts tm) = serialize ts >> serialize tm+  deserialize = GeneralFun <$> deserialize <*> deserialize++instance+  {-# OVERLAPPING #-}+  (GeneralFunArg a, GeneralFunArg b, GeneralFunArg c) =>+  Cereal.Serialize (a --> b --> c)+  where+  put = serialize+  get = deserialize++instance+  {-# OVERLAPPING #-}+  (GeneralFunArg a, GeneralFunArg b, GeneralFunArg c) =>+  Binary.Binary (a --> b --> c)+  where+  put = serialize+  get = deserialize++instance+  {-# OVERLAPPING #-}+  (GeneralFunArg a, GeneralFunArg b, GeneralFunArg c, GeneralFunArg d) =>+  Serial (a --> b --> c --> d)+  where+  serialize (GeneralFun ts tm) = serialize ts >> serialize tm+  deserialize = GeneralFun <$> deserialize <*> deserialize++instance+  {-# OVERLAPPING #-}+  (GeneralFunArg a, GeneralFunArg b, GeneralFunArg c, GeneralFunArg d) =>+  Cereal.Serialize (a --> b --> c --> d)+  where+  put = serialize+  get = deserialize++instance+  {-# OVERLAPPING #-}+  (GeneralFunArg a, GeneralFunArg b, GeneralFunArg c, GeneralFunArg d) =>+  Binary.Binary (a --> b --> c --> d)+  where+  put = serialize+  get = deserialize++instance+  {-# OVERLAPPING #-}+  ( GeneralFunArg a,+    GeneralFunArg b,+    GeneralFunArg c,+    GeneralFunArg d,+    GeneralFunArg e+  ) =>+  Serial (a --> b --> c --> d --> e)+  where+  serialize (GeneralFun ts tm) = serialize ts >> serialize tm+  deserialize = GeneralFun <$> deserialize <*> deserialize++instance+  {-# OVERLAPPING #-}+  ( GeneralFunArg a,+    GeneralFunArg b,+    GeneralFunArg c,+    GeneralFunArg d,+    GeneralFunArg e+  ) =>+  Cereal.Serialize (a --> b --> c --> d --> e)+  where+  put = serialize+  get = deserialize++instance+  {-# OVERLAPPING #-}+  ( GeneralFunArg a,+    GeneralFunArg b,+    GeneralFunArg c,+    GeneralFunArg d,+    GeneralFunArg e+  ) =>+  Binary.Binary (a --> b --> c --> d --> e)+  where+  put = serialize+  get = deserialize++instance+  {-# OVERLAPPING #-}+  ( GeneralFunArg a,+    GeneralFunArg b,+    GeneralFunArg c,+    GeneralFunArg d,+    GeneralFunArg e,+    GeneralFunArg f+  ) =>+  Serial (a --> b --> c --> d --> e --> f)+  where+  serialize (GeneralFun ts tm) = serialize ts >> serialize tm+  deserialize = GeneralFun <$> deserialize <*> deserialize++instance+  {-# OVERLAPPING #-}+  ( GeneralFunArg a,+    GeneralFunArg b,+    GeneralFunArg c,+    GeneralFunArg d,+    GeneralFunArg e,+    GeneralFunArg f+  ) =>+  Cereal.Serialize (a --> b --> c --> d --> e --> f)+  where+  put = serialize+  get = deserialize++instance+  {-# OVERLAPPING #-}+  ( GeneralFunArg a,+    GeneralFunArg b,+    GeneralFunArg c,+    GeneralFunArg d,+    GeneralFunArg e,+    GeneralFunArg f+  ) =>+  Binary.Binary (a --> b --> c --> d --> e --> f)+  where+  put = serialize+  get = deserialize++instance+  {-# OVERLAPPING #-}+  ( GeneralFunArg a,+    GeneralFunArg b,+    GeneralFunArg c,+    GeneralFunArg d,+    GeneralFunArg e,+    GeneralFunArg f,+    GeneralFunArg g+  ) =>+  Serial (a --> b --> c --> d --> e --> f --> g)+  where+  serialize (GeneralFun ts tm) = serialize ts >> serialize tm+  deserialize = GeneralFun <$> deserialize <*> deserialize++instance+  {-# OVERLAPPING #-}+  ( GeneralFunArg a,+    GeneralFunArg b,+    GeneralFunArg c,+    GeneralFunArg d,+    GeneralFunArg e,+    GeneralFunArg f,+    GeneralFunArg g+  ) =>+  Cereal.Serialize (a --> b --> c --> d --> e --> f --> g)+  where+  put = serialize+  get = deserialize++instance+  {-# OVERLAPPING #-}+  ( GeneralFunArg a,+    GeneralFunArg b,+    GeneralFunArg c,+    GeneralFunArg d,+    GeneralFunArg e,+    GeneralFunArg f,+    GeneralFunArg g+  ) =>+  Binary.Binary (a --> b --> c --> d --> e --> f --> g)+  where+  put = serialize+  get = deserialize++instance+  {-# OVERLAPPING #-}+  ( GeneralFunArg a,+    GeneralFunArg b,+    GeneralFunArg c,+    GeneralFunArg d,+    GeneralFunArg e,+    GeneralFunArg f,+    GeneralFunArg g,+    GeneralFunArg h+  ) =>+  Serial (a --> b --> c --> d --> e --> f --> g --> h)+  where+  serialize (GeneralFun ts tm) = serialize ts >> serialize tm+  deserialize = GeneralFun <$> deserialize <*> deserialize++instance+  {-# OVERLAPPING #-}+  ( GeneralFunArg a,+    GeneralFunArg b,+    GeneralFunArg c,+    GeneralFunArg d,+    GeneralFunArg e,+    GeneralFunArg f,+    GeneralFunArg g,+    GeneralFunArg h+  ) =>+  Cereal.Serialize (a --> b --> c --> d --> e --> f --> g --> h)+  where+  put = serialize+  get = deserialize++instance+  {-# OVERLAPPING #-}+  ( GeneralFunArg a,+    GeneralFunArg b,+    GeneralFunArg c,+    GeneralFunArg d,+    GeneralFunArg e,+    GeneralFunArg f,+    GeneralFunArg g,+    GeneralFunArg h+  ) =>+  Binary.Binary (a --> b --> c --> d --> e --> f --> g --> h)+  where+  put = serialize+  get = deserialize++instance+  {-# OVERLAPPING #-}+  ( GeneralFunArg a,+    GeneralFunArg b,+    GeneralFunArg c,+    GeneralFunArg d,+    GeneralFunArg e,+    GeneralFunArg f,+    GeneralFunArg g,+    GeneralFunArg h,+    GeneralFunArg i+  ) =>+  Serial (a --> b --> c --> d --> e --> f --> g --> h --> i)+  where+  serialize (GeneralFun ts tm) = serialize ts >> serialize tm+  deserialize = GeneralFun <$> deserialize <*> deserialize++instance+  {-# OVERLAPPING #-}+  ( GeneralFunArg a,+    GeneralFunArg b,+    GeneralFunArg c,+    GeneralFunArg d,+    GeneralFunArg e,+    GeneralFunArg f,+    GeneralFunArg g,+    GeneralFunArg h,+    GeneralFunArg i+  ) =>+  Cereal.Serialize (a --> b --> c --> d --> e --> f --> g --> h --> i)+  where+  put = serialize+  get = deserialize++instance+  {-# OVERLAPPING #-}+  ( GeneralFunArg a,+    GeneralFunArg b,+    GeneralFunArg c,+    GeneralFunArg d,+    GeneralFunArg e,+    GeneralFunArg f,+    GeneralFunArg g,+    GeneralFunArg h,+    GeneralFunArg i+  ) =>+  Binary.Binary (a --> b --> c --> d --> e --> f --> g --> h --> i)+  where+  put = serialize+  get = deserialize
+ src/Grisette/Internal/SymPrim/Prim/Internal/Term.hs view
@@ -0,0 +1,8417 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveLift #-}+{-# HLINT ignore "Eta reduce" #-}+{-# HLINT ignore "Unused LANGUAGE pragma" #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE Strict #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}+{-# OPTIONS_GHC -funbox-strict-fields #-}++-- |+-- Module      :   Grisette.Internal.SymPrim.Prim.Internal.Term+-- 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.SymPrim.Prim.Internal.Term+  ( -- * Supported primitive types+    SupportedPrimConstraint (..),+    SupportedPrim (..),+    SymRep (..),+    ConRep (..),+    LinkedRep (..),++    -- * Partial evaluation for the terms+    PEvalApplyTerm (..),+    PEvalBitwiseTerm (..),+    PEvalShiftTerm (..),+    PEvalRotateTerm (..),+    PEvalNumTerm (..),+    pevalSubNumTerm,+    PEvalOrdTerm (..),+    pevalGtOrdTerm,+    pevalGeOrdTerm,+    pevalNEqTerm,+    PEvalDivModIntegralTerm (..),+    PEvalBitCastTerm (..),+    PEvalBitCastOrTerm (..),+    PEvalBVTerm (..),+    PEvalFractionalTerm (..),+    PEvalFPTerm (..),+    PEvalFloatingTerm (..),+    PEvalFromIntegralTerm (..),+    PEvalIEEEFPConvertibleTerm (..),++    -- * Typed symbols+    SymbolKind (..),+    TypedSymbol (TypedSymbol, unTypedSymbol),+    typedConstantSymbol,+    typedAnySymbol,+    TypedConstantSymbol,+    TypedAnySymbol,+    SomeTypedSymbol (..),+    SomeTypedConstantSymbol,+    SomeTypedAnySymbol,+    IsSymbolKind (..),+    showUntyped,+    someTypedSymbol,+    eqHeteroSymbol,+    castSomeTypedSymbol,++    -- * Terms+    FPTrait (..),+    FPUnaryOp (..),+    FPBinaryOp (..),+    FPRoundingUnaryOp (..),+    FPRoundingBinaryOp (..),+    FloatingUnaryOp (..),+    Term (..),+    defaultValueDynamic,+    pattern DynTerm,+    toCurThread,+    CachedInfo (..),+    termInfo,+    termThreadId,+    termDigest,+    termId,+    termStableIdent,+    pformatTerm,+    ModelValue (..),+    toModelValue,+    unsafeFromModelValue,++    -- * Interning+    UTerm (..),+    prettyPrintTerm,++    -- * Interned constructors+    conTerm,+    symTerm,+    ssymTerm,+    isymTerm,+    forallTerm,+    existsTerm,+    notTerm,+    orTerm,+    andTerm,+    eqTerm,+    distinctTerm,+    iteTerm,+    addNumTerm,+    negNumTerm,+    mulNumTerm,+    absNumTerm,+    signumNumTerm,+    ltOrdTerm,+    leOrdTerm,+    andBitsTerm,+    orBitsTerm,+    xorBitsTerm,+    complementBitsTerm,+    shiftLeftTerm,+    rotateLeftTerm,+    shiftRightTerm,+    rotateRightTerm,+    bitCastTerm,+    bitCastOrTerm,+    bvConcatTerm,+    bvSelectTerm,+    bvExtendTerm,+    bvsignExtendTerm,+    bvzeroExtendTerm,+    applyTerm,+    divIntegralTerm,+    modIntegralTerm,+    quotIntegralTerm,+    remIntegralTerm,+    fpTraitTerm,+    fdivTerm,+    recipTerm,+    floatingUnaryTerm,+    powerTerm,+    fpUnaryTerm,+    fpBinaryTerm,+    fpRoundingUnaryTerm,+    fpRoundingBinaryTerm,+    fpFMATerm,+    fromIntegralTerm,+    fromFPOrTerm,+    toFPTerm,++    -- * Patterns+    pattern SupportedTerm,+    pattern SupportedTypedSymbol,+    pattern SupportedConstantTypedSymbol,+    pattern ConTerm,+    pattern SymTerm,+    pattern ForallTerm,+    pattern ExistsTerm,+    pattern NotTerm,+    pattern OrTerm,+    pattern AndTerm,+    pattern OrTermAll,+    pattern AndTermAll,+    pattern EqTerm,+    pattern DistinctTerm,+    pattern ITETerm,+    pattern AddNumTerm,+    pattern NegNumTerm,+    pattern MulNumTerm,+    pattern AbsNumTerm,+    pattern SignumNumTerm,+    pattern LtOrdTerm,+    pattern LeOrdTerm,+    pattern AndBitsTerm,+    pattern OrBitsTerm,+    pattern XorBitsTerm,+    pattern ComplementBitsTerm,+    pattern ShiftLeftTerm,+    pattern RotateLeftTerm,+    pattern ShiftRightTerm,+    pattern RotateRightTerm,+    pattern BitCastTerm,+    pattern BitCastOrTerm,+    pattern BVConcatTerm,+    pattern BVSelectTerm,+    pattern BVExtendTerm,+    pattern ApplyTerm,+    pattern DivIntegralTerm,+    pattern ModIntegralTerm,+    pattern QuotIntegralTerm,+    pattern RemIntegralTerm,+    pattern FPTraitTerm,+    pattern FdivTerm,+    pattern RecipTerm,+    pattern FloatingUnaryTerm,+    pattern PowerTerm,+    pattern FPUnaryTerm,+    pattern FPBinaryTerm,+    pattern FPRoundingUnaryTerm,+    pattern FPRoundingBinaryTerm,+    pattern FPFMATerm,+    pattern FromIntegralTerm,+    pattern FromFPOrTerm,+    pattern ToFPTerm,++    -- * Support for boolean type+    trueTerm,+    falseTerm,+    pattern BoolConTerm,+    pattern TrueTerm,+    pattern FalseTerm,+    pattern BoolTerm,+    pevalNotTerm,+    pevalOrTerm,+    pevalAndTerm,+    pevalImplyTerm,+    pevalXorTerm,+    pevalITEBasic,+    pevalITEBasicTerm,+    pevalDefaultEqTerm,+    NonFuncPrimConstraint,+    NonFuncSBVRep (..),+    SupportedNonFuncPrim (..),+    SBVRep (..),+    SBVFreshMonad (..),+    translateTypeError,+    parseSMTModelResultError,+    partitionCVArg,+    parseScalarSMTModelResult,+    bvIsNonZeroFromGEq1,++    -- * Partial evaluation+    PartialFun,+    PartialRuleUnary,+    TotalRuleUnary,+    PartialRuleBinary,+    TotalRuleBinary,+    totalize,+    totalize2,+    UnaryPartialStrategy (..),+    unaryPartial,+    BinaryCommPartialStrategy (..),+    BinaryPartialStrategy (..),+    binaryPartial,++    -- * Unfold+    unaryUnfoldOnce,+    binaryUnfoldOnce,+    generalUnaryUnfolded,+    generalBinaryUnfolded,++    -- * bv+    unsafePevalBVConcatTerm,+    unsafePevalBVExtendTerm,+    unsafePevalBVSelectTerm,+    boolToBVTerm,++    -- * num+    pevalDefaultAddNumTerm,+    pevalDefaultNegNumTerm,+    pevalDefaultMulNumTerm,+    pevalBitsAbsNumTerm,+    doPevalNoOverflowAbsNumTerm,+    pevalGeneralSignumNumTerm,+    doPevalNoOverflowSignumNumTerm,+  )+where++#if MIN_VERSION_prettyprinter(1,7,0)+import Prettyprinter+  ( column,+    pageWidth,+    Doc,+    PageWidth(Unbounded, AvailablePerLine),+    Pretty(pretty),+  )+#else+import Data.Text.Prettyprint.Doc+  ( column,+    pageWidth,+    Doc,+    PageWidth(Unbounded, AvailablePerLine),+    Pretty(pretty),+  )+#endif++#if !MIN_VERSION_sbv(10,0,0)+#define SMTDefinable Uninterpreted+#endif++#if MIN_VERSION_sbv(11,0,0)+import qualified Data.SBV as SBVTC+#endif++#if MIN_VERSION_base(4,15,0)+import Language.Haskell.TH (Code, Quote)+#else+import Language.Haskell.TH (TExpQ)+#endif++import Control.DeepSeq (NFData (rnf))+import Control.Monad (msum)+import Control.Monad.Except (MonadError (catchError))+import Control.Monad.IO.Class (MonadIO)+import qualified Control.Monad.RWS.Lazy as Lazy+import qualified Control.Monad.RWS.Strict as Strict+import Control.Monad.Reader (MonadTrans (lift), ReaderT)+import qualified Control.Monad.State.Lazy as Lazy+import qualified Control.Monad.State.Strict as Strict+import qualified Control.Monad.Writer.Lazy as Lazy+import qualified Control.Monad.Writer.Strict as Strict+import Data.Atomics (atomicModifyIORefCAS_)+import qualified Data.Binary as Binary+import Data.Bits+  ( Bits (complement, isSigned, xor, zeroBits, (.&.), (.|.)),+    FiniteBits (countLeadingZeros),+  )+import Data.Bytes.Serial (Serial (deserialize, serialize))+import Data.Coerce (coerce)+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS+import Data.Hashable (Hashable (hashWithSalt))+import Data.IORef (IORef, newIORef, readIORef)+import Data.Kind (Constraint, Type)+import Data.List.NonEmpty (NonEmpty ((:|)), toList)+import Data.Maybe (fromMaybe, isJust)+import Data.Proxy (Proxy (Proxy))+import Data.SBV (BVIsNonZero)+import qualified Data.SBV as SBV+import qualified Data.SBV.Dynamic as SBVD+import qualified Data.SBV.Trans as SBVT+import qualified Data.SBV.Trans.Control as SBVTC+import qualified Data.Serialize as Cereal+import Data.String (IsString (fromString))+import Data.Type.Equality ((:~:) (Refl), type (:~~:) (HRefl))+import Data.Typeable (Typeable, cast, typeRepFingerprint)+import GHC.Exts (Any, sortWith)+import GHC.Fingerprint (Fingerprint)+import GHC.Generics (Generic)+import GHC.IO (unsafePerformIO)+import GHC.Stack (HasCallStack)+import GHC.TypeNats (KnownNat, Nat, natVal, sameNat, type (+), type (-), type (<=))+import Grisette.Internal.Core.Data.Class.BitCast (BitCast (bitCast), BitCastOr)+import Grisette.Internal.Core.Data.Class.BitVector+  ( SizedBV+      ( sizedBVConcat,+        sizedBVFromIntegral,+        sizedBVSelect,+        sizedBVSext,+        sizedBVZext+      ),+  )+import Grisette.Internal.Core.Data.Class.IEEEFP+  ( fpIsNegativeZero,+    fpIsPositiveZero,+  )+import Grisette.Internal.Core.Data.Symbol+  ( Identifier,+    Symbol (IndexedSymbol, SimpleSymbol),+  )+import Grisette.Internal.SymPrim.AlgReal (AlgReal, fromSBVAlgReal, toSBVAlgReal)+import Grisette.Internal.SymPrim.BV (IntN, WordN)+import Grisette.Internal.SymPrim.FP+  ( FP (FP),+    FPRoundingMode (RNA, RNE, RTN, RTP, RTZ),+    ValidFP,+  )+import Grisette.Internal.SymPrim.Prim.Internal.Caches+  ( CachedInfo+      ( CachedInfo,+        cachedDigest,+        cachedId,+        cachedStableIdent,+        cachedThreadId+      ),+    Digest,+    Id,+    Interned+      ( Description,+        Uninterned,+        describe,+        descriptionDigest,+        identify,+        threadId+      ),+    StableIdent,+    intern,+  )+import Grisette.Internal.SymPrim.Prim.Internal.Utils+  ( WeakThreadId,+    myWeakThreadId,+  )+import Grisette.Internal.Utils.Parameterized+  ( LeqProof (LeqProof),+    NatRepr,+    SomeNatRepr (SomeNatRepr),+    SomePositiveNatRepr (SomePositiveNatRepr),+    addNat,+    mkNatRepr,+    mkPositiveNatRepr,+    natRepr,+    unsafeAxiom,+    unsafeKnownProof,+    unsafeLeqProof,+    withKnownNat,+    withKnownProof,+  )+import Language.Haskell.TH.Syntax (Lift (liftTyped))+import Type.Reflection+  ( SomeTypeRep (SomeTypeRep),+    TypeRep,+    eqTypeRep,+    someTypeRep,+    typeRep,+  )+import qualified Type.Reflection as R+import Unsafe.Coerce (unsafeCoerce)++-- $setup+-- >>> import Grisette.Core+-- >>> import Grisette.SymPrim++-- | Monads that supports generating sbv fresh variables.+class (MonadIO m) => SBVFreshMonad m where+  sbvFresh :: (SBV.SymVal a) => String -> m (SBV.SBV a)++instance (MonadIO m) => SBVFreshMonad (SBVT.SymbolicT m) where+  sbvFresh = SBVT.free+  {-# INLINE sbvFresh #-}++instance (MonadIO m) => SBVFreshMonad (SBVTC.QueryT m) where+  sbvFresh = SBVTC.freshVar+  {-# INLINE sbvFresh #-}++instance (SBVFreshMonad m) => SBVFreshMonad (ReaderT r m) where+  sbvFresh = lift . sbvFresh+  {-# INLINE sbvFresh #-}++instance (SBVFreshMonad m, Monoid w) => SBVFreshMonad (Lazy.WriterT w m) where+  sbvFresh = lift . sbvFresh+  {-# INLINE sbvFresh #-}++instance (SBVFreshMonad m, Monoid w) => SBVFreshMonad (Lazy.RWST r w s m) where+  sbvFresh = lift . sbvFresh+  {-# INLINE sbvFresh #-}++instance (SBVFreshMonad m) => SBVFreshMonad (Lazy.StateT s m) where+  sbvFresh = lift . sbvFresh+  {-# INLINE sbvFresh #-}++instance (SBVFreshMonad m, Monoid w) => SBVFreshMonad (Strict.WriterT w m) where+  sbvFresh = lift . sbvFresh+  {-# INLINE sbvFresh #-}++instance (SBVFreshMonad m, Monoid w) => SBVFreshMonad (Strict.RWST r w s m) where+  sbvFresh = lift . sbvFresh+  {-# INLINE sbvFresh #-}++instance (SBVFreshMonad m) => SBVFreshMonad (Strict.StateT s m) where+  sbvFresh = lift . sbvFresh+  {-# INLINE sbvFresh #-}++-- | Error message for unsupported types.+translateTypeError :: (HasCallStack) => Maybe String -> TypeRep a -> b+translateTypeError Nothing ta =+  error $+    "Don't know how to translate the type " ++ show ta ++ " to SMT"+translateTypeError (Just reason) ta =+  error $+    "Don't know how to translate the type " ++ show ta ++ " to SMT: " <> reason++-- | Type class for resolving the base type for the SBV type for the primitive+-- type.+class+  ( SupportedPrim a,+    Ord a,+    Eq a,+    Show a,+    Hashable a,+    Typeable a+  ) =>+  NonFuncSBVRep a+  where+  type NonFuncSBVBaseType a++-- | Type class for resolving the constraint for a supported non-function+-- primitive type.+type NonFuncPrimConstraint a =+  ( SBV.SymVal (NonFuncSBVBaseType a),+    SBV.EqSymbolic (SBVType a),+    SBV.Mergeable (SBVType a),+    SBV.SMTDefinable (SBVType a),+    SBV.Mergeable (SBVType a),+    SBVType a ~ SBV.SBV (NonFuncSBVBaseType a),+    PrimConstraint a+  )++-- | Indicates that a type is supported, can be represented as a symbolic term,+-- is not a function type, and can be lowered to an SBV term.+class (NonFuncSBVRep a) => SupportedNonFuncPrim a where+  conNonFuncSBVTerm :: a -> SBV.SBV (NonFuncSBVBaseType a)+  symNonFuncSBVTerm ::+    (SBVFreshMonad m) => String -> m (SBV.SBV (NonFuncSBVBaseType a))+  withNonFuncPrim :: ((NonFuncPrimConstraint a) => r) -> r++-- | Partition the list of CVs for models for functions.+partitionCVArg ::+  forall a.+  (SupportedNonFuncPrim a) =>+  [([SBVD.CV], SBVD.CV)] ->+  [(a, [([SBVD.CV], SBVD.CV)])]+partitionCVArg cv =+  partitionOrdCVArg $+    parseFirstCVArg cv+  where+    parseFirstCVArg ::+      forall a.+      (SupportedNonFuncPrim a) =>+      [([SBVD.CV], SBVD.CV)] ->+      [(a, [([SBVD.CV], SBVD.CV)])]+    parseFirstCVArg =+      fmap+        ( \case+            (x : xs, v) ->+              (parseSMTModelResult 0 ([], x), [(xs, v)])+            _ -> error "impossible"+        )+    partitionOrdCVArg ::+      forall a.+      (SupportedNonFuncPrim a) =>+      [(a, [([SBVD.CV], SBVD.CV)])] ->+      [(a, [([SBVD.CV], SBVD.CV)])]+    partitionOrdCVArg v = go sorted+      where+        sorted = sortWith fst v :: [(a, [([SBVD.CV], SBVD.CV)])]+        go (x : x1 : xs) =+          if fst x == fst x1+            then go $ (fst x, snd x ++ snd x1) : xs+            else x : go (x1 : xs)+        go x = x++-- | Parse the scalar model result.+parseScalarSMTModelResult ::+  forall v r.+  (SBVT.SatModel r, Typeable v) =>+  (r -> v) ->+  ([([SBVD.CV], SBVD.CV)], SBVD.CV) ->+  v+parseScalarSMTModelResult convert cvs@([], v) = case SBVT.parseCVs [v] of+  Just (x, _) -> convert x+  Nothing -> parseSMTModelResultError (typeRep @v) cvs+parseScalarSMTModelResult _ cv = parseSMTModelResultError (typeRep @v) cv++-- | Type class for resolving the SBV type for the primitive type.+class SBVRep t where+  type SBVType t++-- | Type class for resolving the constraint for a supported primitive type.+class SupportedPrimConstraint t where+  type PrimConstraint t :: Constraint+  type PrimConstraint _ = ()++-- | Indicates that a type is supported, can be represented as a symbolic term,+-- and can be lowered to an SBV term.+class+  ( Lift t,+    NFData t,+    Typeable t,+    SupportedPrimConstraint t,+    SBVRep t+  ) =>+  SupportedPrim t+  where+  primTypeRep :: TypeRep t+  default primTypeRep :: (Typeable t) => TypeRep t+  primTypeRep = typeRep+  sameCon :: t -> t -> Bool+  default sameCon :: (Eq t) => t -> t -> Bool+  sameCon = (==)+  hashConWithSalt :: Int -> t -> Int+  default hashConWithSalt :: (Hashable t) => Int -> t -> Int+  hashConWithSalt = hashWithSalt+  pformatCon :: t -> String+  default pformatCon :: (Show t) => t -> String+  pformatCon = show+  defaultValue :: t+  pevalITETerm :: Term Bool -> Term t -> Term t -> Term t+  pevalEqTerm :: Term t -> Term t -> Term Bool+  pevalDistinctTerm :: NonEmpty (Term t) -> Term Bool+  conSBVTerm :: t -> SBVType t+  symSBVName :: TypedSymbol 'AnyKind t -> Int -> String+  symSBVTerm :: (SBVFreshMonad m) => String -> m (SBVType t)+  default withPrim ::+    ( PrimConstraint t,+      SBV.SMTDefinable (SBVType t),+      SBV.Mergeable (SBVType t),+      Typeable (SBVType t)+    ) =>+    ( ( PrimConstraint t,+        SBV.SMTDefinable (SBVType t),+        SBV.Mergeable (SBVType t),+        Typeable (SBVType t)+      ) =>+      a+    ) ->+    a+  withPrim ::+    ( ( PrimConstraint t,+        SBV.SMTDefinable (SBVType t),+        SBV.Mergeable (SBVType t),+        Typeable (SBVType t)+      ) =>+      a+    ) ->+    a+  withPrim i = i+  {-# INLINE withPrim #-}+  sbvIte :: SBV.SBV Bool -> SBVType t -> SBVType t -> SBVType t+  sbvIte = withPrim @t SBV.ite+  sbvEq :: SBVType t -> SBVType t -> SBV.SBV Bool+  default sbvEq ::+    (SBVT.EqSymbolic (SBVType t)) => SBVType t -> SBVType t -> SBV.SBV Bool+  sbvEq = (SBV..==)+  sbvDistinct :: NonEmpty (SBVType t) -> SBV.SBV Bool+  default sbvDistinct ::+    (SBVT.EqSymbolic (SBVType t)) => NonEmpty (SBVType t) -> SBV.SBV Bool+  sbvDistinct = SBV.distinct . toList+  parseSMTModelResult :: Int -> ([([SBVD.CV], SBVD.CV)], SBVD.CV) -> t+  castTypedSymbol ::+    (IsSymbolKind knd') => TypedSymbol knd t -> Maybe (TypedSymbol knd' t)+  funcDummyConstraint :: SBVType t -> SBV.SBV Bool++-- | The default value in a dynamic t'ModelValue'.+defaultValueDynamic ::+  forall t proxy. (SupportedPrim t) => proxy t -> ModelValue+defaultValueDynamic _ = toModelValue (defaultValue @t)++-- | A value with its type information.+data ModelValue where+  ModelValue :: forall v. (SupportedPrim v) => v -> ModelValue++instance NFData ModelValue where+  rnf (ModelValue v) = rnf v++instance Lift ModelValue where+  liftTyped (ModelValue v) = [||ModelValue v||]++instance Show ModelValue where+  show (ModelValue (v :: v)) = pformatCon v ++ " :: " ++ show (primTypeRep @v)++instance Eq ModelValue where+  (ModelValue (v1 :: v1)) == (ModelValue (v2 :: v2)) =+    case eqTypeRep (primTypeRep @v1) (primTypeRep @v2) of+      Just HRefl -> sameCon v1 v2+      _ -> False++instance Hashable ModelValue where+  s `hashWithSalt` (ModelValue (v :: v)) =+    (s `hashWithSalt` (primTypeRep @v)) `hashConWithSalt` v++-- | Convert from a model value. Crashes if the types does not match.+unsafeFromModelValue :: forall a. (Typeable a) => ModelValue -> a+unsafeFromModelValue (ModelValue (v :: v)) =+  case eqTypeRep (primTypeRep @v) (typeRep @a) of+    Just HRefl -> v+    _ ->+      error $+        "Bad model value type, expected type: "+          ++ show (typeRep @a)+          ++ ", but got: "+          ++ show (primTypeRep @v)++-- | Convert to a model value.+toModelValue :: forall a. (SupportedPrim a) => a -> ModelValue+toModelValue = ModelValue++-- | Cast a typed symbol to a different kind. Check if the kind is compatible.+castSomeTypedSymbol ::+  (IsSymbolKind knd') => SomeTypedSymbol knd -> Maybe (SomeTypedSymbol knd')+castSomeTypedSymbol (SomeTypedSymbol s@TypedSymbol {}) =+  SomeTypedSymbol <$> castTypedSymbol s+{-# INLINE castSomeTypedSymbol #-}++-- | Error message for failure to parse the SBV model result.+parseSMTModelResultError ::+  (HasCallStack) => TypeRep a -> ([([SBVD.CV], SBVD.CV)], SBVD.CV) -> a+parseSMTModelResultError ty cv =+  error $+    "BUG: cannot parse SBV model value \""+      <> show cv+      <> "\" to Grisette model value with the type "+      <> show ty++-- | Partial evaluation for inequality terms.+pevalNEqTerm :: (SupportedPrim a) => Term a -> Term a -> Term Bool+pevalNEqTerm l r = pevalNotTerm $ pevalEqTerm l r+{-# INLINE pevalNEqTerm #-}++-- | Type family to resolve the concrete type associated with a symbolic type.+class ConRep sym where+  type ConType sym++-- | Type family to resolve the symbolic type associated with a concrete type.+class (SupportedPrim con) => SymRep con where+  type SymType con++-- | One-to-one mapping between symbolic types and concrete types.+class+  (ConRep sym, SymRep con, sym ~ SymType con, con ~ ConType sym) =>+  LinkedRep con sym+    | con -> sym,+      sym -> con+  where+  underlyingTerm :: sym -> Term con+  wrapTerm :: Term con -> sym++-- | Partial evaluation and lowering for function application terms.+class PEvalApplyTerm f a b | f -> a b where+  pevalApplyTerm :: Term f -> Term a -> Term b+  sbvApplyTerm :: SBVType f -> SBVType a -> SBVType b++-- | Partial evaluation and lowering for bitwise operation terms.+class PEvalBitwiseTerm t where+  pevalAndBitsTerm :: Term t -> Term t -> Term t+  pevalOrBitsTerm :: Term t -> Term t -> Term t+  pevalXorBitsTerm :: Term t -> Term t -> Term t+  pevalComplementBitsTerm :: Term t -> Term t+  withSbvBitwiseTermConstraint :: (((Bits (SBVType t)) => r)) -> r+  sbvAndBitsTerm :: SBVType t -> SBVType t -> SBVType t+  sbvAndBitsTerm = withSbvBitwiseTermConstraint @t (SBV..&.)+  sbvOrBitsTerm :: SBVType t -> SBVType t -> SBVType t+  sbvOrBitsTerm = withSbvBitwiseTermConstraint @t (SBV..|.)+  sbvXorBitsTerm :: SBVType t -> SBVType t -> SBVType t+  sbvXorBitsTerm = withSbvBitwiseTermConstraint @t SBV.xor+  sbvComplementBitsTerm :: SBVType t -> SBVType t+  sbvComplementBitsTerm = withSbvBitwiseTermConstraint @t SBV.complement++-- | Partial evaluation and lowering for symbolic shifting terms.+class PEvalShiftTerm t where+  pevalShiftLeftTerm :: Term t -> Term t -> Term t+  pevalShiftRightTerm :: Term t -> Term t -> Term t+  withSbvShiftTermConstraint ::+    (((SBV.SIntegral (NonFuncSBVBaseType t)) => r)) -> r+  sbvShiftLeftTerm :: SBVType t -> SBVType t -> SBVType t+  default sbvShiftLeftTerm ::+    (SupportedNonFuncPrim t) => SBVType t -> SBVType t -> SBVType t+  sbvShiftLeftTerm l r =+    withNonFuncPrim @t $ withSbvShiftTermConstraint @t $ SBV.sShiftLeft l r+  default sbvShiftRightTerm ::+    (SupportedNonFuncPrim t) => SBVType t -> SBVType t -> SBVType t+  sbvShiftRightTerm :: SBVType t -> SBVType t -> SBVType t+  sbvShiftRightTerm l r =+    withNonFuncPrim @t $ withSbvShiftTermConstraint @t $ SBV.sShiftRight l r++-- | Partial evaluation and lowering for symbolic rotate terms.+class PEvalRotateTerm t where+  pevalRotateLeftTerm :: Term t -> Term t -> Term t+  pevalRotateRightTerm :: Term t -> Term t -> Term t+  withSbvRotateTermConstraint ::+    (((SBV.SIntegral (NonFuncSBVBaseType t)) => r)) -> r+  sbvRotateLeftTerm :: SBVType t -> SBVType t -> SBVType t+  default sbvRotateLeftTerm ::+    (SupportedNonFuncPrim t) => SBVType t -> SBVType t -> SBVType t+  sbvRotateLeftTerm l r =+    withNonFuncPrim @t $ withSbvRotateTermConstraint @t $ SBV.sRotateLeft l r+  sbvRotateRightTerm :: SBVType t -> SBVType t -> SBVType t+  default sbvRotateRightTerm ::+    (SupportedNonFuncPrim t) => SBVType t -> SBVType t -> SBVType t+  sbvRotateRightTerm l r =+    withNonFuncPrim @t $ withSbvRotateTermConstraint @t $ SBV.sRotateRight l r++-- | Partial evaluation and lowering for number terms.+class (Num t) => PEvalNumTerm t where+  pevalAddNumTerm :: Term t -> Term t -> Term t+  pevalNegNumTerm :: Term t -> Term t+  pevalMulNumTerm :: Term t -> Term t -> Term t+  pevalAbsNumTerm :: Term t -> Term t+  pevalSignumNumTerm :: Term t -> Term t+  withSbvNumTermConstraint :: (((Num (SBVType t)) => r)) -> r+  sbvAddNumTerm ::+    SBVType t ->+    SBVType t ->+    SBVType t+  sbvAddNumTerm l r = withSbvNumTermConstraint @t $ l + r+  sbvNegNumTerm ::+    SBVType t ->+    SBVType t+  sbvNegNumTerm l = withSbvNumTermConstraint @t $ -l+  sbvMulNumTerm ::+    SBVType t ->+    SBVType t ->+    SBVType t+  sbvMulNumTerm l r = withSbvNumTermConstraint @t $ l * r+  sbvAbsNumTerm ::+    SBVType t ->+    SBVType t+  sbvAbsNumTerm l = withSbvNumTermConstraint @t $ abs l+  sbvSignumNumTerm ::+    SBVType t ->+    SBVType t+  sbvSignumNumTerm l = withSbvNumTermConstraint @t $ signum l++-- | Partial evaluation for subtraction terms.+pevalSubNumTerm :: (PEvalNumTerm a) => Term a -> Term a -> Term a+pevalSubNumTerm l r = pevalAddNumTerm l (pevalNegNumTerm r)++-- | Partial evaluation and lowering for comparison terms.+class PEvalOrdTerm t where+  pevalLtOrdTerm :: Term t -> Term t -> Term Bool+  pevalLeOrdTerm :: Term t -> Term t -> Term Bool+  withSbvOrdTermConstraint :: (((SBV.OrdSymbolic (SBVType t)) => r)) -> r+  sbvLtOrdTerm ::+    SBVType t ->+    SBVType t ->+    SBV.SBV Bool+  sbvLtOrdTerm l r = withSbvOrdTermConstraint @t $ l SBV..< r+  sbvLeOrdTerm :: SBVType t -> SBVType t -> SBV.SBV Bool+  sbvLeOrdTerm l r = withSbvOrdTermConstraint @t $ l SBV..<= r++-- | Partial evaluation for greater than terms.+pevalGtOrdTerm :: (PEvalOrdTerm a) => Term a -> Term a -> Term Bool+pevalGtOrdTerm = flip pevalLtOrdTerm+{-# INLINE pevalGtOrdTerm #-}++-- | Partial evaluation for greater than or equal to terms.+pevalGeOrdTerm :: (PEvalOrdTerm a) => Term a -> Term a -> Term Bool+pevalGeOrdTerm = flip pevalLeOrdTerm+{-# INLINE pevalGeOrdTerm #-}++-- | Partial evaluation and lowering for integer division and modulo terms.+class PEvalDivModIntegralTerm t where+  pevalDivIntegralTerm :: Term t -> Term t -> Term t+  pevalModIntegralTerm :: Term t -> Term t -> Term t+  pevalQuotIntegralTerm :: Term t -> Term t -> Term t+  pevalRemIntegralTerm :: Term t -> Term t -> Term t+  withSbvDivModIntegralTermConstraint ::+    (((SBV.SDivisible (SBVType t)) => r)) -> r+  sbvDivIntegralTerm :: SBVType t -> SBVType t -> SBVType t+  sbvDivIntegralTerm l r =+    withSbvDivModIntegralTermConstraint @t $ l `SBV.sDiv` r+  sbvModIntegralTerm :: SBVType t -> SBVType t -> SBVType t+  sbvModIntegralTerm l r =+    withSbvDivModIntegralTermConstraint @t $ l `SBV.sMod` r+  sbvQuotIntegralTerm :: SBVType t -> SBVType t -> SBVType t+  sbvQuotIntegralTerm l r =+    withSbvDivModIntegralTermConstraint @t $ l `SBV.sQuot` r+  sbvRemIntegralTerm :: SBVType t -> SBVType t -> SBVType t+  sbvRemIntegralTerm l r =+    withSbvDivModIntegralTermConstraint @t $ l `SBV.sRem` r++-- | Partial evaluation and lowering for bitcast terms.+class (BitCast a b) => PEvalBitCastTerm a b where+  pevalBitCastTerm :: Term a -> Term b+  sbvBitCast :: SBVType a -> SBVType b++-- | Partial evaluation and lowering for bitcast or default value terms.+class+  (BitCastOr a b) =>+  PEvalBitCastOrTerm a b+  where+  pevalBitCastOrTerm :: Term b -> Term a -> Term b+  sbvBitCastOr :: SBVType b -> SBVType a -> SBVType b++-- | Partial evaluation and lowering for bit-vector terms.+class+  ( SizedBV bv,+    forall n. (KnownNat n, 1 <= n) => PEvalNumTerm (bv n),+    forall n. (KnownNat n, 1 <= n) => PEvalBitwiseTerm (bv n),+    forall n. (KnownNat n, 1 <= n) => FiniteBits (bv n),+    forall n. (KnownNat n, 1 <= n) => Num (bv n)+  ) =>+  PEvalBVTerm bv+  where+  pevalBVConcatTerm ::+    (KnownNat l, KnownNat r, 1 <= l, 1 <= r) =>+    Term (bv l) ->+    Term (bv r) ->+    Term (bv (l + r))+  pevalBVExtendTerm ::+    (KnownNat l, KnownNat r, 1 <= l, 1 <= r, l <= r) =>+    Bool ->+    proxy r ->+    Term (bv l) ->+    Term (bv r)+  pevalBVSelectTerm ::+    (KnownNat n, KnownNat ix, KnownNat w, 1 <= n, 1 <= w, ix + w <= n) =>+    p ix ->+    q w ->+    Term (bv n) ->+    Term (bv w)+  sbvBVConcatTerm ::+    (KnownNat l, KnownNat r, 1 <= l, 1 <= r) =>+    p1 l ->+    p2 r ->+    SBVType (bv l) ->+    SBVType (bv r) ->+    SBVType (bv (l + r))+  sbvBVExtendTerm ::+    (KnownNat l, KnownNat r, 1 <= l, 1 <= r, l <= r) =>+    p1 l ->+    p2 r ->+    Bool ->+    SBVType (bv l) ->+    SBVType (bv r)+  sbvBVSelectTerm ::+    ( KnownNat ix,+      KnownNat w,+      KnownNat n,+      1 <= n,+      1 <= w,+      ix + w <= n+    ) =>+    p1 ix ->+    p2 w ->+    p3 n ->+    SBVType (bv n) ->+    SBVType (bv w)++-- | Partial evaluation and lowering for fractional terms.+class (Fractional t) => PEvalFractionalTerm t where+  pevalFdivTerm :: Term t -> Term t -> Term t+  pevalRecipTerm :: Term t -> Term t+  withSbvFractionalTermConstraint ::+    (((Fractional (SBVType t)) => r)) ->+    r+  sbvFdivTerm ::+    SBVType t ->+    SBVType t ->+    SBVType t+  sbvFdivTerm l r = withSbvFractionalTermConstraint @t $ l / r+  sbvRecipTerm ::+    SBVType t ->+    SBVType t+  sbvRecipTerm l = withSbvFractionalTermConstraint @t $ recip l++-- | Unary floating point operations.+data FloatingUnaryOp+  = FloatingExp+  | FloatingLog+  | FloatingSqrt+  | FloatingSin+  | FloatingCos+  | FloatingTan+  | FloatingAsin+  | FloatingAcos+  | FloatingAtan+  | FloatingSinh+  | FloatingCosh+  | FloatingTanh+  | FloatingAsinh+  | FloatingAcosh+  | FloatingAtanh+  deriving (Eq, Ord, Generic, Hashable, Lift, NFData, Serial)++instance Cereal.Serialize FloatingUnaryOp where+  put = serialize+  get = deserialize++instance Binary.Binary FloatingUnaryOp where+  put = serialize+  get = deserialize++instance Show FloatingUnaryOp where+  show FloatingExp = "exp"+  show FloatingLog = "log"+  show FloatingSqrt = "sqrt"+  show FloatingSin = "sin"+  show FloatingCos = "cos"+  show FloatingTan = "tan"+  show FloatingAsin = "asin"+  show FloatingAcos = "acos"+  show FloatingAtan = "atan"+  show FloatingSinh = "sinh"+  show FloatingCosh = "cosh"+  show FloatingTanh = "tanh"+  show FloatingAsinh = "asinh"+  show FloatingAcosh = "acosh"+  show FloatingAtanh = "atanh"++-- | Partial evaluation and lowering for floating point terms.+class PEvalFPTerm fp where+  pevalFPTraitTerm :: (ValidFP eb sb) => FPTrait -> Term (fp eb sb) -> Term Bool+  pevalFPUnaryTerm ::+    (ValidFP eb sb) =>+    FPUnaryOp ->+    Term (fp eb sb) ->+    Term (fp eb sb)+  pevalFPBinaryTerm ::+    (ValidFP eb sb) =>+    FPBinaryOp ->+    Term (fp eb sb) ->+    Term (fp eb sb) ->+    Term (fp eb sb)+  pevalFPRoundingUnaryTerm ::+    (ValidFP eb sb) =>+    FPRoundingUnaryOp ->+    Term FPRoundingMode ->+    Term (fp eb sb) ->+    Term (fp eb sb)+  pevalFPRoundingBinaryTerm ::+    (ValidFP eb sb) =>+    FPRoundingBinaryOp ->+    Term FPRoundingMode ->+    Term (fp eb sb) ->+    Term (fp eb sb) ->+    Term (fp eb sb)+  pevalFPFMATerm ::+    (ValidFP eb sb) =>+    Term FPRoundingMode ->+    Term (fp eb sb) ->+    Term (fp eb sb) ->+    Term (fp eb sb) ->+    Term (fp eb sb)+  sbvFPTraitTerm ::+    (ValidFP eb sb) => FPTrait -> SBVType (fp eb sb) -> SBVType Bool+  sbvFPUnaryTerm ::+    (ValidFP eb sb) =>+    FPUnaryOp ->+    SBVType (fp eb sb) ->+    SBVType (fp eb sb)+  sbvFPBinaryTerm ::+    (ValidFP eb sb) =>+    FPBinaryOp ->+    SBVType (fp eb sb) ->+    SBVType (fp eb sb) ->+    SBVType (fp eb sb)+  sbvFPRoundingUnaryTerm ::+    (ValidFP eb sb) =>+    FPRoundingUnaryOp ->+    SBVType FPRoundingMode ->+    SBVType (fp eb sb) ->+    SBVType (fp eb sb)+  sbvFPRoundingBinaryTerm ::+    (ValidFP eb sb) =>+    FPRoundingBinaryOp ->+    SBVType FPRoundingMode ->+    SBVType (fp eb sb) ->+    SBVType (fp eb sb) ->+    SBVType (fp eb sb)+  sbvFPFMATerm ::+    (ValidFP eb sb) =>+    SBVType FPRoundingMode ->+    SBVType (fp eb sb) ->+    SBVType (fp eb sb) ->+    SBVType (fp eb sb) ->+    SBVType (fp eb sb)++-- | Partial evaluation and lowering for floating point terms.+class PEvalFloatingTerm t where+  pevalFloatingUnaryTerm :: FloatingUnaryOp -> Term t -> Term t+  pevalPowerTerm :: Term t -> Term t -> Term t+  withSbvFloatingTermConstraint ::+    (((Floating (SBVType t)) => r)) ->+    r+  sbvPowerTerm ::+    SBVType t ->+    SBVType t ->+    SBVType t+  sbvPowerTerm = withSbvFloatingTermConstraint @t (**)+  sbvFloatingUnaryTerm ::+    FloatingUnaryOp ->+    SBVType t ->+    SBVType t+  sbvFloatingUnaryTerm op l =+    withSbvFloatingTermConstraint @t $+      case op of+        FloatingExp -> exp l+        FloatingLog -> log l+        FloatingSqrt -> sqrt l+        FloatingSin -> sin l+        FloatingCos -> cos l+        FloatingTan -> tan l+        FloatingAsin -> asin l+        FloatingAcos -> acos l+        FloatingAtan -> atan l+        FloatingSinh -> sinh l+        FloatingCosh -> cosh l+        FloatingTanh -> tanh l+        FloatingAsinh -> asinh l+        FloatingAcosh -> acosh l+        FloatingAtanh -> atanh l++-- | Partial evaluation and lowering for integral terms.+class (Integral a, Num b) => PEvalFromIntegralTerm a b where+  pevalFromIntegralTerm :: Term a -> Term b+  sbvFromIntegralTerm :: SBVType a -> SBVType b++-- | Partial evaluation and lowering for converting from and to IEEE floating+-- point terms.+class PEvalIEEEFPConvertibleTerm a where+  pevalFromFPOrTerm ::+    (ValidFP eb sb) =>+    Term a ->+    Term FPRoundingMode ->+    Term (FP eb sb) ->+    Term a+  pevalToFPTerm ::+    (ValidFP eb sb) => Term FPRoundingMode -> Term a -> Term (FP eb sb)+  sbvFromFPOrTerm ::+    (ValidFP eb sb) =>+    SBVType a ->+    SBVType FPRoundingMode ->+    SBVType (FP eb sb) ->+    SBVType a+  sbvToFPTerm ::+    (ValidFP eb sb) =>+    SBVType FPRoundingMode ->+    SBVType a ->+    SBVType (FP eb sb)++-- Typed Symbols++-- | The kind of a symbol.+--+-- All symbols are 'AnyKind', and all symbols other than general/tabular+-- functions are 'ConstantKind'.+data SymbolKind = ConstantKind | AnyKind++-- | Decision procedure for symbol kinds.+class IsSymbolKind (knd :: SymbolKind) where+  type SymbolKindConstraint knd :: Type -> Constraint+  decideSymbolKind :: Either (knd :~~: 'ConstantKind) (knd :~~: 'AnyKind)+  withSymbolKindConstraint ::+    TypedSymbol knd t ->+    ((SymbolKindConstraint knd t) => a) ->+    a++instance IsSymbolKind 'ConstantKind where+  type SymbolKindConstraint 'ConstantKind = SupportedNonFuncPrim+  decideSymbolKind = Left HRefl+  withSymbolKindConstraint r = withConstantSymbolSupported r++instance IsSymbolKind 'AnyKind where+  type SymbolKindConstraint 'AnyKind = SupportedPrim+  decideSymbolKind = Right HRefl+  withSymbolKindConstraint r = withSymbolSupported r++-- | A typed symbol is a symbol that is associated with a type. Note that the+-- 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:+--+-- >>> "a" :: TypedSymbol 'AnyKind Bool+-- a :: Bool+data TypedSymbol (knd :: SymbolKind) t where+  TypedSymbol ::+    ( SupportedPrim t,+      SymbolKindConstraint knd t,+      IsSymbolKind knd+    ) =>+    {unTypedSymbol :: Symbol} ->+    TypedSymbol knd t++-- | Create a typed symbol with constant kinds.+typedConstantSymbol ::+  forall t. (SupportedNonFuncPrim t) => Symbol -> TypedSymbol 'ConstantKind t+typedConstantSymbol = typedConstantSymbol' getPhantomNonFuncDict+{-# INLINE typedConstantSymbol #-}++{-# NOINLINE typedConstantSymbol' #-}+typedConstantSymbol' ::+  forall t. PhantomNonFuncDict t -> Symbol -> TypedSymbol 'ConstantKind t+typedConstantSymbol' PhantomNonFuncDict symbol = TypedSymbol symbol++-- | Create a typed symbol with any kinds.+typedAnySymbol ::+  forall t. (SupportedPrim t) => Symbol -> TypedSymbol 'AnyKind t+typedAnySymbol = typedAnySymbol' getPhantomDict+{-# INLINE typedAnySymbol #-}++{-# NOINLINE typedAnySymbol' #-}+typedAnySymbol' ::+  forall t. PhantomDict t -> Symbol -> TypedSymbol 'AnyKind t+typedAnySymbol' PhantomDict symbol = TypedSymbol symbol++-- | Constant symbol+type TypedConstantSymbol = TypedSymbol 'ConstantKind++-- | Any symbol+type TypedAnySymbol = TypedSymbol 'AnyKind++instance Eq (TypedSymbol knd t) where+  TypedSymbol x == TypedSymbol y = x == y++instance Ord (TypedSymbol knd t) where+  TypedSymbol x <= TypedSymbol y = x <= y++instance Lift (TypedSymbol knd t) where+  liftTyped (TypedSymbol x) = [||TypedSymbol x||]++instance Show (TypedSymbol knd t) where+  show (TypedSymbol symbol) = show symbol ++ " :: " ++ show (primTypeRep @t)++-- | Show a typed symbol without the type information.+showUntyped :: TypedSymbol knd t -> String+showUntyped (TypedSymbol symbol) = show symbol++instance Hashable (TypedSymbol knd t) where+  s `hashWithSalt` TypedSymbol x = s `hashWithSalt` x++instance NFData (TypedSymbol knd t) where+  rnf (TypedSymbol str) = rnf str++instance+  ( SupportedPrim t,+    SymbolKindConstraint knd t,+    IsSymbolKind knd+  ) =>+  IsString (TypedSymbol knd t)+  where+  fromString = TypedSymbol . fromString++-- | Introduce the 'SupportedPrim' constraint from the t'TypedSymbol'.+withSymbolSupported ::+  forall knd t a.+  TypedSymbol knd t ->+  ((SupportedPrim t) => a) ->+  a+withSymbolSupported (TypedSymbol _) a = a+{-# INLINE withSymbolSupported #-}++-- | Introduce the 'SupportedPrim' constraint from the t'TypedSymbol'.+withConstantSymbolSupported ::+  forall t a.+  TypedSymbol 'ConstantKind t ->+  ((SupportedNonFuncPrim t) => a) ->+  a+withConstantSymbolSupported (TypedSymbol _) a = a+{-# INLINE withConstantSymbolSupported #-}++-- | A non-indexed symbol. Type information are checked at runtime.+data SomeTypedSymbol knd where+  SomeTypedSymbol ::+    forall knd t.+    TypedSymbol knd t ->+    SomeTypedSymbol knd++-- | Non-indexed constant symbol+type SomeTypedConstantSymbol = SomeTypedSymbol 'ConstantKind++-- | Non-indexed any symbol+type SomeTypedAnySymbol = SomeTypedSymbol 'AnyKind++instance NFData (SomeTypedSymbol knd) where+  rnf (SomeTypedSymbol s) = rnf s+  {-# INLINE rnf #-}++instance Lift (SomeTypedSymbol knd) where+  liftTyped (SomeTypedSymbol s) = [||SomeTypedSymbol s||]++instance Eq (SomeTypedSymbol knd) where+  (SomeTypedSymbol (s1 :: TypedSymbol knd a))+    == (SomeTypedSymbol (s2 :: TypedSymbol knd b)) =+      withSymbolSupported s1 $+        withSymbolSupported s2 $+          case eqTypeRep (primTypeRep @a) (primTypeRep @b) of+            Just HRefl -> s1 == s2+            _ -> False+  {-# INLINE (==) #-}++instance Ord (SomeTypedSymbol knd) where+  (SomeTypedSymbol (s1 :: TypedSymbol knd a))+    <= (SomeTypedSymbol (s2 :: TypedSymbol knd b)) =+      withSymbolSupported s1 $+        withSymbolSupported s2 $+          let t1 = primTypeRep @a+              t2 = primTypeRep @b+           in SomeTypeRep t1 < SomeTypeRep t2+                || ( case eqTypeRep t1 t2 of+                       Just HRefl -> s1 <= s2+                       _ -> False+                   )++instance Hashable (SomeTypedSymbol knd) where+  hashWithSalt s (SomeTypedSymbol s1) = s `hashWithSalt` s1+  {-# INLINE hashWithSalt #-}++instance Show (SomeTypedSymbol knd) where+  show (SomeTypedSymbol s) = show s++-- | Construct a t'SomeTypedSymbol' from a t'TypedSymbol'.+someTypedSymbol :: forall knd t. TypedSymbol knd t -> SomeTypedSymbol knd+someTypedSymbol s@(TypedSymbol _) = SomeTypedSymbol s+{-# INLINE someTypedSymbol #-}++-- Terms++-- | Traits for IEEE floating point numbers.+data FPTrait+  = FPIsNaN+  | FPIsPositive+  | FPIsNegative+  | FPIsPositiveInfinite+  | FPIsNegativeInfinite+  | FPIsInfinite+  | FPIsPositiveZero+  | FPIsNegativeZero+  | FPIsZero+  | FPIsNormal+  | FPIsSubnormal+  | FPIsPoint+  deriving (Eq, Ord, Generic, Hashable, Lift, NFData, Serial)++instance Cereal.Serialize FPTrait where+  put = serialize+  get = deserialize++instance Binary.Binary FPTrait where+  put = serialize+  get = deserialize++instance Show FPTrait where+  show FPIsNaN = "is_nan"+  show FPIsPositive = "is_pos"+  show FPIsNegative = "is_neg"+  show FPIsPositiveInfinite = "is_pos_inf"+  show FPIsNegativeInfinite = "is_neg_inf"+  show FPIsInfinite = "is_inf"+  show FPIsPositiveZero = "is_pos_zero"+  show FPIsNegativeZero = "is_neg_zero"+  show FPIsZero = "is_zero"+  show FPIsNormal = "is_normal"+  show FPIsSubnormal = "is_subnormal"+  show FPIsPoint = "is_point"++-- | Unary floating point operations.+data FPUnaryOp = FPAbs | FPNeg+  deriving (Eq, Ord, Generic, Hashable, Lift, NFData, Serial)++instance Cereal.Serialize FPUnaryOp where+  put = serialize+  get = deserialize++instance Binary.Binary FPUnaryOp where+  put = serialize+  get = deserialize++instance Show FPUnaryOp where+  show FPAbs = "fp.abs"+  show FPNeg = "fp.neg"++-- | Binary floating point operations.+data FPBinaryOp+  = FPRem+  | FPMinimum+  | FPMinimumNumber+  | FPMaximum+  | FPMaximumNumber+  deriving (Eq, Ord, Generic, Hashable, Lift, NFData, Serial)++instance Cereal.Serialize FPBinaryOp where+  put = serialize+  get = deserialize++instance Binary.Binary FPBinaryOp where+  put = serialize+  get = deserialize++instance Show FPBinaryOp where+  show FPRem = "fp.rem"+  show FPMinimum = "fp.minimum"+  show FPMinimumNumber = "fp.minimumNumber"+  show FPMaximum = "fp.maximum"+  show FPMaximumNumber = "fp.maximumNumber"++-- | Unary floating point operations with rounding modes.+data FPRoundingUnaryOp = FPSqrt | FPRoundToIntegral+  deriving (Eq, Ord, Generic, Hashable, Lift, NFData, Serial)++instance Cereal.Serialize FPRoundingUnaryOp where+  put = serialize+  get = deserialize++instance Binary.Binary FPRoundingUnaryOp where+  put = serialize+  get = deserialize++instance Show FPRoundingUnaryOp where+  show FPSqrt = "fp.sqrt"+  show FPRoundToIntegral = "fp.roundToIntegral"++-- | Binary floating point operations with rounding modes.+data FPRoundingBinaryOp = FPAdd | FPSub | FPMul | FPDiv+  deriving (Eq, Ord, Generic, Hashable, Lift, NFData, Serial)++instance Cereal.Serialize FPRoundingBinaryOp where+  put = serialize+  get = deserialize++instance Binary.Binary FPRoundingBinaryOp where+  put = serialize+  get = deserialize++instance Show FPRoundingBinaryOp where+  show FPAdd = "fp.add"+  show FPSub = "fp.sub"+  show FPMul = "fp.mul"+  show FPDiv = "fp.div"++instance NFData CachedInfo where+  rnf (CachedInfo tid digest id stableIdent) =+    rnf tid `seq` rnf digest `seq` rnf id `seq` rnf stableIdent++-- | Internal representation for Grisette symbolic terms.+data Term t where+  ConTerm' ::+    (SupportedPrim t) =>+    {-# UNPACK #-} !CachedInfo ->+    !t ->+    Term t+  SymTerm' ::+    {-# UNPACK #-} !CachedInfo ->+    !(TypedSymbol 'AnyKind t) ->+    Term t+  ForallTerm' ::+    {-# UNPACK #-} !CachedInfo ->+    !(TypedSymbol 'ConstantKind t) ->+    !(Term Bool) ->+    Term Bool+  ExistsTerm' ::+    {-# UNPACK #-} !CachedInfo ->+    !(TypedSymbol 'ConstantKind t) ->+    !(Term Bool) ->+    Term Bool+  NotTerm' ::+    {-# UNPACK #-} !CachedInfo ->+    !(Term Bool) ->+    Term Bool+  OrTerm' ::+    {-# UNPACK #-} !CachedInfo ->+    !(Term Bool) ->+    !(Term Bool) ->+    !(HS.HashSet (Term Bool)) -> -- All or'ed terms+    Term Bool+  AndTerm' ::+    {-# UNPACK #-} !CachedInfo ->+    !(Term Bool) ->+    !(Term Bool) ->+    !(HS.HashSet (Term Bool)) -> -- All and'ed terms+    Term Bool+  EqTerm' ::+    {-# UNPACK #-} !CachedInfo ->+    !(Term t) ->+    !(Term t) ->+    Term Bool+  DistinctTerm' ::+    {-# UNPACK #-} !CachedInfo ->+    !(NonEmpty (Term t)) ->+    Term Bool+  ITETerm' ::+    (SupportedPrim t) =>+    {-# UNPACK #-} !CachedInfo ->+    !(Term Bool) ->+    !(Term t) ->+    !(Term t) ->+    Term t+  AddNumTerm' ::+    (SupportedPrim t, PEvalNumTerm t) =>+    {-# UNPACK #-} !CachedInfo ->+    !(Term t) ->+    !(Term t) ->+    Term t+  NegNumTerm' ::+    (SupportedPrim t, PEvalNumTerm t) =>+    {-# UNPACK #-} !CachedInfo ->+    !(Term t) ->+    Term t+  MulNumTerm' ::+    (SupportedPrim t, PEvalNumTerm t) =>+    {-# UNPACK #-} !CachedInfo ->+    !(Term t) ->+    !(Term t) ->+    Term t+  AbsNumTerm' ::+    (SupportedPrim t, PEvalNumTerm t) =>+    {-# UNPACK #-} !CachedInfo ->+    !(Term t) ->+    Term t+  SignumNumTerm' ::+    (SupportedPrim t, PEvalNumTerm t) =>+    {-# UNPACK #-} !CachedInfo ->+    !(Term t) ->+    Term t+  LtOrdTerm' ::+    (SupportedPrim t, PEvalOrdTerm t) =>+    {-# UNPACK #-} !CachedInfo ->+    !(Term t) ->+    !(Term t) ->+    Term Bool+  LeOrdTerm' ::+    (SupportedPrim t, PEvalOrdTerm t) =>+    {-# UNPACK #-} !CachedInfo ->+    !(Term t) ->+    !(Term t) ->+    Term Bool+  AndBitsTerm' ::+    (SupportedPrim t, PEvalBitwiseTerm t) =>+    {-# UNPACK #-} !CachedInfo ->+    !(Term t) ->+    !(Term t) ->+    Term t+  OrBitsTerm' ::+    (SupportedPrim t, PEvalBitwiseTerm t) =>+    {-# UNPACK #-} !CachedInfo ->+    !(Term t) ->+    !(Term t) ->+    Term t+  XorBitsTerm' ::+    (SupportedPrim t, PEvalBitwiseTerm t) =>+    {-# UNPACK #-} !CachedInfo ->+    !(Term t) ->+    !(Term t) ->+    Term t+  ComplementBitsTerm' ::+    (SupportedPrim t, PEvalBitwiseTerm t) =>+    {-# UNPACK #-} !CachedInfo ->+    !(Term t) ->+    Term t+  ShiftLeftTerm' ::+    (SupportedPrim t, PEvalShiftTerm t) =>+    {-# UNPACK #-} !CachedInfo ->+    !(Term t) ->+    !(Term t) ->+    Term t+  ShiftRightTerm' ::+    (SupportedPrim t, PEvalShiftTerm t) =>+    {-# UNPACK #-} !CachedInfo ->+    !(Term t) ->+    !(Term t) ->+    Term t+  RotateLeftTerm' ::+    (SupportedPrim t, PEvalRotateTerm t) =>+    {-# UNPACK #-} !CachedInfo ->+    !(Term t) ->+    !(Term t) ->+    Term t+  RotateRightTerm' ::+    (SupportedPrim t, PEvalRotateTerm t) =>+    {-# UNPACK #-} !CachedInfo ->+    !(Term t) ->+    !(Term t) ->+    Term t+  BitCastTerm' ::+    (SupportedPrim b, PEvalBitCastTerm a b) =>+    {-# UNPACK #-} !CachedInfo ->+    !(Term a) ->+    Term b+  BitCastOrTerm' ::+    (SupportedPrim b, PEvalBitCastOrTerm a b) =>+    {-# UNPACK #-} !CachedInfo ->+    !(Term b) ->+    !(Term a) ->+    Term b+  BVConcatTerm' ::+    ( PEvalBVTerm bv,+      KnownNat l,+      KnownNat r,+      KnownNat (l + r),+      1 <= l,+      1 <= r,+      1 <= l + r,+      SupportedPrim (bv (l + r))+    ) =>+    {-# UNPACK #-} !CachedInfo ->+    !(Term (bv l)) ->+    !(Term (bv r)) ->+    Term (bv (l + r))+  BVSelectTerm' ::+    ( PEvalBVTerm bv,+      KnownNat n,+      KnownNat ix,+      KnownNat w,+      1 <= n,+      1 <= w,+      ix + w <= n,+      SupportedPrim (bv w)+    ) =>+    {-# UNPACK #-} !CachedInfo ->+    !(Proxy ix) ->+    !(Proxy w) ->+    !(Term (bv n)) ->+    Term (bv w)+  BVExtendTerm' ::+    ( PEvalBVTerm bv,+      KnownNat l,+      KnownNat r,+      1 <= l,+      1 <= r,+      l <= r,+      SupportedPrim (bv r)+    ) =>+    {-# UNPACK #-} !CachedInfo ->+    !Bool ->+    !(Proxy r) ->+    !(Term (bv l)) ->+    Term (bv r)+  ApplyTerm' ::+    (PEvalApplyTerm f a b, SupportedPrim b) =>+    {-# UNPACK #-} !CachedInfo ->+    !(Term f) ->+    !(Term a) ->+    Term b+  DivIntegralTerm' ::+    (SupportedPrim t, PEvalDivModIntegralTerm t) =>+    {-# UNPACK #-} !CachedInfo ->+    !(Term t) ->+    !(Term t) ->+    Term t+  ModIntegralTerm' ::+    (SupportedPrim t, PEvalDivModIntegralTerm t) =>+    {-# UNPACK #-} !CachedInfo ->+    !(Term t) ->+    !(Term t) ->+    Term t+  QuotIntegralTerm' ::+    (SupportedPrim t, PEvalDivModIntegralTerm t) =>+    {-# UNPACK #-} !CachedInfo ->+    !(Term t) ->+    !(Term t) ->+    Term t+  RemIntegralTerm' ::+    (SupportedPrim t, PEvalDivModIntegralTerm t) =>+    {-# UNPACK #-} !CachedInfo ->+    !(Term t) ->+    !(Term t) ->+    Term t+  FPTraitTerm' ::+    (ValidFP eb sb, SupportedPrim (fp eb sb), PEvalFPTerm fp) =>+    {-# UNPACK #-} !CachedInfo ->+    !FPTrait ->+    !(Term (fp eb sb)) ->+    Term Bool+  FdivTerm' ::+    (SupportedPrim t, PEvalFractionalTerm t) =>+    {-# UNPACK #-} !CachedInfo ->+    !(Term t) ->+    !(Term t) ->+    Term t+  RecipTerm' ::+    (SupportedPrim t, PEvalFractionalTerm t) =>+    {-# UNPACK #-} !CachedInfo ->+    !(Term t) ->+    Term t+  FloatingUnaryTerm' ::+    (SupportedPrim t, PEvalFloatingTerm t) =>+    {-# UNPACK #-} !CachedInfo ->+    !FloatingUnaryOp ->+    !(Term t) ->+    Term t+  PowerTerm' ::+    (SupportedPrim t, PEvalFloatingTerm t) =>+    {-# UNPACK #-} !CachedInfo ->+    !(Term t) ->+    !(Term t) ->+    Term t+  FPUnaryTerm' ::+    (ValidFP eb sb, SupportedPrim (fp eb sb), PEvalFPTerm fp) =>+    {-# UNPACK #-} !CachedInfo ->+    !FPUnaryOp ->+    !(Term (fp eb sb)) ->+    Term (fp eb sb)+  FPBinaryTerm' ::+    (ValidFP eb sb, SupportedPrim (fp eb sb), PEvalFPTerm fp) =>+    {-# UNPACK #-} !CachedInfo ->+    !FPBinaryOp ->+    !(Term (fp eb sb)) ->+    !(Term (fp eb sb)) ->+    Term (fp eb sb)+  FPRoundingUnaryTerm' ::+    (ValidFP eb sb, SupportedPrim (fp eb sb), PEvalFPTerm fp) =>+    {-# UNPACK #-} !CachedInfo ->+    !FPRoundingUnaryOp ->+    !(Term FPRoundingMode) ->+    !(Term (fp eb sb)) ->+    Term (fp eb sb)+  FPRoundingBinaryTerm' ::+    (ValidFP eb sb, SupportedPrim (fp eb sb), PEvalFPTerm fp) =>+    {-# UNPACK #-} !CachedInfo ->+    !FPRoundingBinaryOp ->+    !(Term FPRoundingMode) ->+    !(Term (fp eb sb)) ->+    !(Term (fp eb sb)) ->+    Term (fp eb sb)+  FPFMATerm' ::+    (ValidFP eb sb, SupportedPrim (fp eb sb), PEvalFPTerm fp) =>+    {-# UNPACK #-} !CachedInfo ->+    !(Term FPRoundingMode) ->+    !(Term (fp eb sb)) ->+    !(Term (fp eb sb)) ->+    !(Term (fp eb sb)) ->+    Term (fp eb sb)+  FromIntegralTerm' ::+    (PEvalFromIntegralTerm a b, SupportedPrim b) =>+    {-# UNPACK #-} !CachedInfo ->+    !(Term a) ->+    Term b+  FromFPOrTerm' ::+    ( PEvalIEEEFPConvertibleTerm a,+      ValidFP eb sb,+      SupportedPrim a+    ) =>+    {-# UNPACK #-} !CachedInfo ->+    !(Term a) ->+    !(Term FPRoundingMode) ->+    !(Term (FP eb sb)) ->+    Term a+  ToFPTerm' ::+    ( PEvalIEEEFPConvertibleTerm a,+      ValidFP eb sb,+      SupportedPrim (FP eb sb)+    ) =>+    {-# UNPACK #-} !CachedInfo ->+    !(Term FPRoundingMode) ->+    !(Term a) ->+    Proxy eb ->+    Proxy sb ->+    Term (FP eb sb)++data SupportedPrimEvidence t where+  SupportedPrimEvidence :: (SupportedPrim t) => SupportedPrimEvidence t++-- | Pattern synonym to introduce the SupportedPrim constraint.+pattern SupportedTerm :: forall t. () => (SupportedPrim t) => Term t+pattern SupportedTerm <-+  ( ( \v ->+        introSupportedPrimConstraint v $+          Just (SupportedPrimEvidence @t)+    ) ->+      Just SupportedPrimEvidence+    )++#if MIN_VERSION_base(4, 16, 4)+{-# COMPLETE SupportedTerm #-}+{-# INLINE SupportedTerm #-}+#endif++-- | Cast a term to another type.+castTerm :: forall a b. (Typeable b) => Term a -> Maybe (Term b)+castTerm t@SupportedTerm = cast t+{-# INLINE castTerm #-}++data SupportedTypedSymbolEvidence (k :: SymbolKind) t where+  SupportedTypedSymbolEvidence ::+    forall k t.+    (SupportedPrim t, SymbolKindConstraint k t, IsSymbolKind k) =>+    SupportedTypedSymbolEvidence k t++supportedTypedSymbolViewPat ::+  TypedSymbol k t -> Maybe (SupportedTypedSymbolEvidence k t)+supportedTypedSymbolViewPat (TypedSymbol _) = Just SupportedTypedSymbolEvidence++-- | Pattern synonym to introduce constraints from a t'TypedSymbol'.+pattern SupportedTypedSymbol ::+  forall (k :: SymbolKind) t.+  () =>+  (SupportedPrim t, SymbolKindConstraint k t, IsSymbolKind k) =>+  TypedSymbol k t+pattern SupportedTypedSymbol <-+  (supportedTypedSymbolViewPat -> Just SupportedTypedSymbolEvidence)++#if MIN_VERSION_base(4, 16, 4)+{-# COMPLETE SupportedTypedSymbol #-}+{-# INLINE SupportedTypedSymbol #-}+#endif++data SupportedConstantTypedSymbolEvidence k t where+  SupportedConstantTypedSymbolEvidence ::+    forall k t.+    ( SupportedPrim t,+      SymbolKindConstraint k t,+      IsSymbolKind k,+      k ~ 'ConstantKind+    ) =>+    SupportedConstantTypedSymbolEvidence k t++supportedConstantTypedSymbolViewPat ::+  forall k t.+  TypedSymbol k t ->+  Maybe (SupportedConstantTypedSymbolEvidence k t)+supportedConstantTypedSymbolViewPat (TypedSymbol _) =+  case decideSymbolKind @k of+    Left HRefl -> Just SupportedConstantTypedSymbolEvidence+    Right _ -> Nothing++-- | Pattern synonym to introduce constraints from a t'TypedSymbol'. Also checks+-- that the symbol kind is 'ConstantKind'.+pattern SupportedConstantTypedSymbol ::+  forall k t.+  () =>+  ( SupportedPrim t,+    SymbolKindConstraint k t,+    IsSymbolKind k,+    k ~ 'ConstantKind+  ) =>+  TypedSymbol k t+pattern SupportedConstantTypedSymbol <-+  ( supportedConstantTypedSymbolViewPat ->+      Just SupportedConstantTypedSymbolEvidence+    )++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE SupportedConstantTypedSymbol #-}+#endif++-- | Pattern synonym for 'ConTerm''. Note that using this pattern to construct+-- a 'Term' will do term simplification.+pattern ConTerm :: forall t. () => (SupportedPrim t) => t -> Term t+pattern ConTerm t <- (ConTerm' _ t)+  where+    ConTerm = conTerm++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE ConTerm #-}+#endif++-- | Pattern synonym for 'SymTerm''. Note that using this pattern to construct+-- a 'Term' will do term simplification.+pattern SymTerm ::+  forall t. () => (SupportedPrim t) => TypedSymbol 'AnyKind t -> Term t+pattern SymTerm t <- (SymTerm' _ t@SupportedTypedSymbol)+  where+    SymTerm = symTerm++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE SymTerm #-}+#endif++-- | Pattern synonym for 'ForallTerm''. Note that using this pattern to+-- construct a 'Term' will do term simplification.+pattern ForallTerm ::+  forall r.+  () =>+  forall t.+  (r ~ Bool, SupportedNonFuncPrim t) =>+  TypedSymbol 'ConstantKind t ->+  Term Bool ->+  Term r+pattern ForallTerm sym body <-+  (ForallTerm' _ sym@SupportedConstantTypedSymbol body)+  where+    ForallTerm = forallTerm++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE ForallTerm #-}+#endif++-- | Pattern synonym for 'ExistsTerm''. Note that using this pattern to+-- construct a 'Term' will do term simplification.+pattern ExistsTerm ::+  forall r.+  () =>+  forall t.+  (r ~ Bool, SupportedNonFuncPrim t) =>+  TypedSymbol 'ConstantKind t ->+  Term Bool ->+  Term r+pattern ExistsTerm sym body <-+  (ExistsTerm' _ sym@SupportedConstantTypedSymbol body)+  where+    ExistsTerm = existsTerm++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE ExistsTerm #-}+#endif++-- | Pattern synonym for 'NotTerm''. Note that using this pattern to construct+-- a 'Term' will do term simplification.+pattern NotTerm :: forall r. () => (r ~ Bool) => Term Bool -> Term r+pattern NotTerm body <- (NotTerm' _ body)+  where+    NotTerm = pevalNotTerm++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE NotTerm #-}+#endif++-- | Pattern synonym for 'OrTerm''. Note that using this pattern to construct a+-- 'Term' will do term simplification.+pattern OrTerm :: forall r. () => (r ~ Bool) => Term Bool -> Term Bool -> Term r+pattern OrTerm l r <- (OrTerm' _ l r _)+  where+    OrTerm = pevalOrTerm++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE OrTerm #-}+#endif++-- | Pattern synonym for 'OrTerm''. Note that using this pattern to construct a+-- 'Term' will do term simplification.+pattern OrTermAll ::+  forall r.+  () =>+  (r ~ Bool) =>+  Term Bool -> Term Bool -> HS.HashSet (Term Bool) -> Term r+pattern OrTermAll l r s <- (OrTerm' _ l r s)++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE OrTermAll #-}+#endif++-- | Pattern synonym for 'AndTerm''. Note that using this pattern to construct a+-- 'Term' will do term simplification.+pattern AndTerm :: forall r. () => (r ~ Bool) => Term Bool -> Term Bool -> Term r+pattern AndTerm l r <- (AndTerm' _ l r _)+  where+    AndTerm = pevalAndTerm++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE AndTerm #-}+#endif++-- | Pattern synonym for 'AndTerm''. Note that using this pattern to construct a+-- 'Term' will do term simplification.+pattern AndTermAll ::+  forall r.+  () =>+  (r ~ Bool) =>+  Term Bool -> Term Bool -> HS.HashSet (Term Bool) -> Term r+pattern AndTermAll l r s <- (AndTerm' _ l r s)++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE AndTermAll #-}+#endif++-- | Pattern synonym for 'EqTerm''. Note that using this pattern to construct a+-- 'Term' will do term simplification.+pattern EqTerm ::+  forall r.+  () =>+  forall t.+  (r ~ Bool, SupportedPrim t) =>+  Term t ->+  Term t ->+  Term r+pattern EqTerm l r <- (EqTerm' _ l r@SupportedTerm)+  where+    EqTerm = pevalEqTerm++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE EqTerm #-}+#endif++-- | Pattern synonym for 'DistinctTerm''. Note that using this pattern to+-- construct a 'Term' will do term simplification.+pattern DistinctTerm ::+  forall r.+  () =>+  forall t.+  (r ~ Bool, SupportedPrim t) =>+  NonEmpty (Term t) ->+  Term r+pattern DistinctTerm ts <- (DistinctTerm' _ ts@(SupportedTerm :| _))+  where+    DistinctTerm = pevalDistinctTerm++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE DistinctTerm #-}+#endif++-- | Pattern synonym for 'ITETerm''. Note that using this pattern to construct a+-- 'Term' will do term simplification.+pattern ITETerm ::+  forall t.+  () =>+  (SupportedPrim t) =>+  Term Bool ->+  Term t ->+  Term t ->+  Term t+pattern ITETerm cond t1 t2 <- (ITETerm' _ cond t1 t2)+  where+    ITETerm = pevalITETerm++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE ITETerm #-}+#endif++-- | Pattern synonym for 'AddNumTerm''. Note that using this pattern to+-- construct a 'Term' will do term simplification.+pattern AddNumTerm ::+  forall t.+  () =>+  (SupportedPrim t, PEvalNumTerm t) =>+  Term t ->+  Term t ->+  Term t+pattern AddNumTerm l r <- (AddNumTerm' _ l r)+  where+    AddNumTerm = pevalAddNumTerm++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE AddNumTerm #-}+#endif++-- | Pattern synonym for 'NegNumTerm''. Note that using this pattern to+-- construct a 'Term' will do term simplification.+pattern NegNumTerm ::+  forall t.+  () =>+  (SupportedPrim t, PEvalNumTerm t) =>+  Term t ->+  Term t+pattern NegNumTerm t <- (NegNumTerm' _ t)+  where+    NegNumTerm = pevalNegNumTerm++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE NegNumTerm #-}+#endif++-- | Pattern synonym for 'MulNumTerm''. Note that using this pattern to+-- construct a 'Term' will do term simplification.+pattern MulNumTerm ::+  forall t.+  () =>+  (SupportedPrim t, PEvalNumTerm t) =>+  Term t ->+  Term t ->+  Term t+pattern MulNumTerm l r <- (MulNumTerm' _ l r)+  where+    MulNumTerm = pevalMulNumTerm++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE MulNumTerm #-}+#endif++-- | Pattern synonym for 'AbsNumTerm''. Note that using this pattern to+-- construct a 'Term' will do term simplification.+pattern AbsNumTerm ::+  forall t.+  () =>+  (SupportedPrim t, PEvalNumTerm t) =>+  Term t ->+  Term t+pattern AbsNumTerm t <- (AbsNumTerm' _ t)+  where+    AbsNumTerm = pevalAbsNumTerm++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE AbsNumTerm #-}+#endif++-- | Pattern synonym for 'SignumNumTerm''. Note that using this pattern to+-- construct a 'Term' will do term simplification.+pattern SignumNumTerm ::+  forall t.+  () =>+  (SupportedPrim t, PEvalNumTerm t) =>+  Term t ->+  Term t+pattern SignumNumTerm t <- (SignumNumTerm' _ t)+  where+    SignumNumTerm = pevalSignumNumTerm++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE SignumNumTerm #-}+#endif++-- | Pattern synonym for 'LtOrdTerm''. Note that using this pattern to construct+-- a 'Term' will do term simplification.+pattern LtOrdTerm ::+  forall r.+  () =>+  forall t.+  (r ~ Bool, SupportedPrim t, PEvalOrdTerm t) =>+  Term t ->+  Term t ->+  Term r+pattern LtOrdTerm l r <- (LtOrdTerm' _ l r@SupportedTerm)+  where+    LtOrdTerm = pevalLtOrdTerm++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE LtOrdTerm #-}+#endif++-- | Pattern synonym for 'LeOrdTerm''. Note that using this pattern to construct+-- a 'Term' will do term simplification.+pattern LeOrdTerm ::+  forall r.+  () =>+  forall t.+  (r ~ Bool, SupportedPrim t, PEvalOrdTerm t) =>+  Term t ->+  Term t ->+  Term r+pattern LeOrdTerm l r <- (LeOrdTerm' _ l r@SupportedTerm)+  where+    LeOrdTerm = pevalLeOrdTerm++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE LeOrdTerm #-}+#endif++-- | Pattern synonym for 'AndBitsTerm''. Note that using this pattern to+-- construct a 'Term' will do term simplification.+pattern AndBitsTerm ::+  forall t.+  () =>+  (SupportedPrim t, PEvalBitwiseTerm t) =>+  Term t ->+  Term t ->+  Term t+pattern AndBitsTerm l r <- (AndBitsTerm' _ l r)+  where+    AndBitsTerm = pevalAndBitsTerm++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE AndBitsTerm #-}+#endif++-- | Pattern synonym for 'OrBitsTerm''. Note that using this pattern to+-- construct a 'Term' will do term simplification.+pattern OrBitsTerm ::+  forall t.+  () =>+  (SupportedPrim t, PEvalBitwiseTerm t) =>+  Term t ->+  Term t ->+  Term t+pattern OrBitsTerm l r <- (OrBitsTerm' _ l r)+  where+    OrBitsTerm = pevalOrBitsTerm++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE OrBitsTerm #-}+#endif++-- | Pattern synonym for 'XorBitsTerm''. Note that using this pattern to+-- construct a 'Term' will do term simplification.+pattern XorBitsTerm ::+  forall t.+  () =>+  (SupportedPrim t, PEvalBitwiseTerm t) =>+  Term t ->+  Term t ->+  Term t+pattern XorBitsTerm l r <- (XorBitsTerm' _ l r)+  where+    XorBitsTerm = pevalXorBitsTerm++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE XorBitsTerm #-}+#endif++-- | Pattern synonym for 'ComplementBitsTerm''. Note that using this pattern to+-- construct a 'Term' will do term simplification.+pattern ComplementBitsTerm ::+  forall t.+  () =>+  (SupportedPrim t, PEvalBitwiseTerm t) =>+  Term t ->+  Term t+pattern ComplementBitsTerm t <- (ComplementBitsTerm' _ t)+  where+    ComplementBitsTerm = pevalComplementBitsTerm++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE ComplementBitsTerm #-}+#endif++-- | Pattern synonym for 'ShiftLeftTerm''. Note that using this pattern to+-- construct a 'Term' will do term simplification.+pattern ShiftLeftTerm ::+  forall t.+  () =>+  (SupportedPrim t, PEvalShiftTerm t) =>+  Term t ->+  Term t ->+  Term t+pattern ShiftLeftTerm l r <- (ShiftLeftTerm' _ l r)+  where+    ShiftLeftTerm = pevalShiftLeftTerm++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE ShiftLeftTerm #-}+#endif++-- | Pattern synonym for 'ShiftRightTerm''. Note that using this pattern to+-- construct a 'Term' will do term simplification.+pattern ShiftRightTerm ::+  forall t.+  () =>+  (SupportedPrim t, PEvalShiftTerm t) =>+  Term t ->+  Term t ->+  Term t+pattern ShiftRightTerm l r <- (ShiftRightTerm' _ l r)+  where+    ShiftRightTerm = pevalShiftRightTerm++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE ShiftRightTerm #-}+#endif++-- | Pattern synonym for 'RotateLeftTerm''. Note that using this pattern to+-- construct a 'Term' will do term simplification.+pattern RotateLeftTerm ::+  forall t.+  () =>+  (SupportedPrim t, PEvalRotateTerm t) =>+  Term t ->+  Term t ->+  Term t+pattern RotateLeftTerm l r <- (RotateLeftTerm' _ l r)+  where+    RotateLeftTerm = pevalRotateLeftTerm++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE RotateLeftTerm #-}+#endif++-- | Pattern synonym for 'RotateRightTerm''. Note that using this pattern to+-- construct a 'Term' will do term simplification.+pattern RotateRightTerm ::+  forall t.+  () =>+  (SupportedPrim t, PEvalRotateTerm t) =>+  Term t ->+  Term t ->+  Term t+pattern RotateRightTerm l r <- (RotateRightTerm' _ l r)+  where+    RotateRightTerm = pevalRotateRightTerm++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE RotateRightTerm #-}+#endif++-- | Pattern synonym for 'BitCastTerm''. Note that using this pattern to+-- construct a 'Term' will do term simplification.+pattern BitCastTerm ::+  forall b.+  () =>+  forall a.+  (SupportedPrim a, SupportedPrim b, PEvalBitCastTerm a b) =>+  Term a ->+  Term b+pattern BitCastTerm t <- (BitCastTerm' _ t@SupportedTerm)+  where+    BitCastTerm = pevalBitCastTerm++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE BitCastTerm #-}+#endif++-- | Pattern synonym for 'BitCastOrTerm''. Note that using this pattern to+-- construct a 'Term' will do term simplification.+pattern BitCastOrTerm ::+  forall b.+  () =>+  forall a.+  (SupportedPrim a, SupportedPrim b, PEvalBitCastOrTerm a b) =>+  Term b ->+  Term a ->+  Term b+pattern BitCastOrTerm t1 t2 <- (BitCastOrTerm' _ t1 t2@SupportedTerm)+  where+    BitCastOrTerm = pevalBitCastOrTerm++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE BitCastOrTerm #-}+#endif++-- | Pattern synonym for 'BVConcatTerm''. Note that using this pattern to+-- construct a 'Term' will do term simplification.+pattern BVConcatTerm ::+  forall ret.+  () =>+  forall bv l r.+  ( PEvalBVTerm bv,+    KnownNat l,+    KnownNat r,+    KnownNat (l + r),+    1 <= l,+    1 <= r,+    1 <= l + r,+    SupportedPrim (bv l),+    SupportedPrim (bv r),+    SupportedPrim (bv (l + r)),+    ret ~ bv (l + r)+  ) =>+  Term (bv l) ->+  Term (bv r) ->+  Term ret+pattern BVConcatTerm l r <- (BVConcatTerm' _ l@SupportedTerm r@SupportedTerm)+  where+    BVConcatTerm = pevalBVConcatTerm++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE BVConcatTerm #-}+#endif++-- | Pattern synonym for 'BVSelectTerm''. Note that using this pattern to+-- construct a 'Term' will do term simplification.+pattern BVSelectTerm ::+  forall ret.+  () =>+  forall bv w n ix.+  ( PEvalBVTerm bv,+    KnownNat n,+    KnownNat ix,+    KnownNat w,+    1 <= n,+    1 <= w,+    ix + w <= n,+    SupportedPrim (bv n),+    SupportedPrim (bv w),+    ret ~ bv w+  ) =>+  Proxy ix ->+  Proxy w ->+  Term (bv n) ->+  Term ret+pattern BVSelectTerm ix w t <- (BVSelectTerm' _ ix w t@SupportedTerm)+  where+    BVSelectTerm = pevalBVSelectTerm++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE BVSelectTerm #-}+#endif++-- | Pattern synonym for 'BVExtendTerm''. Note that using this pattern to+-- construct a 'Term' will do term simplification.+pattern BVExtendTerm ::+  forall ret.+  () =>+  forall bv l r.+  ( PEvalBVTerm bv,+    KnownNat l,+    KnownNat r,+    1 <= l,+    1 <= r,+    l <= r,+    SupportedPrim (bv l),+    SupportedPrim (bv r),+    ret ~ bv r+  ) =>+  Bool ->+  Proxy r ->+  Term (bv l) ->+  Term ret+pattern BVExtendTerm signed p t <- (BVExtendTerm' _ signed p t@SupportedTerm)+  where+    BVExtendTerm = pevalBVExtendTerm++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE BVExtendTerm #-}+#endif++-- | Pattern synonym for 'ApplyTerm''. Note that using this pattern to construct+-- a 'Term' will do term simplification.+pattern ApplyTerm ::+  forall b.+  () =>+  forall f a.+  (PEvalApplyTerm f a b, SupportedPrim f, SupportedPrim a, SupportedPrim b) =>+  Term f ->+  Term a ->+  Term b+pattern ApplyTerm f x <- (ApplyTerm' _ f@SupportedTerm x@SupportedTerm)+  where+    ApplyTerm = pevalApplyTerm++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE ApplyTerm #-}+#endif++-- | Pattern synonym for 'DivIntegralTerm''. Note that using this pattern to+-- construct a 'Term' will do term simplification.+pattern DivIntegralTerm ::+  forall t.+  () =>+  (SupportedPrim t, PEvalDivModIntegralTerm t) =>+  Term t ->+  Term t ->+  Term t+pattern DivIntegralTerm l r <- (DivIntegralTerm' _ l r)+  where+    DivIntegralTerm = pevalDivIntegralTerm++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE DivIntegralTerm #-}+#endif++-- | Pattern synonym for 'ModIntegralTerm''. Note that using this pattern to+-- construct a 'Term' will do term simplification.+pattern ModIntegralTerm ::+  forall t.+  () =>+  (SupportedPrim t, PEvalDivModIntegralTerm t) =>+  Term t ->+  Term t ->+  Term t+pattern ModIntegralTerm l r <- (ModIntegralTerm' _ l r)+  where+    ModIntegralTerm = pevalModIntegralTerm++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE ModIntegralTerm #-}+#endif++-- | Pattern synonym for 'QuotIntegralTerm''. Note that using this pattern to+-- construct a 'Term' will do term simplification.+pattern QuotIntegralTerm ::+  forall t.+  () =>+  (SupportedPrim t, PEvalDivModIntegralTerm t) =>+  Term t ->+  Term t ->+  Term t+pattern QuotIntegralTerm l r <- (QuotIntegralTerm' _ l r)+  where+    QuotIntegralTerm = pevalQuotIntegralTerm++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE QuotIntegralTerm #-}+#endif++-- | Pattern synonym for 'RemIntegralTerm''. Note that using this pattern to+-- construct a 'Term' will do term simplification.+pattern RemIntegralTerm ::+  forall t.+  () =>+  (SupportedPrim t, PEvalDivModIntegralTerm t) =>+  Term t ->+  Term t ->+  Term t+pattern RemIntegralTerm l r <- (RemIntegralTerm' _ l r)+  where+    RemIntegralTerm = pevalRemIntegralTerm++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE RemIntegralTerm #-}+#endif++-- | Pattern synonym for 'FPTraitTerm''. Note that using this pattern to+-- construct a 'Term' will do term simplification.+pattern FPTraitTerm ::+  forall r.+  () =>+  forall eb sb fp.+  (r ~ Bool, ValidFP eb sb, SupportedPrim (fp eb sb), PEvalFPTerm fp) =>+  FPTrait ->+  Term (fp eb sb) ->+  Term r+pattern FPTraitTerm trait t <- (FPTraitTerm' _ trait t)+  where+    FPTraitTerm = pevalFPTraitTerm++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE FPTraitTerm #-}+#endif++-- | Pattern synonym for 'FdivTerm''. Note that using this pattern to construct+-- a 'Term' will do term simplification.+pattern FdivTerm ::+  forall t.+  () =>+  (SupportedPrim t, PEvalFractionalTerm t) =>+  Term t ->+  Term t ->+  Term t+pattern FdivTerm l r <- (FdivTerm' _ l r)+  where+    FdivTerm = pevalFdivTerm++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE FdivTerm #-}+#endif++-- | Pattern synonym for 'RecipTerm''. Note that using this pattern to construct+-- a 'Term' will do term simplification.+pattern RecipTerm ::+  forall t.+  () =>+  (SupportedPrim t, PEvalFractionalTerm t) =>+  Term t ->+  Term t+pattern RecipTerm t <- (RecipTerm' _ t)+  where+    RecipTerm = pevalRecipTerm++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE RecipTerm #-}+#endif++-- | Pattern synonym for 'FloatingUnaryTerm''. Note that using this pattern to+-- construct a 'Term' will do term simplification.+pattern FloatingUnaryTerm ::+  forall t.+  () =>+  (SupportedPrim t, PEvalFloatingTerm t) =>+  FloatingUnaryOp ->+  Term t ->+  Term t+pattern FloatingUnaryTerm op t <- (FloatingUnaryTerm' _ op t)+  where+    FloatingUnaryTerm = pevalFloatingUnaryTerm++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE FloatingUnaryTerm #-}+#endif++-- | Pattern synonym for 'PowerTerm''. Note that using this pattern to construct+-- a 'Term' will do term simplification.+pattern PowerTerm ::+  forall t.+  () =>+  (SupportedPrim t, PEvalFloatingTerm t) =>+  Term t ->+  Term t ->+  Term t+pattern PowerTerm l r <- (PowerTerm' _ l r)+  where+    PowerTerm = pevalPowerTerm++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE PowerTerm #-}+#endif++-- | Pattern synonym for 'FPUnaryTerm''. Note that using this pattern to construct+-- a 'Term' will do term simplification.+pattern FPUnaryTerm ::+  forall ret.+  () =>+  forall fp eb sb.+  (ret ~ fp eb sb, ValidFP eb sb, SupportedPrim (fp eb sb), PEvalFPTerm fp) =>+  FPUnaryOp ->+  Term (fp eb sb) ->+  Term ret+pattern FPUnaryTerm op t <- (FPUnaryTerm' _ op t)+  where+    FPUnaryTerm = pevalFPUnaryTerm++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE FPUnaryTerm #-}+#endif++-- | Pattern synonym for 'FPBinaryTerm''. Note that using this pattern to construct+-- a 'Term' will do term simplification.+pattern FPBinaryTerm ::+  forall ret.+  () =>+  forall fp eb sb.+  (ret ~ fp eb sb, ValidFP eb sb, SupportedPrim (fp eb sb), PEvalFPTerm fp) =>+  FPBinaryOp ->+  Term (fp eb sb) ->+  Term (fp eb sb) ->+  Term ret+pattern FPBinaryTerm op l r <- (FPBinaryTerm' _ op l r)+  where+    FPBinaryTerm = pevalFPBinaryTerm++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE FPBinaryTerm #-}+#endif++-- | Pattern synonym for 'FPRoundingUnaryTerm''. Note that using this pattern to+-- construct a 'Term' will do term simplification.+pattern FPRoundingUnaryTerm ::+  forall ret.+  () =>+  forall fp eb sb.+  (ret ~ fp eb sb, ValidFP eb sb, SupportedPrim (fp eb sb), PEvalFPTerm fp) =>+  FPRoundingUnaryOp ->+  Term FPRoundingMode ->+  Term (fp eb sb) ->+  Term ret+pattern FPRoundingUnaryTerm op rm t <- (FPRoundingUnaryTerm' _ op rm t)+  where+    FPRoundingUnaryTerm = pevalFPRoundingUnaryTerm++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE FPRoundingUnaryTerm #-}+#endif++-- | Pattern synonym for 'FPRoundingBinaryTerm''. Note that using this pattern to+-- construct a 'Term' will do term simplification.+pattern FPRoundingBinaryTerm ::+  forall ret.+  () =>+  forall fp eb sb.+  (ret ~ fp eb sb, ValidFP eb sb, SupportedPrim (fp eb sb), PEvalFPTerm fp) =>+  FPRoundingBinaryOp ->+  Term FPRoundingMode ->+  Term (fp eb sb) ->+  Term (fp eb sb) ->+  Term ret+pattern FPRoundingBinaryTerm op rm l r <- (FPRoundingBinaryTerm' _ op rm l r)+  where+    FPRoundingBinaryTerm = pevalFPRoundingBinaryTerm++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE FPRoundingBinaryTerm #-}+#endif++-- | Pattern synonym for 'FPFMATerm''. Note that using this pattern to construct+-- a 'Term' will do term simplification.+pattern FPFMATerm ::+  forall ret.+  () =>+  forall fp eb sb.+  (ret ~ fp eb sb, ValidFP eb sb, SupportedPrim (fp eb sb), PEvalFPTerm fp) =>+  Term FPRoundingMode ->+  Term (fp eb sb) ->+  Term (fp eb sb) ->+  Term (fp eb sb) ->+  Term ret+pattern FPFMATerm rm t1 t2 t3 <- (FPFMATerm' _ rm t1 t2 t3)+  where+    FPFMATerm = pevalFPFMATerm++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE FPFMATerm #-}+#endif++-- | Pattern synonym for 'FromIntegralTerm''. Note that using this pattern to+-- construct a 'Term' will do term simplification.+pattern FromIntegralTerm ::+  forall b.+  () =>+  forall a.+  (PEvalFromIntegralTerm a b, SupportedPrim a, SupportedPrim b) =>+  Term a ->+  Term b+pattern FromIntegralTerm t <- (FromIntegralTerm' _ t@SupportedTerm)+  where+    FromIntegralTerm = pevalFromIntegralTerm++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE FromIntegralTerm #-}+#endif++-- | Pattern synonym for 'FromFPOrTerm''. Note that using this pattern to construct+-- a 'Term' will do term simplification.+pattern FromFPOrTerm ::+  forall a.+  () =>+  forall eb sb.+  ( PEvalIEEEFPConvertibleTerm a,+    ValidFP eb sb,+    SupportedPrim a+  ) =>+  Term a ->+  Term FPRoundingMode ->+  Term (FP eb sb) ->+  Term a+pattern FromFPOrTerm t1 rm t2 <- (FromFPOrTerm' _ t1 rm t2)+  where+    FromFPOrTerm = pevalFromFPOrTerm++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE FromFPOrTerm #-}+#endif++-- | Pattern synonym for 'ToFPTerm''. Note that using this pattern to construct+-- a 'Term' will do term simplification.+pattern ToFPTerm ::+  forall ret.+  () =>+  forall eb sb a.+  ( PEvalIEEEFPConvertibleTerm a,+    ValidFP eb sb,+    SupportedPrim (FP eb sb),+    SupportedPrim a,+    ret ~ FP eb sb+  ) =>+  Term FPRoundingMode ->+  Term a ->+  Proxy eb ->+  Proxy sb ->+  Term ret+pattern ToFPTerm rm t eb sb <- (ToFPTerm' _ rm t@SupportedTerm eb sb)+  where+    ToFPTerm rm t _ _ = pevalToFPTerm rm t++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE ToFPTerm #-}+#endif++#if MIN_VERSION_base(4, 16, 4)+{-# COMPLETE+  ConTerm,+  SymTerm,+  ForallTerm,+  ExistsTerm,+  NotTerm,+  OrTerm,+  AndTerm,+  EqTerm,+  DistinctTerm,+  ITETerm,+  AddNumTerm,+  NegNumTerm,+  MulNumTerm,+  AbsNumTerm,+  SignumNumTerm,+  LtOrdTerm,+  LeOrdTerm,+  AndBitsTerm,+  OrBitsTerm,+  XorBitsTerm,+  ComplementBitsTerm,+  ShiftLeftTerm,+  ShiftRightTerm,+  RotateLeftTerm,+  RotateRightTerm,+  BitCastTerm,+  BitCastOrTerm,+  BVConcatTerm,+  BVSelectTerm,+  BVExtendTerm,+  ApplyTerm,+  DivIntegralTerm,+  ModIntegralTerm,+  QuotIntegralTerm,+  RemIntegralTerm,+  FPTraitTerm,+  FdivTerm,+  RecipTerm,+  FloatingUnaryTerm,+  PowerTerm,+  FPUnaryTerm,+  FPBinaryTerm,+  FPRoundingUnaryTerm,+  FPRoundingBinaryTerm,+  FPFMATerm,+  FromIntegralTerm,+  FromFPOrTerm,+  ToFPTerm+  #-}+#endif++-- | Get the cached information for a term.+termInfo :: Term t -> CachedInfo+termInfo (ConTerm' i _) = i+termInfo (SymTerm' i _) = i+termInfo (ForallTerm' i _ _) = i+termInfo (ExistsTerm' i _ _) = i+termInfo (NotTerm' i _) = i+termInfo (OrTerm' i _ _ _) = i+termInfo (AndTerm' i _ _ _) = i+termInfo (EqTerm' i _ _) = i+termInfo (DistinctTerm' i _) = i+termInfo (ITETerm' i _ _ _) = i+termInfo (AddNumTerm' i _ _) = i+termInfo (NegNumTerm' i _) = i+termInfo (MulNumTerm' i _ _) = i+termInfo (AbsNumTerm' i _) = i+termInfo (SignumNumTerm' i _) = i+termInfo (LtOrdTerm' i _ _) = i+termInfo (LeOrdTerm' i _ _) = i+termInfo (AndBitsTerm' i _ _) = i+termInfo (OrBitsTerm' i _ _) = i+termInfo (XorBitsTerm' i _ _) = i+termInfo (ComplementBitsTerm' i _) = i+termInfo (ShiftLeftTerm' i _ _) = i+termInfo (ShiftRightTerm' i _ _) = i+termInfo (RotateLeftTerm' i _ _) = i+termInfo (RotateRightTerm' i _ _) = i+termInfo (BitCastTerm' i _) = i+termInfo (BitCastOrTerm' i _ _) = i+termInfo (BVConcatTerm' i _ _) = i+termInfo (BVSelectTerm' i _ _ _) = i+termInfo (BVExtendTerm' i _ _ _) = i+termInfo (ApplyTerm' i _ _) = i+termInfo (DivIntegralTerm' i _ _) = i+termInfo (ModIntegralTerm' i _ _) = i+termInfo (QuotIntegralTerm' i _ _) = i+termInfo (RemIntegralTerm' i _ _) = i+termInfo (FPTraitTerm' i _ _) = i+termInfo (FdivTerm' i _ _) = i+termInfo (RecipTerm' i _) = i+termInfo (FloatingUnaryTerm' i _ _) = i+termInfo (PowerTerm' i _ _) = i+termInfo (FPUnaryTerm' i _ _) = i+termInfo (FPBinaryTerm' i _ _ _) = i+termInfo (FPRoundingUnaryTerm' i _ _ _) = i+termInfo (FPRoundingBinaryTerm' i _ _ _ _) = i+termInfo (FPFMATerm' i _ _ _ _) = i+termInfo (FromIntegralTerm' i _) = i+termInfo (FromFPOrTerm' i _ _ _) = i+termInfo (ToFPTerm' i _ _ _ _) = i++-- | Get the thread ID for a term.+{-# INLINE termThreadId #-}+termThreadId :: Term t -> WeakThreadId+termThreadId = cachedThreadId . termInfo++-- | Get the digest for a term.+{-# INLINE termDigest #-}+termDigest :: Term t -> Digest+termDigest = cachedDigest . termInfo++-- | Get the ID for a term.+{-# INLINE termId #-}+termId :: Term t -> Id+termId = cachedId . termInfo++-- | Get the stable identifier for a term.+{-# INLINE termStableIdent #-}+termStableIdent :: Term t -> StableIdent+termStableIdent = cachedStableIdent . termInfo++-- | Pattern for term with dynamic typing.+pattern DynTerm :: forall a b. (SupportedPrim a) => Term a -> Term b+pattern DynTerm x <- ((\v@SupportedTerm -> cast v) -> Just x)++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE DynTerm #-}+#endif++-- baseHash :: Term t -> Digest+-- baseHash t = case hashId t of+--   HashId h _ -> h+-- {-# INLINE baseHash #-}++data HashId = HashId {-# UNPACK #-} !Digest Id deriving (Show)++instance Eq HashId where+  HashId _ l == HashId _ r = l == r+  {-# INLINE (==) #-}++instance Hashable HashId where+  hashWithSalt s (HashId i _) = hashWithSalt s i+  {-# INLINE hashWithSalt #-}++eqHashId :: HashId -> HashId -> Bool+eqHashId = (==)+{-# INLINE eqHashId #-}++data TypeHashId = TypeHashId {-# UNPACK #-} !Fingerprint {-# UNPACK #-} !HashId+  deriving (Show)++instance Eq TypeHashId where+  TypeHashId l li == TypeHashId r ri = l == r && li == ri+  {-# INLINE (==) #-}++instance Hashable TypeHashId where+  hashWithSalt s (TypeHashId tp i) = s `hashWithSalt` tp `hashWithSalt` i+  {-# INLINE hashWithSalt #-}++{-# INLINE termHashId #-}+termHashId :: Term t -> HashId+termHashId t = HashId (termDigest t) (termId t)++typeFingerprint :: forall t. (SupportedPrim t) => Fingerprint+typeFingerprint = typeRepFingerprint $ SomeTypeRep $ primTypeRep @t+{-# INLINE typeFingerprint #-}++{-# INLINE termTypeHashId #-}+termTypeHashId :: forall t. Term t -> TypeHashId+termTypeHashId t@SupportedTerm = TypeHashId (typeFingerprint @t) (termHashId t)++-- {-# NOINLINE typeHashId #-}+introSupportedPrimConstraint0 :: forall t a. Term t -> ((SupportedPrim t) => a) -> a+introSupportedPrimConstraint0 ConTerm' {} x = x+introSupportedPrimConstraint0 (SymTerm' _ t) x = withSymbolSupported t x+introSupportedPrimConstraint0 ForallTerm' {} x = x+introSupportedPrimConstraint0 ExistsTerm' {} x = x+introSupportedPrimConstraint0 NotTerm' {} x = x+introSupportedPrimConstraint0 OrTerm' {} x = x+introSupportedPrimConstraint0 AndTerm' {} x = x+introSupportedPrimConstraint0 EqTerm' {} x = x+introSupportedPrimConstraint0 DistinctTerm' {} x = x+introSupportedPrimConstraint0 ITETerm' {} x = x+introSupportedPrimConstraint0 AddNumTerm' {} x = x+introSupportedPrimConstraint0 NegNumTerm' {} x = x+introSupportedPrimConstraint0 MulNumTerm' {} x = x+introSupportedPrimConstraint0 AbsNumTerm' {} x = x+introSupportedPrimConstraint0 SignumNumTerm' {} x = x+introSupportedPrimConstraint0 LtOrdTerm' {} x = x+introSupportedPrimConstraint0 LeOrdTerm' {} x = x+introSupportedPrimConstraint0 AndBitsTerm' {} x = x+introSupportedPrimConstraint0 OrBitsTerm' {} x = x+introSupportedPrimConstraint0 XorBitsTerm' {} x = x+introSupportedPrimConstraint0 ComplementBitsTerm' {} x = x+introSupportedPrimConstraint0 ShiftLeftTerm' {} x = x+introSupportedPrimConstraint0 RotateLeftTerm' {} x = x+introSupportedPrimConstraint0 ShiftRightTerm' {} x = x+introSupportedPrimConstraint0 RotateRightTerm' {} x = x+introSupportedPrimConstraint0 BitCastTerm' {} x = x+introSupportedPrimConstraint0 BitCastOrTerm' {} x = x+introSupportedPrimConstraint0 BVConcatTerm' {} x = x+introSupportedPrimConstraint0 BVSelectTerm' {} x = x+introSupportedPrimConstraint0 BVExtendTerm' {} x = x+introSupportedPrimConstraint0 ApplyTerm' {} x = x+introSupportedPrimConstraint0 DivIntegralTerm' {} x = x+introSupportedPrimConstraint0 ModIntegralTerm' {} x = x+introSupportedPrimConstraint0 QuotIntegralTerm' {} x = x+introSupportedPrimConstraint0 RemIntegralTerm' {} x = x+introSupportedPrimConstraint0 FPTraitTerm' {} x = x+introSupportedPrimConstraint0 FdivTerm' {} x = x+introSupportedPrimConstraint0 RecipTerm' {} x = x+introSupportedPrimConstraint0 FloatingUnaryTerm' {} x = x+introSupportedPrimConstraint0 PowerTerm' {} x = x+introSupportedPrimConstraint0 FPUnaryTerm' {} x = x+introSupportedPrimConstraint0 FPBinaryTerm' {} x = x+introSupportedPrimConstraint0 FPRoundingUnaryTerm' {} x = x+introSupportedPrimConstraint0 FPRoundingBinaryTerm' {} x = x+introSupportedPrimConstraint0 FPFMATerm' {} x = x+introSupportedPrimConstraint0 FromIntegralTerm' {} x = x+introSupportedPrimConstraint0 FromFPOrTerm' {} x = x+introSupportedPrimConstraint0 ToFPTerm' {} x = x++-- | Introduce the 'SupportedPrim' constraint from a term.+introSupportedPrimConstraint ::+  forall t a. Term t -> ((SupportedPrim t, Typeable t) => a) -> a+introSupportedPrimConstraint t a = introSupportedPrimConstraint0 t a+{-# INLINE introSupportedPrimConstraint #-}++-- | Pretty-print a term.+pformatTerm :: forall t. Term t -> String+pformatTerm (ConTerm t) = pformatCon t+pformatTerm (SymTerm sym) = showUntyped sym+pformatTerm (ForallTerm sym arg) = "(forall " ++ show sym ++ " " ++ pformatTerm arg ++ ")"+pformatTerm (ExistsTerm sym arg) = "(exists " ++ show sym ++ " " ++ pformatTerm arg ++ ")"+pformatTerm (NotTerm arg) = "(! " ++ pformatTerm arg ++ ")"+pformatTerm (OrTerm arg1 arg2) = "(|| " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")"+pformatTerm (AndTerm arg1 arg2) = "(&& " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")"+pformatTerm (EqTerm arg1 arg2) = "(= " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")"+pformatTerm (DistinctTerm args) = "(distinct " ++ unwords (map pformatTerm $ toList args) ++ ")"+pformatTerm (ITETerm cond arg1 arg2) = "(ite " ++ pformatTerm cond ++ " " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")"+pformatTerm (AddNumTerm arg1 arg2) = "(+ " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")"+pformatTerm (NegNumTerm arg) = "(- " ++ pformatTerm arg ++ ")"+pformatTerm (MulNumTerm arg1 arg2) = "(* " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")"+pformatTerm (AbsNumTerm arg) = "(abs " ++ pformatTerm arg ++ ")"+pformatTerm (SignumNumTerm arg) = "(signum " ++ pformatTerm arg ++ ")"+pformatTerm (LtOrdTerm arg1 arg2) = "(< " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")"+pformatTerm (LeOrdTerm arg1 arg2) = "(<= " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")"+pformatTerm (AndBitsTerm arg1 arg2) = "(& " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")"+pformatTerm (OrBitsTerm arg1 arg2) = "(| " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")"+pformatTerm (XorBitsTerm arg1 arg2) = "(^ " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")"+pformatTerm (ComplementBitsTerm arg) = "(~ " ++ pformatTerm arg ++ ")"+pformatTerm (ShiftLeftTerm arg n) = "(shl " ++ pformatTerm arg ++ " " ++ pformatTerm n ++ ")"+pformatTerm (ShiftRightTerm arg n) = "(shr " ++ pformatTerm arg ++ " " ++ pformatTerm n ++ ")"+pformatTerm (RotateLeftTerm arg n) = "(rotl " ++ pformatTerm arg ++ " " ++ pformatTerm n ++ ")"+pformatTerm (RotateRightTerm arg n) = "(rotr " ++ pformatTerm arg ++ " " ++ pformatTerm n ++ ")"+pformatTerm (BitCastTerm arg) = "(bitcast " ++ pformatTerm arg ++ ")"+pformatTerm (BitCastOrTerm d arg) = "(bitcast_or " ++ pformatTerm d ++ " " ++ pformatTerm arg ++ ")"+pformatTerm (BVConcatTerm arg1 arg2) = "(bvconcat " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")"+pformatTerm (BVSelectTerm (_ :: Proxy ix) (_ :: Proxy w) arg) =+  "(bvselect " ++ show (typeRep @ix) ++ " " ++ show (typeRep @w) ++ " " ++ pformatTerm arg ++ ")"+pformatTerm (BVExtendTerm signed (_ :: Proxy n) arg) =+  (if signed then "(bvsext " else "(bvzext ") ++ show (typeRep @n) ++ " " ++ pformatTerm arg ++ ")"+pformatTerm (ApplyTerm func arg) = "(apply " ++ pformatTerm func ++ " " ++ pformatTerm arg ++ ")"+pformatTerm (DivIntegralTerm arg1 arg2) = "(div " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")"+pformatTerm (ModIntegralTerm arg1 arg2) = "(mod " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")"+pformatTerm (QuotIntegralTerm arg1 arg2) = "(quot " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")"+pformatTerm (RemIntegralTerm arg1 arg2) = "(rem " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")"+pformatTerm (FPTraitTerm trait arg) = "(" ++ show trait ++ " " ++ pformatTerm arg ++ ")"+pformatTerm (FdivTerm arg1 arg2) = "(fdiv " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")"+pformatTerm (RecipTerm arg) = "(recip " ++ pformatTerm arg ++ ")"+pformatTerm (FloatingUnaryTerm op arg) = "(" ++ show op ++ " " ++ pformatTerm arg ++ ")"+pformatTerm (PowerTerm arg1 arg2) = "(** " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")"+pformatTerm (FPUnaryTerm op arg) = "(" ++ show op ++ " " ++ pformatTerm arg ++ ")"+pformatTerm (FPBinaryTerm op arg1 arg2) = "(" ++ show op ++ " " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")"+pformatTerm (FPRoundingUnaryTerm op mode arg) = "(" ++ show op ++ " " ++ pformatTerm mode ++ " " ++ pformatTerm arg ++ ")"+pformatTerm (FPRoundingBinaryTerm op mode arg1 arg2) =+  "(" ++ show op ++ " " ++ pformatTerm mode ++ " " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")"+pformatTerm (FPFMATerm mode arg1 arg2 arg3) =+  "(fp.fma " ++ pformatTerm mode ++ " " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ " " ++ pformatTerm arg3 ++ ")"+pformatTerm (FromIntegralTerm arg) = "(from_integral " ++ pformatTerm arg ++ ")"+pformatTerm (FromFPOrTerm d r arg) = "(from_fp_or " ++ pformatTerm d ++ " " ++ pformatTerm r ++ " " ++ pformatTerm arg ++ ")"+pformatTerm (ToFPTerm r arg _ _) = "(to_fp " ++ pformatTerm r ++ " " ++ pformatTerm arg ++ ")"++-- {-# INLINE pformatTerm #-}++instance NFData (Term a) where+  rnf i = rnf (termInfo i)+  {-# INLINE rnf #-}++#if MIN_VERSION_base(4,15,0)+type CODE x = forall qq. Quote qq => Code qq (x)+#else+type CODE x = TExpQ x+#endif++instance Lift (Term t) where+  liftTyped (ConTerm v) = [||conTerm v||]+  liftTyped (SymTerm t) = [||symTerm t||]+  liftTyped (ForallTerm t1 t2) = [||forallTerm t1 t2||]+  liftTyped (ExistsTerm t1 t2) = [||existsTerm t1 t2||]+  liftTyped (NotTerm t) = [||notTerm t||]+  liftTyped (OrTerm t1 t2) = [||orTerm t1 t2||]+  liftTyped (AndTerm t1 t2) = [||andTerm t1 t2||]+  liftTyped (EqTerm t1 t2) = [||eqTerm t1 t2||]+  liftTyped (DistinctTerm t) = [||distinctTerm t||]+  liftTyped (ITETerm t1 t2 t3) = [||iteTerm t1 t2 t3||]+  liftTyped (AddNumTerm t1 t2) = [||addNumTerm t1 t2||]+  liftTyped (NegNumTerm t) = [||negNumTerm t||]+  liftTyped (MulNumTerm t1 t2) = [||mulNumTerm t1 t2||]+  liftTyped (AbsNumTerm t) = [||absNumTerm t||]+  liftTyped (SignumNumTerm t) = [||signumNumTerm t||]+  liftTyped (LtOrdTerm t1 t2) = [||ltOrdTerm t1 t2||]+  liftTyped (LeOrdTerm t1 t2) = [||leOrdTerm t1 t2||]+  liftTyped (AndBitsTerm t1 t2) = [||andBitsTerm t1 t2||]+  liftTyped (OrBitsTerm t1 t2) = [||orBitsTerm t1 t2||]+  liftTyped (XorBitsTerm t1 t2) = [||xorBitsTerm t1 t2||]+  liftTyped (ComplementBitsTerm t) = [||complementBitsTerm t||]+  liftTyped (ShiftLeftTerm t1 t2) = [||shiftLeftTerm t1 t2||]+  liftTyped (ShiftRightTerm t1 t2) = [||shiftRightTerm t1 t2||]+  liftTyped (RotateLeftTerm t1 t2) = [||rotateLeftTerm t1 t2||]+  liftTyped (RotateRightTerm t1 t2) = [||rotateRightTerm t1 t2||]+  liftTyped (BitCastTerm t) = [||bitCastTerm t||]+  liftTyped (BitCastOrTerm t1 t2) = [||bitCastOrTerm t1 t2||]+  liftTyped (BVConcatTerm t1 t2) = [||bvConcatTerm t1 t2||]+  liftTyped (BVSelectTerm (_ :: p ix) (_ :: q w) t3) =+    let pix = [||Proxy||] :: CODE (Proxy ix)+        pw = [||Proxy||] :: CODE (Proxy w)+     in [||bvSelectTerm $$pix $$pw t3||]+  liftTyped (BVExtendTerm b (_ :: p r) t2) =+    let pr = [||Proxy||] :: CODE (Proxy r)+     in [||bvExtendTerm b $$pr t2||]+  liftTyped (ApplyTerm t1 t2) = [||applyTerm t1 t2||]+  liftTyped (DivIntegralTerm t1 t2) = [||divIntegralTerm t1 t2||]+  liftTyped (ModIntegralTerm t1 t2) = [||modIntegralTerm t1 t2||]+  liftTyped (QuotIntegralTerm t1 t2) = [||quotIntegralTerm t1 t2||]+  liftTyped (RemIntegralTerm t1 t2) = [||remIntegralTerm t1 t2||]+  liftTyped (FPTraitTerm t1 t2) = [||fpTraitTerm t1 t2||]+  liftTyped (FdivTerm t1 t2) = [||fdivTerm t1 t2||]+  liftTyped (RecipTerm t) = [||recipTerm t||]+  liftTyped (FloatingUnaryTerm t1 t2) = [||floatingUnaryTerm t1 t2||]+  liftTyped (PowerTerm t1 t2) = [||powerTerm t1 t2||]+  liftTyped (FPUnaryTerm t1 t2) = [||fpUnaryTerm t1 t2||]+  liftTyped (FPBinaryTerm t1 t2 t3) = [||fpBinaryTerm t1 t2 t3||]+  liftTyped (FPRoundingUnaryTerm t1 t2 t3) =+    [||fpRoundingUnaryTerm t1 t2 t3||]+  liftTyped (FPRoundingBinaryTerm t1 t2 t3 t4) =+    [||fpRoundingBinaryTerm t1 t2 t3 t4||]+  liftTyped (FPFMATerm t1 t2 t3 t4) = [||fpFMATerm t1 t2 t3 t4||]+  liftTyped (FromIntegralTerm t) = [||fromIntegralTerm t||]+  liftTyped (FromFPOrTerm t1 t2 t3) = [||fromFPOrTerm t1 t2 t3||]+  liftTyped (ToFPTerm t1 t2 _ _) =+    [||toFPTerm t1 t2||]++instance Show (Term ty) where+  show t@(ConTerm v) =+    "ConTerm{tid="+      ++ show (termThreadId t)+      ++ ", id="+      ++ show (termId t)+      ++ ", v="+      ++ pformatCon v+      ++ "}"+  show t@(SymTerm name@TypedSymbol {}) =+    "SymTerm{tid="+      ++ show (termThreadId t)+      ++ ", id="+      ++ show (termId t)+      ++ ", name="+      ++ show name+      ++ ", type="+      ++ show (primTypeRep @ty)+      ++ "}"+  show t@(ForallTerm sym arg) =+    "Forall{tid="+      ++ show (termThreadId t)+      ++ ", id="+      ++ show (termId t)+      ++ ", sym="+      ++ show sym+      ++ ", arg="+      ++ show arg+      ++ "}"+  show t@(ExistsTerm sym arg) =+    "Exists{tid="+      ++ show (termThreadId t)+      ++ ", id="+      ++ show (termId t)+      ++ ", sym="+      ++ show sym+      ++ ", arg="+      ++ show arg+      ++ "}"+  show t@(NotTerm arg) =+    "Not{tid=" ++ show (termThreadId t) ++ ", id=" ++ show (termId t) ++ ", arg=" ++ show arg ++ "}"+  show t@(OrTerm arg1 arg2) =+    "Or{tid="+      ++ show (termThreadId t)+      ++ ", id="+      ++ show (termId t)+      ++ ", arg1="+      ++ show arg1+      ++ ", arg2="+      ++ show arg2+      ++ "}"+  show t@(AndTerm arg1 arg2) =+    "And{tid="+      ++ show (termThreadId t)+      ++ ", id="+      ++ show (termId t)+      ++ ", arg1="+      ++ show arg1+      ++ ", arg2="+      ++ show arg2+      ++ "}"+  show t@(EqTerm arg1 arg2) =+    "Eqv{tid="+      ++ show (termThreadId t)+      ++ ", id="+      ++ show (termId t)+      ++ ", arg1="+      ++ show arg1+      ++ ", arg2="+      ++ show arg2+      ++ "}"+  show t@(DistinctTerm args) =+    "Distinct{tid="+      ++ show (termThreadId t)+      ++ ", id="+      ++ show (termId t)+      ++ ", args="+      ++ show args+      ++ "}"+  show t@(ITETerm cond l r) =+    "ITE{tid="+      ++ show (termThreadId t)+      ++ ", id="+      ++ show (termId t)+      ++ ", cond="+      ++ show cond+      ++ ", then="+      ++ show l+      ++ ", else="+      ++ show r+      ++ "}"+  show t@(AddNumTerm arg1 arg2) =+    "AddNum{tid="+      ++ show (termThreadId t)+      ++ ", id="+      ++ show (termId t)+      ++ ", arg1="+      ++ show arg1+      ++ ", arg2="+      ++ show arg2+      ++ "}"+  show t@(NegNumTerm arg) =+    "NegNum{tid="+      ++ show (termThreadId t)+      ++ ", id="+      ++ show (termId t)+      ++ ", arg="+      ++ show arg+      ++ "}"+  show t@(MulNumTerm arg1 arg2) =+    "MulNum{tid="+      ++ show (termThreadId t)+      ++ ", id="+      ++ show (termId t)+      ++ ", arg1="+      ++ show arg1+      ++ ", arg2="+      ++ show arg2+      ++ "}"+  show t@(AbsNumTerm arg) =+    "AbsNum{tid="+      ++ show (termThreadId t)+      ++ ", id="+      ++ show (termId t)+      ++ ", arg="+      ++ show arg+      ++ "}"+  show t@(SignumNumTerm arg) =+    "SignumNum{tid="+      ++ show (termThreadId t)+      ++ ", id="+      ++ show (termId t)+      ++ ", arg="+      ++ show arg+      ++ "}"+  show t@(LtOrdTerm arg1 arg2) =+    "LTNum{tid="+      ++ show (termThreadId t)+      ++ ", id="+      ++ show (termId t)+      ++ ", arg1="+      ++ show arg1+      ++ ", arg2="+      ++ show arg2+      ++ "}"+  show t@(LeOrdTerm arg1 arg2) =+    "LENum{tid="+      ++ show (termThreadId t)+      ++ ", id="+      ++ show (termId t)+      ++ ", arg1="+      ++ show arg1+      ++ ", arg2="+      ++ show arg2+      ++ "}"+  show t@(AndBitsTerm arg1 arg2) =+    "AndBits{tid="+      ++ show (termThreadId t)+      ++ ", id="+      ++ show (termId t)+      ++ ", arg1="+      ++ show arg1+      ++ ", arg2="+      ++ show arg2+      ++ "}"+  show t@(OrBitsTerm arg1 arg2) =+    "OrBits{tid="+      ++ show (termThreadId t)+      ++ ", id="+      ++ show (termId t)+      ++ ", arg1="+      ++ show arg1+      ++ ", arg2="+      ++ show arg2+      ++ "}"+  show t@(XorBitsTerm arg1 arg2) =+    "XorBits{tid="+      ++ show (termThreadId t)+      ++ ", id="+      ++ show (termId t)+      ++ ", arg1="+      ++ show arg1+      ++ ", arg2="+      ++ show arg2+      ++ "}"+  show t@(ComplementBitsTerm arg) =+    "ComplementBits{tid="+      ++ show (termThreadId t)+      ++ ", id="+      ++ show (termId t)+      ++ ", arg="+      ++ show arg+      ++ "}"+  show t@(ShiftLeftTerm arg n) =+    "ShiftLeft{tid="+      ++ show (termThreadId t)+      ++ ", id="+      ++ show (termId t)+      ++ ", arg="+      ++ show arg+      ++ ", n="+      ++ show n+      ++ "}"+  show t@(ShiftRightTerm arg n) =+    "ShiftRight{tid="+      ++ show (termThreadId t)+      ++ ", id="+      ++ show (termId t)+      ++ ", arg="+      ++ show arg+      ++ ", n="+      ++ show n+      ++ "}"+  show t@(RotateLeftTerm arg n) =+    "RotateLeft{tid="+      ++ show (termThreadId t)+      ++ ", id="+      ++ show (termId t)+      ++ ", arg="+      ++ show arg+      ++ ", n="+      ++ show n+      ++ "}"+  show t@(RotateRightTerm arg n) =+    "RotateRight{tid="+      ++ show (termThreadId t)+      ++ ", id="+      ++ show (termId t)+      ++ ", arg="+      ++ show arg+      ++ ", n="+      ++ show n+      ++ "}"+  show t@(BitCastTerm arg) =+    "BitCast{tid="+      ++ show (termThreadId t)+      ++ ", id="+      ++ show (termId t)+      ++ ", arg="+      ++ show arg+      ++ "}"+  show t@(BitCastOrTerm arg d) =+    "BitCastOr{tid="+      ++ show (termThreadId t)+      ++ ", id="+      ++ show (termId t)+      ++ ", default="+      ++ show d+      ++ ", arg="+      ++ show arg+      ++ "}"+  show t@(BVConcatTerm arg1 arg2) =+    "BVConcat{tid="+      ++ show (termThreadId t)+      ++ ", id="+      ++ show (termId t)+      ++ ", arg1="+      ++ show arg1+      ++ ", arg2="+      ++ show arg2+      ++ "}"+  show t@(BVSelectTerm ix w arg) =+    "BVSelect{tid="+      ++ show (termThreadId t)+      ++ ", id="+      ++ show (termId t)+      ++ ", ix="+      ++ show (natVal ix)+      ++ ", w="+      ++ show (natVal w)+      ++ ", arg="+      ++ show arg+      ++ "}"+  show t@(BVExtendTerm signed n arg) =+    "BVExtend{tid="+      ++ show (termThreadId t)+      ++ ", id="+      ++ show (termId t)+      ++ ", signed="+      ++ show signed+      ++ ", n="+      ++ show (natVal n)+      ++ ", arg="+      ++ show arg+      ++ "}"+  show t@(ApplyTerm func arg) =+    "Apply{tid="+      ++ show (termThreadId t)+      ++ ", id="+      ++ show (termId t)+      ++ ", f="+      ++ show func+      ++ ", arg="+      ++ show arg+      ++ "}"+  show t@(DivIntegralTerm arg1 arg2) =+    "DivIntegral{tid="+      ++ show (termThreadId t)+      ++ ", id="+      ++ show (termId t)+      ++ ", arg1="+      ++ show arg1+      ++ ", arg2="+      ++ show arg2+      ++ "}"+  show t@(ModIntegralTerm arg1 arg2) =+    "ModIntegral{tid="+      ++ show (termThreadId t)+      ++ ", id="+      ++ show (termId t)+      ++ ", arg1="+      ++ show arg1+      ++ ", arg2="+      ++ show arg2+      ++ "}"+  show t@(QuotIntegralTerm arg1 arg2) =+    "QuotIntegral{tid="+      ++ show (termThreadId t)+      ++ ", id="+      ++ show (termId t)+      ++ ", arg1="+      ++ show arg1+      ++ ", arg2="+      ++ show arg2+      ++ "}"+  show t@(RemIntegralTerm arg1 arg2) =+    "RemIntegral{tid="+      ++ show (termThreadId t)+      ++ ", id="+      ++ show (termId t)+      ++ ", arg1="+      ++ show arg1+      ++ ", arg2="+      ++ show arg2+      ++ "}"+  show t@(FPTraitTerm trait arg) =+    "FPTrait{tid="+      ++ show (termThreadId t)+      ++ ", id="+      ++ show (termId t)+      ++ ", trait="+      ++ show trait+      ++ ", arg="+      ++ show arg+      ++ "}"+  show t@(FdivTerm arg1 arg2) =+    "Fdiv{tid="+      ++ show (termThreadId t)+      ++ ", id="+      ++ show (termId t)+      ++ ", arg1="+      ++ show arg1+      ++ ", arg2="+      ++ show arg2+      ++ "}"+  show t@(RecipTerm arg) =+    "Recip{tid="+      ++ show (termThreadId t)+      ++ ", id="+      ++ show (termId t)+      ++ ", arg="+      ++ show arg+      ++ "}"+  show t@(FloatingUnaryTerm op arg) =+    "FloatingUnary{tid="+      ++ show (termThreadId t)+      ++ ", id="+      ++ show (termId t)+      ++ ", op="+      ++ show op+      ++ ", arg="+      ++ show arg+      ++ "}"+  show t@(PowerTerm arg1 arg2) =+    "Power{tid="+      ++ show (termThreadId t)+      ++ ", id="+      ++ show (termId t)+      ++ ", arg1="+      ++ show arg1+      ++ ", arg2="+      ++ show arg2+      ++ "}"+  show t@(FPUnaryTerm op arg) =+    "FPUnary{tid="+      ++ show (termThreadId t)+      ++ ", id="+      ++ show (termId t)+      ++ ", op="+      ++ show op+      ++ ", arg="+      ++ show arg+      ++ "}"+  show t@(FPBinaryTerm op arg1 arg2) =+    "FPBinary{tid="+      ++ show (termThreadId t)+      ++ ", id="+      ++ show (termId t)+      ++ ", op="+      ++ show op+      ++ ", arg1="+      ++ show arg1+      ++ ", arg2="+      ++ show arg2+      ++ "}"+  show t@(FPRoundingUnaryTerm op mode arg) =+    "FPRoundingUnary{tid="+      ++ show (termThreadId t)+      ++ ", id="+      ++ show (termId t)+      ++ ", op="+      ++ show op+      ++ ", mode="+      ++ show mode+      ++ ", arg="+      ++ show arg+      ++ "}"+  show t@(FPRoundingBinaryTerm op mode arg1 arg2) =+    "FPRoundingBinary{tid="+      ++ show (termThreadId t)+      ++ ", id="+      ++ show (termId t)+      ++ ", op="+      ++ show op+      ++ ", mode="+      ++ show mode+      ++ ", arg1="+      ++ show arg1+      ++ ", arg2="+      ++ show arg2+      ++ "}"+  show t@(FPFMATerm mode arg1 arg2 arg3) =+    "FPFMA{tid="+      ++ show (termThreadId t)+      ++ ", id="+      ++ show (termId t)+      ++ ", mode="+      ++ show mode+      ++ ", arg1="+      ++ show arg1+      ++ ", arg2="+      ++ show arg2+      ++ ", arg3="+      ++ show arg3+      ++ "}"+  show t@(FromIntegralTerm arg) =+    "FromIntegral{tid="+      ++ show (termThreadId t)+      ++ ", id="+      ++ show (termId t)+      ++ ", arg="+      ++ show arg+      ++ "}"+  show t@(FromFPOrTerm arg d mode) =+    "FromFPTerm{tid="+      ++ show (termThreadId t)+      ++ ", id="+      ++ show (termId t)+      ++ ", default="+      ++ show d+      ++ ", mode="+      ++ show mode+      ++ ", arg="+      ++ show arg+      ++ "}"+  show t@(ToFPTerm arg mode _ _) =+    "ToFPTerm{tid="+      ++ show (termThreadId t)+      ++ ", id="+      ++ show (termId t)+      ++ ", mode="+      ++ show mode+      ++ ", arg="+      ++ show arg+      ++ "}"++-- {-# INLINE show #-}++-- | Pretty-print a term, possibly eliding parts of it.+prettyPrintTerm :: Term t -> Doc ann+prettyPrintTerm v@SupportedTerm =+  column+    ( \c ->+        pageWidth $ \case+          AvailablePerLine i r ->+            if fromIntegral (c + len) > fromIntegral i * r+              then "..."+              else pretty formatted+          Unbounded -> pretty formatted+    )+  where+    formatted = pformatTerm v+    len = length formatted++instance (SupportedPrim t) => Eq (Term t) where+  a == b =+    if threadId a == threadId b+      then termId a == termId b+      else unsafePerformIO $ do+        tid <- myWeakThreadId+        a' <- toCurThreadImpl tid a+        b' <- toCurThreadImpl tid b+        return $ a' == b'++instance (SupportedPrim t) => Hashable (Term t) where+  hashWithSalt s t = hashWithSalt s $ termHashId t+  {-# INLINE hashWithSalt #-}++-- | Term without identity (before internalizing).+data UTerm t where+  UConTerm :: (SupportedPrim t) => !t -> UTerm t+  USymTerm :: !(TypedSymbol 'AnyKind t) -> UTerm t+  UForallTerm ::+    !(TypedSymbol 'ConstantKind t) ->+    !(Term Bool) ->+    UTerm Bool+  UExistsTerm ::+    !(TypedSymbol 'ConstantKind t) ->+    !(Term Bool) ->+    UTerm Bool+  UNotTerm :: !(Term Bool) -> UTerm Bool+  UOrTerm :: !(Term Bool) -> !(Term Bool) -> !(HS.HashSet (Term Bool)) -> UTerm Bool+  UAndTerm :: !(Term Bool) -> !(Term Bool) -> !(HS.HashSet (Term Bool)) -> UTerm Bool+  UEqTerm :: !(Term t) -> !(Term t) -> UTerm Bool+  UDistinctTerm :: !(NonEmpty (Term t)) -> UTerm Bool+  UITETerm ::+    (SupportedPrim t) =>+    !(Term Bool) ->+    !(Term t) ->+    !(Term t) ->+    UTerm t+  UAddNumTerm :: (SupportedPrim t, PEvalNumTerm t) => !(Term t) -> !(Term t) -> UTerm t+  UNegNumTerm :: (SupportedPrim t, PEvalNumTerm t) => !(Term t) -> UTerm t+  UMulNumTerm :: (SupportedPrim t, PEvalNumTerm t) => !(Term t) -> !(Term t) -> UTerm t+  UAbsNumTerm :: (SupportedPrim t, PEvalNumTerm t) => !(Term t) -> UTerm t+  USignumNumTerm :: (SupportedPrim t, PEvalNumTerm t) => !(Term t) -> UTerm t+  ULtOrdTerm :: (SupportedPrim t, PEvalOrdTerm t) => !(Term t) -> !(Term t) -> UTerm Bool+  ULeOrdTerm :: (SupportedPrim t, PEvalOrdTerm t) => !(Term t) -> !(Term t) -> UTerm Bool+  UAndBitsTerm :: (SupportedPrim t, PEvalBitwiseTerm t) => !(Term t) -> !(Term t) -> UTerm t+  UOrBitsTerm :: (SupportedPrim t, PEvalBitwiseTerm t) => !(Term t) -> !(Term t) -> UTerm t+  UXorBitsTerm :: (SupportedPrim t, PEvalBitwiseTerm t) => !(Term t) -> !(Term t) -> UTerm t+  UComplementBitsTerm :: (SupportedPrim t, PEvalBitwiseTerm t) => !(Term t) -> UTerm t+  UShiftLeftTerm ::+    (SupportedPrim t, PEvalShiftTerm t) => !(Term t) -> !(Term t) -> UTerm t+  UShiftRightTerm ::+    (SupportedPrim t, PEvalShiftTerm t) => !(Term t) -> !(Term t) -> UTerm t+  URotateLeftTerm ::+    (SupportedPrim t, PEvalRotateTerm t) => !(Term t) -> !(Term t) -> UTerm t+  URotateRightTerm ::+    (SupportedPrim t, PEvalRotateTerm t) => !(Term t) -> !(Term t) -> UTerm t+  UBitCastTerm ::+    (SupportedPrim b, PEvalBitCastTerm a b) =>+    !(Term a) ->+    UTerm b+  UBitCastOrTerm ::+    (SupportedPrim b, PEvalBitCastOrTerm a b) =>+    !(Term b) ->+    !(Term a) ->+    UTerm b+  UBVConcatTerm ::+    ( PEvalBVTerm bv,+      KnownNat l,+      KnownNat r,+      KnownNat (l + r),+      1 <= l,+      1 <= r,+      1 <= l + r,+      SupportedPrim (bv (l + r))+    ) =>+    !(Term (bv l)) ->+    !(Term (bv r)) ->+    UTerm (bv (l + r))+  UBVSelectTerm ::+    ( PEvalBVTerm bv,+      KnownNat n,+      KnownNat ix,+      KnownNat w,+      1 <= n,+      1 <= w,+      ix + w <= n,+      SupportedPrim (bv w)+    ) =>+    !(Proxy ix) ->+    !(Proxy w) ->+    !(Term (bv n)) ->+    UTerm (bv w)+  UBVExtendTerm ::+    ( PEvalBVTerm bv,+      KnownNat l,+      KnownNat r,+      1 <= l,+      1 <= r,+      l <= r,+      SupportedPrim (bv r)+    ) =>+    !Bool ->+    !(Proxy r) ->+    !(Term (bv l)) ->+    UTerm (bv r)+  UApplyTerm ::+    (PEvalApplyTerm f a b, SupportedPrim b) =>+    Term f ->+    Term a ->+    UTerm b+  UDivIntegralTerm ::+    (SupportedPrim t, PEvalDivModIntegralTerm t) =>+    !(Term t) ->+    !(Term t) ->+    UTerm t+  UModIntegralTerm ::+    (SupportedPrim t, PEvalDivModIntegralTerm t) =>+    !(Term t) ->+    !(Term t) ->+    UTerm t+  UQuotIntegralTerm ::+    (SupportedPrim t, PEvalDivModIntegralTerm t) =>+    !(Term t) ->+    !(Term t) ->+    UTerm t+  URemIntegralTerm ::+    (SupportedPrim t, PEvalDivModIntegralTerm t) =>+    !(Term t) ->+    !(Term t) ->+    UTerm t+  UFPTraitTerm ::+    (ValidFP eb sb, SupportedPrim (fp eb sb), PEvalFPTerm fp) =>+    !FPTrait ->+    !(Term (fp eb sb)) ->+    UTerm Bool+  UFdivTerm ::+    (SupportedPrim t, PEvalFractionalTerm t) =>+    !(Term t) ->+    !(Term t) ->+    UTerm t+  URecipTerm :: (SupportedPrim t, PEvalFractionalTerm t) => !(Term t) -> UTerm t+  UFloatingUnaryTerm ::+    (SupportedPrim t, PEvalFloatingTerm t) =>+    !FloatingUnaryOp ->+    !(Term t) ->+    UTerm t+  UPowerTerm ::+    (SupportedPrim t, PEvalFloatingTerm t) => !(Term t) -> !(Term t) -> UTerm t+  UFPUnaryTerm ::+    (ValidFP eb sb, SupportedPrim (fp eb sb), PEvalFPTerm fp) =>+    !FPUnaryOp ->+    !(Term (fp eb sb)) ->+    UTerm (fp eb sb)+  UFPBinaryTerm ::+    (ValidFP eb sb, SupportedPrim (fp eb sb), PEvalFPTerm fp) =>+    !FPBinaryOp ->+    !(Term (fp eb sb)) ->+    !(Term (fp eb sb)) ->+    UTerm (fp eb sb)+  UFPRoundingUnaryTerm ::+    (ValidFP eb sb, SupportedPrim (fp eb sb), PEvalFPTerm fp) =>+    !FPRoundingUnaryOp ->+    !(Term FPRoundingMode) ->+    !(Term (fp eb sb)) ->+    UTerm (fp eb sb)+  UFPRoundingBinaryTerm ::+    (ValidFP eb sb, SupportedPrim (fp eb sb), PEvalFPTerm fp) =>+    !FPRoundingBinaryOp ->+    !(Term FPRoundingMode) ->+    !(Term (fp eb sb)) ->+    !(Term (fp eb sb)) ->+    UTerm (fp eb sb)+  UFPFMATerm ::+    (ValidFP eb sb, SupportedPrim (fp eb sb), PEvalFPTerm fp) =>+    !(Term FPRoundingMode) ->+    !(Term (fp eb sb)) ->+    !(Term (fp eb sb)) ->+    !(Term (fp eb sb)) ->+    UTerm (fp eb sb)+  UFromIntegralTerm ::+    (PEvalFromIntegralTerm a b, SupportedPrim b) =>+    !(Term a) ->+    UTerm b+  UFromFPOrTerm ::+    ( PEvalIEEEFPConvertibleTerm a,+      SupportedPrim a,+      ValidFP eb sb+    ) =>+    Term a ->+    !(Term FPRoundingMode) ->+    !(Term (FP eb sb)) ->+    UTerm a+  UToFPTerm ::+    ( PEvalIEEEFPConvertibleTerm a,+      ValidFP eb sb,+      SupportedPrim (FP eb sb)+    ) =>+    !(Term FPRoundingMode) ->+    !(Term a) ->+    Proxy eb ->+    Proxy sb ->+    UTerm (FP eb sb)++-- | Compare two t'TypedSymbol's for equality.+eqHeteroSymbol :: forall ta a tb b. TypedSymbol ta a -> TypedSymbol tb b -> Bool+eqHeteroSymbol (TypedSymbol taga) (TypedSymbol tagb) =+  case eqTypeRep (primTypeRep @a) (primTypeRep @b) of+    Just HRefl -> taga == tagb+    Nothing -> False+{-# INLINE eqHeteroSymbol #-}++preHashConDescription :: (SupportedPrim t) => t -> Digest+preHashConDescription = fromIntegral . hashConWithSalt 0+{-# INLINE preHashConDescription #-}++preHashSymDescription :: TypedSymbol 'AnyKind t -> Digest+preHashSymDescription = fromIntegral . hashWithSalt 1+{-# INLINE preHashSymDescription #-}++preHashForallDescription ::+  TypedSymbol 'ConstantKind t -> HashId -> Digest+preHashForallDescription sym h =+  fromIntegral+    ( 2+        `hashWithSalt` sym+        `hashWithSalt` h+    )+{-# INLINE preHashForallDescription #-}++preHashExistsDescription ::+  TypedSymbol 'ConstantKind t -> HashId -> Digest+preHashExistsDescription sym h =+  fromIntegral+    ( 3+        `hashWithSalt` sym+        `hashWithSalt` h+    )+{-# INLINE preHashExistsDescription #-}++preHashNotDescription :: HashId -> Digest+preHashNotDescription = fromIntegral . hashWithSalt 7+{-# INLINE preHashNotDescription #-}++preHashOrDescription :: HashId -> HashId -> Digest+preHashOrDescription h1 h2 =+  fromIntegral (8 `hashWithSalt` h1 `hashWithSalt` h2)+{-# INLINE preHashOrDescription #-}++preHashAndDescription :: HashId -> HashId -> Digest+preHashAndDescription h1 h2 =+  fromIntegral (9 `hashWithSalt` h1 `hashWithSalt` h2)+{-# INLINE preHashAndDescription #-}++preHashEqDescription :: Fingerprint -> HashId -> HashId -> Digest+preHashEqDescription tp h1 h2 =+  fromIntegral (10 `hashWithSalt` tp `hashWithSalt` h1 `hashWithSalt` h2)+{-# INLINE preHashEqDescription #-}++preHashDistinctDescription :: Fingerprint -> NonEmpty HashId -> Digest+preHashDistinctDescription tp hs =+  fromIntegral (11 `hashWithSalt` tp `hashWithSalt` hs)+{-# INLINE preHashDistinctDescription #-}++preHashITEDescription :: HashId -> HashId -> HashId -> Digest+preHashITEDescription h1 h2 h3 =+  fromIntegral (12 `hashWithSalt` h1 `hashWithSalt` h2 `hashWithSalt` h3)+{-# INLINE preHashITEDescription #-}++preHashAddNumDescription :: HashId -> HashId -> Digest+preHashAddNumDescription h1 h2 =+  fromIntegral (13 `hashWithSalt` h1 `hashWithSalt` h2)+{-# INLINE preHashAddNumDescription #-}++preHashNegNumDescription :: HashId -> Digest+preHashNegNumDescription =+  fromIntegral . hashWithSalt 14+{-# INLINE preHashNegNumDescription #-}++preHashMulNumDescription :: HashId -> HashId -> Digest+preHashMulNumDescription h1 h2 =+  fromIntegral (15 `hashWithSalt` h1 `hashWithSalt` h2)+{-# INLINE preHashMulNumDescription #-}++preHashAbsNumDescription :: HashId -> Digest+preHashAbsNumDescription = fromIntegral . hashWithSalt 16+{-# INLINE preHashAbsNumDescription #-}++preHashSignumNumDescription :: HashId -> Digest+preHashSignumNumDescription = fromIntegral . hashWithSalt 17+{-# INLINE preHashSignumNumDescription #-}++preHashLtOrdDescription :: Fingerprint -> HashId -> HashId -> Digest+preHashLtOrdDescription tp h1 h2 =+  fromIntegral (18 `hashWithSalt` tp `hashWithSalt` h1 `hashWithSalt` h2)+{-# INLINE preHashLtOrdDescription #-}++preHashLeOrdDescription :: Fingerprint -> HashId -> HashId -> Digest+preHashLeOrdDescription tp h1 h2 =+  fromIntegral (19 `hashWithSalt` tp `hashWithSalt` h1 `hashWithSalt` h2)+{-# INLINE preHashLeOrdDescription #-}++preHashAndBitsDescription :: HashId -> HashId -> Digest+preHashAndBitsDescription h1 h2 =+  fromIntegral (20 `hashWithSalt` h1 `hashWithSalt` h2)+{-# INLINE preHashAndBitsDescription #-}++preHashOrBitsDescription :: HashId -> HashId -> Digest+preHashOrBitsDescription h1 h2 =+  fromIntegral (21 `hashWithSalt` h1 `hashWithSalt` h2)+{-# INLINE preHashOrBitsDescription #-}++preHashXorBitsDescription :: HashId -> HashId -> Digest+preHashXorBitsDescription h1 h2 =+  fromIntegral (22 `hashWithSalt` h1 `hashWithSalt` h2)+{-# INLINE preHashXorBitsDescription #-}++preHashComplementBitsDescription :: HashId -> Digest+preHashComplementBitsDescription = fromIntegral . hashWithSalt 23+{-# INLINE preHashComplementBitsDescription #-}++preHashShiftLeftDescription :: HashId -> HashId -> Digest+preHashShiftLeftDescription h1 h2 =+  fromIntegral (24 `hashWithSalt` h1 `hashWithSalt` h2)+{-# INLINE preHashShiftLeftDescription #-}++preHashShiftRightDescription :: HashId -> HashId -> Digest+preHashShiftRightDescription h1 h2 =+  fromIntegral (25 `hashWithSalt` h1 `hashWithSalt` h2)+{-# INLINE preHashShiftRightDescription #-}++preHashRotateLeftDescription :: HashId -> HashId -> Digest+preHashRotateLeftDescription h1 h2 =+  fromIntegral (26 `hashWithSalt` h1 `hashWithSalt` h2)+{-# INLINE preHashRotateLeftDescription #-}++preHashRotateRightDescription :: HashId -> HashId -> Digest+preHashRotateRightDescription h1 h2 =+  fromIntegral (27 `hashWithSalt` h1 `hashWithSalt` h2)+{-# INLINE preHashRotateRightDescription #-}++preHashBVConcatDescription :: TypeHashId -> TypeHashId -> Digest+preHashBVConcatDescription h1 h2 =+  fromIntegral+    ( 28+        `hashWithSalt` h1+        `hashWithSalt` h2+    )++preHashBVSelectDescription :: Fingerprint -> TypeHashId -> Digest+preHashBVSelectDescription tp h =+  fromIntegral (29 `hashWithSalt` tp `hashWithSalt` h)++preHashBVExtendDescription :: Bool -> TypeHashId -> Digest+preHashBVExtendDescription signed h =+  fromIntegral (30 `hashWithSalt` signed `hashWithSalt` h)++preHashBitCastDescription :: TypeHashId -> Digest+preHashBitCastDescription = fromIntegral . hashWithSalt 31+{-# INLINE preHashBitCastDescription #-}++preHashBitCastOrDescription :: HashId -> TypeHashId -> Digest+preHashBitCastOrDescription h1 h2 =+  fromIntegral (32 `hashWithSalt` h1 `hashWithSalt` h2)+{-# INLINE preHashBitCastOrDescription #-}++preHashApplyDescription :: TypeHashId -> TypeHashId -> Digest+preHashApplyDescription h1 h2 =+  fromIntegral (33 `hashWithSalt` h1 `hashWithSalt` h2)+{-# INLINE preHashApplyDescription #-}++preHashDivIntegralDescription :: HashId -> HashId -> Digest+preHashDivIntegralDescription h1 h2 =+  fromIntegral (34 `hashWithSalt` h1 `hashWithSalt` h2)+{-# INLINE preHashDivIntegralDescription #-}++preHashModIntegralDescription :: HashId -> HashId -> Digest+preHashModIntegralDescription h1 h2 =+  fromIntegral (35 `hashWithSalt` h1 `hashWithSalt` h2)+{-# INLINE preHashModIntegralDescription #-}++preHashQuotIntegralDescription :: HashId -> HashId -> Digest+preHashQuotIntegralDescription h1 h2 =+  fromIntegral (36 `hashWithSalt` h1 `hashWithSalt` h2)+{-# INLINE preHashQuotIntegralDescription #-}++preHashRemIntegralDescription :: HashId -> HashId -> Digest+preHashRemIntegralDescription h1 h2 =+  fromIntegral (37 `hashWithSalt` h1 `hashWithSalt` h2)+{-# INLINE preHashRemIntegralDescription #-}++preHashFPTraitDescription :: FPTrait -> TypeHashId -> Digest+preHashFPTraitDescription trait h =+  fromIntegral (38 `hashWithSalt` trait `hashWithSalt` h)+{-# INLINE preHashFPTraitDescription #-}++preHashFdivDescription :: HashId -> HashId -> Digest+preHashFdivDescription h1 h2 =+  fromIntegral (39 `hashWithSalt` h1 `hashWithSalt` h2)+{-# INLINE preHashFdivDescription #-}++preHashRecipDescription :: HashId -> Digest+preHashRecipDescription = fromIntegral . hashWithSalt 40+{-# INLINE preHashRecipDescription #-}++preHashFloatingUnaryDescription :: FloatingUnaryOp -> HashId -> Digest+preHashFloatingUnaryDescription op h =+  fromIntegral (41 `hashWithSalt` op `hashWithSalt` h)+{-# INLINE preHashFloatingUnaryDescription #-}++preHashPowerDescription :: HashId -> HashId -> Digest+preHashPowerDescription h1 h2 =+  fromIntegral (42 `hashWithSalt` h1 `hashWithSalt` h2)+{-# INLINE preHashPowerDescription #-}++preHashFPUnaryDescription :: FPUnaryOp -> HashId -> Digest+preHashFPUnaryDescription op h =+  fromIntegral (43 `hashWithSalt` op `hashWithSalt` h)+{-# INLINE preHashFPUnaryDescription #-}++preHashFPBinaryDescription :: FPBinaryOp -> HashId -> HashId -> Digest+preHashFPBinaryDescription op h1 h2 =+  fromIntegral (44 `hashWithSalt` op `hashWithSalt` h1 `hashWithSalt` h2)+{-# INLINE preHashFPBinaryDescription #-}++preHashFPRoundingUnaryDescription ::+  FPRoundingUnaryOp -> HashId -> HashId -> Digest+preHashFPRoundingUnaryDescription op mode h =+  fromIntegral (45 `hashWithSalt` op `hashWithSalt` mode `hashWithSalt` h)+{-# INLINE preHashFPRoundingUnaryDescription #-}++preHashFPRoundingBinaryDescription ::+  FPRoundingBinaryOp -> HashId -> HashId -> HashId -> Digest+preHashFPRoundingBinaryDescription op mode h1 h2 =+  fromIntegral+    ( 46+        `hashWithSalt` op+        `hashWithSalt` mode+        `hashWithSalt` h1+        `hashWithSalt` h2+    )++preHashFPFMADescription ::+  HashId -> HashId -> HashId -> HashId -> Digest+preHashFPFMADescription mode h1 h2 h3 =+  fromIntegral+    ( 47+        `hashWithSalt` mode+        `hashWithSalt` h1+        `hashWithSalt` h2+        `hashWithSalt` h3+    )+{-# INLINE preHashFPFMADescription #-}++preHashFromIntegralDescription :: TypeHashId -> Digest+preHashFromIntegralDescription = fromIntegral . hashWithSalt 48+{-# INLINE preHashFromIntegralDescription #-}++preHashFromFPOrDescription ::+  HashId -> HashId -> TypeHashId -> Digest+preHashFromFPOrDescription h1 h2 h3 =+  fromIntegral (49 `hashWithSalt` h1 `hashWithSalt` h2 `hashWithSalt` h3)+{-# INLINE preHashFromFPOrDescription #-}++preHashToFPTermDescription :: HashId -> TypeHashId -> Digest+preHashToFPTermDescription h1 h2 =+  fromIntegral (50 `hashWithSalt` h1 `hashWithSalt` h2)+{-# INLINE preHashToFPTermDescription #-}++instance Interned (Term t) where+  type Uninterned (Term t) = UTerm t+  data Description (Term t) where+    DConTerm ::+      (t -> t -> Bool) -> {-# UNPACK #-} !Digest -> t -> Description (Term t)+    DSymTerm ::+      {-# UNPACK #-} !Digest ->+      TypedSymbol 'AnyKind t ->+      Description (Term t)+    DForallTerm ::+      {-# UNPACK #-} !Digest ->+      {-# UNPACK #-} !(TypedSymbol 'ConstantKind t) ->+      {-# UNPACK #-} !HashId ->+      Description (Term Bool)+    DExistsTerm ::+      {-# UNPACK #-} !Digest ->+      {-# UNPACK #-} !(TypedSymbol 'ConstantKind t) ->+      {-# UNPACK #-} !HashId ->+      Description (Term Bool)+    DNotTerm ::+      {-# UNPACK #-} !Digest ->+      {-# UNPACK #-} !HashId ->+      Description (Term Bool)+    DOrTerm ::+      {-# UNPACK #-} !Digest ->+      {-# UNPACK #-} !HashId ->+      {-# UNPACK #-} !HashId ->+      !(HS.HashSet (Term Bool)) ->+      Description (Term Bool)+    DAndTerm ::+      {-# UNPACK #-} !Digest ->+      {-# UNPACK #-} !HashId ->+      {-# UNPACK #-} !HashId ->+      !(HS.HashSet (Term Bool)) ->+      Description (Term Bool)+    DEqTerm ::+      {-# UNPACK #-} !Digest ->+      Fingerprint ->+      {-# UNPACK #-} !HashId ->+      {-# UNPACK #-} !HashId ->+      Description (Term Bool)+    DDistinctTerm ::+      {-# UNPACK #-} !Digest ->+      Fingerprint ->+      !(NonEmpty HashId) ->+      Description (Term Bool)+    DITETerm ::+      {-# UNPACK #-} !Digest ->+      {-# UNPACK #-} !HashId ->+      {-# UNPACK #-} !HashId ->+      {-# UNPACK #-} !HashId ->+      Description (Term t)+    DAddNumTerm ::+      {-# UNPACK #-} !Digest ->+      {-# UNPACK #-} !HashId ->+      {-# UNPACK #-} !HashId ->+      Description (Term t)+    DNegNumTerm ::+      {-# UNPACK #-} !Digest ->+      {-# UNPACK #-} !HashId ->+      Description (Term t)+    DMulNumTerm ::+      {-# UNPACK #-} !Digest ->+      {-# UNPACK #-} !HashId ->+      {-# UNPACK #-} !HashId ->+      Description (Term t)+    DAbsNumTerm ::+      {-# UNPACK #-} !Digest ->+      {-# UNPACK #-} !HashId ->+      Description (Term t)+    DSignumNumTerm ::+      {-# UNPACK #-} !Digest -> {-# UNPACK #-} !HashId -> Description (Term t)+    DLtOrdTerm ::+      {-# UNPACK #-} !Digest ->+      {-# UNPACK #-} !Fingerprint ->+      {-# UNPACK #-} !HashId ->+      {-# UNPACK #-} !HashId ->+      Description (Term Bool)+    DLeOrdTerm ::+      {-# UNPACK #-} !Digest ->+      {-# UNPACK #-} !Fingerprint ->+      {-# UNPACK #-} !HashId ->+      {-# UNPACK #-} !HashId ->+      Description (Term Bool)+    DAndBitsTerm ::+      {-# UNPACK #-} !Digest ->+      {-# UNPACK #-} !HashId ->+      {-# UNPACK #-} !HashId ->+      Description (Term t)+    DOrBitsTerm ::+      {-# UNPACK #-} !Digest ->+      {-# UNPACK #-} !HashId ->+      {-# UNPACK #-} !HashId ->+      Description (Term t)+    DXorBitsTerm ::+      {-# UNPACK #-} !Digest ->+      {-# UNPACK #-} !HashId ->+      {-# UNPACK #-} !HashId ->+      Description (Term t)+    DComplementBitsTerm ::+      {-# UNPACK #-} !Digest ->+      {-# UNPACK #-} !HashId ->+      Description (Term t)+    DShiftLeftTerm ::+      {-# UNPACK #-} !Digest ->+      {-# UNPACK #-} !HashId ->+      {-# UNPACK #-} !HashId ->+      Description (Term t)+    DShiftRightTerm ::+      {-# UNPACK #-} !Digest ->+      {-# UNPACK #-} !HashId ->+      {-# UNPACK #-} !HashId ->+      Description (Term t)+    DRotateLeftTerm ::+      {-# UNPACK #-} !Digest ->+      {-# UNPACK #-} !HashId ->+      {-# UNPACK #-} !HashId ->+      Description (Term t)+    DRotateRightTerm ::+      {-# UNPACK #-} !Digest ->+      {-# UNPACK #-} !HashId ->+      {-# UNPACK #-} !HashId ->+      Description (Term t)+    DBVConcatTerm ::+      {-# UNPACK #-} !Digest ->+      {-# UNPACK #-} !TypeHashId ->+      {-# UNPACK #-} !TypeHashId ->+      Description (Term t)+    DBitCastTerm ::+      {-# UNPACK #-} !Digest ->+      {-# UNPACK #-} !TypeHashId ->+      Description (Term b)+    DBitCastOrTerm ::+      {-# UNPACK #-} !Digest ->+      {-# UNPACK #-} !HashId ->+      {-# UNPACK #-} !TypeHashId ->+      Description (Term b)+    DBVSelectTerm ::+      forall bv (w :: Nat).+      {-# UNPACK #-} !Digest ->+      !Fingerprint ->+      {-# UNPACK #-} !TypeHashId ->+      Description (Term (bv w))+    DBVExtendTerm ::+      forall bv (r :: Nat).+      {-# UNPACK #-} !Digest ->+      !Bool ->+      !(Proxy r) ->+      {-# UNPACK #-} !TypeHashId ->+      Description (Term (bv r))+    DApplyTerm ::+      {-# UNPACK #-} !Digest ->+      {-# UNPACK #-} !TypeHashId ->+      {-# UNPACK #-} !TypeHashId ->+      Description (Term b)+    DDivIntegralTerm ::+      {-# UNPACK #-} !Digest ->+      {-# UNPACK #-} !HashId ->+      {-# UNPACK #-} !HashId ->+      Description (Term a)+    DModIntegralTerm ::+      {-# UNPACK #-} !Digest ->+      {-# UNPACK #-} !HashId ->+      {-# UNPACK #-} !HashId ->+      Description (Term a)+    DQuotIntegralTerm ::+      {-# UNPACK #-} !Digest ->+      {-# UNPACK #-} !HashId ->+      {-# UNPACK #-} !HashId ->+      Description (Term a)+    DRemIntegralTerm ::+      {-# UNPACK #-} !Digest ->+      {-# UNPACK #-} !HashId ->+      {-# UNPACK #-} !HashId ->+      Description (Term a)+    DFPTraitTerm ::+      {-# UNPACK #-} !Digest ->+      FPTrait ->+      {-# UNPACK #-} !TypeHashId ->+      Description (Term Bool)+    DFdivTerm ::+      {-# UNPACK #-} !Digest ->+      {-# UNPACK #-} !HashId ->+      {-# UNPACK #-} !HashId ->+      Description (Term a)+    DRecipTerm ::+      {-# UNPACK #-} !Digest -> {-# UNPACK #-} !HashId -> Description (Term a)+    DFloatingUnaryTerm ::+      {-# UNPACK #-} !Digest ->+      FloatingUnaryOp ->+      {-# UNPACK #-} !HashId ->+      Description (Term a)+    DPowerTerm ::+      {-# UNPACK #-} !Digest ->+      {-# UNPACK #-} !HashId ->+      {-# UNPACK #-} !HashId ->+      Description (Term a)+    DFPUnaryTerm ::+      forall fp (eb :: Nat) (sb :: Nat).+      {-# UNPACK #-} !Digest ->+      FPUnaryOp ->+      {-# UNPACK #-} !HashId ->+      Description (Term (fp eb sb))+    DFPBinaryTerm ::+      forall fp (eb :: Nat) (sb :: Nat).+      {-# UNPACK #-} !Digest ->+      FPBinaryOp ->+      {-# UNPACK #-} !HashId ->+      {-# UNPACK #-} !HashId ->+      Description (Term (fp eb sb))+    DFPRoundingUnaryTerm ::+      forall fp (eb :: Nat) (sb :: Nat).+      {-# UNPACK #-} !Digest ->+      FPRoundingUnaryOp ->+      {-# UNPACK #-} !HashId ->+      {-# UNPACK #-} !HashId ->+      Description (Term (fp eb sb))+    DFPRoundingBinaryTerm ::+      forall fp (eb :: Nat) (sb :: Nat).+      {-# UNPACK #-} !Digest ->+      FPRoundingBinaryOp ->+      {-# UNPACK #-} !HashId ->+      {-# UNPACK #-} !HashId ->+      {-# UNPACK #-} !HashId ->+      Description (Term (fp eb sb))+    DFPFMATerm ::+      forall fp (eb :: Nat) (sb :: Nat).+      {-# UNPACK #-} !Digest ->+      {-# UNPACK #-} !HashId ->+      {-# UNPACK #-} !HashId ->+      {-# UNPACK #-} !HashId ->+      {-# UNPACK #-} !HashId ->+      Description (Term (fp eb sb))+    DFromIntegralTerm ::+      {-# UNPACK #-} !Digest ->+      {-# UNPACK #-} !TypeHashId ->+      Description (Term b)+    DFromFPOrTerm ::+      {-# UNPACK #-} !Digest ->+      {-# UNPACK #-} !HashId ->+      {-# UNPACK #-} !HashId ->+      {-# UNPACK #-} !TypeHashId ->+      Description (Term a)+    DToFPTerm ::+      {-# UNPACK #-} !Digest ->+      {-# UNPACK #-} !HashId ->+      {-# UNPACK #-} !TypeHashId ->+      Description (Term (FP eb sb))++  describe (UConTerm v) = DConTerm sameCon (preHashConDescription v) v+  describe ((USymTerm name) :: UTerm t) =+    DSymTerm @t (preHashSymDescription name) name+  describe (UForallTerm (sym :: TypedSymbol 'ConstantKind arg) arg) =+    let argHashId = termHashId arg+     in DForallTerm (preHashForallDescription sym argHashId) sym argHashId+  describe (UExistsTerm (sym :: TypedSymbol 'ConstantKind arg) arg) =+    let argHashId = termHashId arg+     in DExistsTerm (preHashExistsDescription sym argHashId) sym argHashId+  describe (UNotTerm arg) =+    let argHashId = termHashId arg+     in DNotTerm (preHashNotDescription argHashId) argHashId+  describe (UOrTerm arg1 arg2 s) =+    let arg1HashId = termHashId arg1+        arg2HashId = termHashId arg2+     in DOrTerm+          (preHashOrDescription arg1HashId arg2HashId)+          arg1HashId+          arg2HashId+          s+  describe (UAndTerm arg1 arg2 s) =+    let arg1HashId = termHashId arg1+        arg2HashId = termHashId arg2+     in DAndTerm+          (preHashAndDescription arg1HashId arg2HashId)+          arg1HashId+          arg2HashId+          s+  describe (UEqTerm (arg1@SupportedTerm :: Term arg) arg2) = do+    let fingerprint = typeFingerprint @arg+        arg1HashId = termHashId arg1+        arg2HashId = termHashId arg2+     in DEqTerm+          (preHashEqDescription fingerprint arg1HashId arg2HashId)+          fingerprint+          arg1HashId+          arg2HashId+  describe (UDistinctTerm args@((SupportedTerm :: Term arg) :| _)) =+    let fingerprint = typeFingerprint @arg+        argsHashId = termHashId <$> args+     in DDistinctTerm+          (preHashDistinctDescription fingerprint argsHashId)+          fingerprint+          argsHashId+  describe (UITETerm cond (l :: Term arg) r) =+    let condHashId = termHashId cond+        lHashId = termHashId l+        rHashId = termHashId r+     in DITETerm+          (preHashITEDescription condHashId lHashId rHashId)+          condHashId+          lHashId+          rHashId+  describe (UAddNumTerm arg1 arg2) =+    let arg1HashId = termHashId arg1+        arg2HashId = termHashId arg2+     in DAddNumTerm+          (preHashAddNumDescription arg1HashId arg2HashId)+          arg1HashId+          arg2HashId+  describe (UNegNumTerm arg) =+    let argHashId = termHashId arg+     in DNegNumTerm (preHashNegNumDescription argHashId) argHashId+  describe (UMulNumTerm arg1 arg2) =+    let arg1HashId = termHashId arg1+        arg2HashId = termHashId arg2+     in DMulNumTerm+          (preHashMulNumDescription arg1HashId arg2HashId)+          arg1HashId+          arg2HashId+  describe (UAbsNumTerm arg) =+    let argHashId = termHashId arg+     in DAbsNumTerm (preHashAbsNumDescription argHashId) argHashId+  describe (USignumNumTerm arg) =+    let argHashId = termHashId arg+     in DSignumNumTerm (preHashSignumNumDescription argHashId) argHashId+  describe (ULtOrdTerm (arg1 :: Term arg) arg2) =+    let tr = typeFingerprint @arg+        arg1HashId = termHashId arg1+        arg2HashId = termHashId arg2+     in DLtOrdTerm+          (preHashLtOrdDescription tr arg1HashId arg2HashId)+          tr+          arg1HashId+          arg2HashId+  describe (ULeOrdTerm (arg1 :: Term arg) arg2) =+    let tr = typeFingerprint @arg+        arg1HashId = termHashId arg1+        arg2HashId = termHashId arg2+     in DLeOrdTerm+          (preHashLeOrdDescription tr arg1HashId arg2HashId)+          tr+          arg1HashId+          arg2HashId+  describe (UAndBitsTerm arg1 arg2) =+    let arg1HashId = termHashId arg1+        arg2HashId = termHashId arg2+     in DAndBitsTerm+          (preHashAndBitsDescription arg1HashId arg2HashId)+          arg1HashId+          arg2HashId+  describe (UOrBitsTerm arg1 arg2) =+    let arg1HashId = termHashId arg1+        arg2HashId = termHashId arg2+     in DOrBitsTerm+          (preHashOrBitsDescription arg1HashId arg2HashId)+          arg1HashId+          arg2HashId+  describe (UXorBitsTerm arg1 arg2) =+    let arg1HashId = termHashId arg1+        arg2HashId = termHashId arg2+     in DXorBitsTerm+          (preHashXorBitsDescription arg1HashId arg2HashId)+          arg1HashId+          arg2HashId+  describe (UComplementBitsTerm arg) =+    let argHashId = termHashId arg+     in DComplementBitsTerm+          (preHashComplementBitsDescription argHashId)+          argHashId+  describe (UShiftLeftTerm arg n) =+    let argHashId = termHashId arg+        nHashId = termHashId n+     in DShiftLeftTerm+          (preHashShiftLeftDescription argHashId nHashId)+          argHashId+          nHashId+  describe (UShiftRightTerm arg n) =+    let argHashId = termHashId arg+        nHashId = termHashId n+     in DShiftRightTerm+          (preHashShiftRightDescription argHashId nHashId)+          argHashId+          nHashId+  describe (URotateLeftTerm arg n) =+    let argHashId = termHashId arg+        nHashId = termHashId n+     in DRotateLeftTerm+          (preHashRotateLeftDescription argHashId nHashId)+          argHashId+          nHashId+  describe (URotateRightTerm arg n) =+    let argHashId = termHashId arg+        nHashId = termHashId n+     in DRotateRightTerm+          (preHashRotateRightDescription argHashId nHashId)+          argHashId+          nHashId+  describe (UBitCastTerm (arg :: Term a)) =+    let argHashId = termTypeHashId arg+     in DBitCastTerm (preHashBitCastDescription argHashId) argHashId+  describe (UBitCastOrTerm d (arg :: Term a)) =+    let dHashId = termHashId d+        argHashId = termTypeHashId arg+     in DBitCastOrTerm+          (preHashBitCastOrDescription dHashId argHashId)+          dHashId+          argHashId+  describe (UBVConcatTerm (arg1 :: Term bv1) (arg2 :: Term bv2)) =+    let arg1HashId = termTypeHashId arg1+        arg2HashId = termTypeHashId arg2+     in DBVConcatTerm+          (preHashBVConcatDescription arg1HashId arg2HashId)+          arg1HashId+          arg2HashId+  describe (UBVSelectTerm (ix :: Proxy ix) _ (arg :: Term arg)) =+    let ixFingerprint = typeRepFingerprint $ someTypeRep ix+        argHashId = termTypeHashId arg+     in DBVSelectTerm+          (preHashBVSelectDescription ixFingerprint argHashId)+          ixFingerprint+          argHashId+  describe (UBVExtendTerm signed (n :: Proxy n) (arg :: Term arg)) =+    let argHashId = termTypeHashId arg+     in DBVExtendTerm+          (preHashBVExtendDescription signed argHashId)+          signed+          n+          argHashId+  describe (UApplyTerm (f :: Term f) (arg :: Term a)) =+    let fHashId = termTypeHashId f+        argHashId = termTypeHashId arg+     in DApplyTerm+          (preHashApplyDescription fHashId argHashId)+          fHashId+          argHashId+  describe (UDivIntegralTerm arg1 arg2) =+    let arg1HashId = termHashId arg1+        arg2HashId = termHashId arg2+     in DDivIntegralTerm+          (preHashDivIntegralDescription arg1HashId arg2HashId)+          arg1HashId+          arg2HashId+  describe (UModIntegralTerm arg1 arg2) =+    let arg1HashId = termHashId arg1+        arg2HashId = termHashId arg2+     in DModIntegralTerm+          (preHashModIntegralDescription arg1HashId arg2HashId)+          arg1HashId+          arg2HashId+  describe (UQuotIntegralTerm arg1 arg2) =+    let arg1HashId = termHashId arg1+        arg2HashId = termHashId arg2+     in DQuotIntegralTerm+          (preHashQuotIntegralDescription arg1HashId arg2HashId)+          arg1HashId+          arg2HashId+  describe (URemIntegralTerm arg1 arg2) =+    let arg1HashId = termHashId arg1+        arg2HashId = termHashId arg2+     in DRemIntegralTerm+          (preHashRemIntegralDescription arg1HashId arg2HashId)+          arg1HashId+          arg2HashId+  describe (UFPTraitTerm trait (arg :: Term arg)) =+    let argHashId = termTypeHashId arg+     in DFPTraitTerm+          (preHashFPTraitDescription trait argHashId)+          trait+          argHashId+  describe (UFdivTerm arg1 arg2) =+    let arg1HashId = termHashId arg1+        arg2HashId = termHashId arg2+     in DFdivTerm+          (preHashFdivDescription arg1HashId arg2HashId)+          arg1HashId+          arg2HashId+  describe (URecipTerm arg) =+    let argHashId = termHashId arg+     in DRecipTerm (preHashRecipDescription argHashId) argHashId+  describe (UFloatingUnaryTerm op arg) =+    let argHashId = termHashId arg+     in DFloatingUnaryTerm+          (preHashFloatingUnaryDescription op argHashId)+          op+          argHashId+  describe (UPowerTerm arg1 arg2) =+    let arg1HashId = termHashId arg1+        arg2HashId = termHashId arg2+     in DPowerTerm+          (preHashPowerDescription arg1HashId arg2HashId)+          arg1HashId+          arg2HashId+  describe (UFPUnaryTerm op arg) =+    let argHashId = termHashId arg+     in DFPUnaryTerm+          (preHashFPUnaryDescription op argHashId)+          op+          argHashId+  describe (UFPBinaryTerm op arg1 arg2) =+    let arg1HashId = termHashId arg1+        arg2HashId = termHashId arg2+     in DFPBinaryTerm+          (preHashFPBinaryDescription op arg1HashId arg2HashId)+          op+          arg1HashId+          arg2HashId+  describe (UFPRoundingUnaryTerm op mode arg) =+    let modeHashId = termHashId mode+        argHashId = termHashId arg+     in DFPRoundingUnaryTerm+          (preHashFPRoundingUnaryDescription op modeHashId argHashId)+          op+          modeHashId+          argHashId+  describe (UFPRoundingBinaryTerm op mode arg1 arg2) =+    let modeHashId = termHashId mode+        arg1HashId = termHashId arg1+        arg2HashId = termHashId arg2+     in DFPRoundingBinaryTerm+          ( preHashFPRoundingBinaryDescription+              op+              modeHashId+              arg1HashId+              arg2HashId+          )+          op+          modeHashId+          arg1HashId+          arg2HashId+  describe (UFPFMATerm mode arg1 arg2 arg3) =+    let modeHashId = termHashId mode+        arg1HashId = termHashId arg1+        arg2HashId = termHashId arg2+        arg3HashId = termHashId arg3+     in DFPFMATerm+          (preHashFPFMADescription modeHashId arg1HashId arg2HashId arg3HashId)+          modeHashId+          arg1HashId+          arg2HashId+          arg3HashId+  describe (UFromIntegralTerm (arg :: Term a)) =+    let argHashId = termTypeHashId arg+     in DFromIntegralTerm (preHashFromIntegralDescription argHashId) argHashId+  describe (UFromFPOrTerm d mode (arg :: Term a)) =+    let dHashId = termHashId d+        modeHashId = termHashId mode+        argHashId = termTypeHashId arg+     in DFromFPOrTerm+          (preHashFromFPOrDescription dHashId modeHashId argHashId)+          dHashId+          modeHashId+          argHashId+  describe (UToFPTerm mode (arg :: Term a) _ _) =+    let modeHashId = termHashId mode+        argHashId = termTypeHashId arg+     in DToFPTerm+          (preHashToFPTermDescription modeHashId argHashId)+          modeHashId+          argHashId++  -- {-# INLINE describe #-}++  identify info = go+    where+      go (UConTerm v) = goPhantomCon info getPhantomDict v+      go (USymTerm v) = SymTerm' info v+      go (UForallTerm sym arg) = ForallTerm' info sym arg+      go (UExistsTerm sym arg) = ExistsTerm' info sym arg+      go (UNotTerm arg) = NotTerm' info arg+      go (UOrTerm arg1 arg2 s) = OrTerm' info arg1 arg2 s+      go (UAndTerm arg1 arg2 s) = AndTerm' info arg1 arg2 s+      go (UEqTerm arg1 arg2) = EqTerm' info arg1 arg2+      go (UDistinctTerm args) = DistinctTerm' info args+      -- ITE is propagated+      go (UITETerm cond l r) = ITETerm' info cond l r+      go (UAddNumTerm arg1 arg2) = AddNumTerm' info arg1 arg2+      go (UNegNumTerm arg) = NegNumTerm' info arg+      go (UMulNumTerm arg1 arg2) = MulNumTerm' info arg1 arg2+      go (UAbsNumTerm arg) = AbsNumTerm' info arg+      go (USignumNumTerm arg) = SignumNumTerm' info arg+      go (ULtOrdTerm arg1 arg2) = LtOrdTerm' info arg1 arg2+      go (ULeOrdTerm arg1 arg2) = LeOrdTerm' info arg1 arg2+      go (UAndBitsTerm arg1 arg2) = AndBitsTerm' info arg1 arg2+      go (UOrBitsTerm arg1 arg2) = OrBitsTerm' info arg1 arg2+      go (UXorBitsTerm arg1 arg2) = XorBitsTerm' info arg1 arg2+      go (UComplementBitsTerm arg) = ComplementBitsTerm' info arg+      go (UShiftLeftTerm arg n) = ShiftLeftTerm' info arg n+      go (UShiftRightTerm arg n) = ShiftRightTerm' info arg n+      go (URotateLeftTerm arg n) = RotateLeftTerm' info arg n+      go (URotateRightTerm arg n) = RotateRightTerm' info arg n+      go (UBitCastTerm arg) = goPhantomBitCast info getPhantomDict arg+      go (UBitCastOrTerm d arg) = BitCastOrTerm' info d arg+      go (UBVConcatTerm arg1 arg2) =+        goPhantomBVConcat info getPhantomDict arg1 arg2+      go (UBVSelectTerm ix w arg) =+        goPhantomBVSelect info getPhantomDict ix w arg+      go (UBVExtendTerm signed n arg) =+        goPhantomBVExtend info getPhantomDict signed n arg+      go (UApplyTerm f arg) = goPhantomApply info getPhantomDict f arg+      go (UDivIntegralTerm arg1 arg2) = DivIntegralTerm' info arg1 arg2+      go (UModIntegralTerm arg1 arg2) = ModIntegralTerm' info arg1 arg2+      go (UQuotIntegralTerm arg1 arg2) = QuotIntegralTerm' info arg1 arg2+      go (URemIntegralTerm arg1 arg2) = RemIntegralTerm' info arg1 arg2+      go (UFPTraitTerm trait arg) =+        goPhantomFPTrait info getPhantomDict trait arg+      go (UFdivTerm arg1 arg2) = FdivTerm' info arg1 arg2+      go (URecipTerm arg) = RecipTerm' info arg+      go (UFloatingUnaryTerm op arg) = FloatingUnaryTerm' info op arg+      go (UPowerTerm arg1 arg2) = PowerTerm' info arg1 arg2+      go (UFPUnaryTerm op arg) = goPhantomFPUnary info getPhantomDict op arg+      go (UFPBinaryTerm op arg1 arg2) =+        goPhantomFPBinary info getPhantomDict op arg1 arg2+      go (UFPRoundingUnaryTerm op mode arg) =+        goPhantomFPRoundingUnary info getPhantomDict op mode arg+      go (UFPRoundingBinaryTerm op mode arg1 arg2) =+        goPhantomFPRoundingBinary info getPhantomDict op mode arg1 arg2+      go (UFPFMATerm mode arg1 arg2 arg3) =+        goPhantomFPFMA info getPhantomDict mode arg1 arg2 arg3+      go (UFromIntegralTerm arg) =+        goPhantomFromIntegral info getPhantomDict arg+      go (UFromFPOrTerm d mode arg) = FromFPOrTerm' info d mode arg+      go (UToFPTerm mode (arg :: Term a) _ _) =+        goPhantomToFP info getPhantomDict mode arg+      {-# INLINE go #-}++  -- {-# INLINE identify #-}+  threadId = termThreadId+  {-# INLINE threadId #-}++  descriptionDigest (DConTerm _ h _) = h+  descriptionDigest (DSymTerm h _) = h+  descriptionDigest (DForallTerm h _ _) = h+  descriptionDigest (DExistsTerm h _ _) = h+  descriptionDigest (DNotTerm h _) = h+  descriptionDigest (DOrTerm h _ _ _) = h+  descriptionDigest (DAndTerm h _ _ _) = h+  descriptionDigest (DEqTerm h _ _ _) = h+  descriptionDigest (DDistinctTerm h _ _) = h+  descriptionDigest (DITETerm h _ _ _) = h+  descriptionDigest (DAddNumTerm h _ _) = h+  descriptionDigest (DNegNumTerm h _) = h+  descriptionDigest (DMulNumTerm h _ _) = h+  descriptionDigest (DAbsNumTerm h _) = h+  descriptionDigest (DSignumNumTerm h _) = h+  descriptionDigest (DLtOrdTerm h _ _ _) = h+  descriptionDigest (DLeOrdTerm h _ _ _) = h+  descriptionDigest (DAndBitsTerm h _ _) = h+  descriptionDigest (DOrBitsTerm h _ _) = h+  descriptionDigest (DXorBitsTerm h _ _) = h+  descriptionDigest (DComplementBitsTerm h _) = h+  descriptionDigest (DShiftLeftTerm h _ _) = h+  descriptionDigest (DShiftRightTerm h _ _) = h+  descriptionDigest (DRotateLeftTerm h _ _) = h+  descriptionDigest (DRotateRightTerm h _ _) = h+  descriptionDigest (DBitCastTerm h _) = h+  descriptionDigest (DBitCastOrTerm h _ _) = h+  descriptionDigest (DBVConcatTerm h _ _) = h+  descriptionDigest (DBVSelectTerm h _ _) = h+  descriptionDigest (DBVExtendTerm h _ _ _) = h+  descriptionDigest (DDivIntegralTerm h _ _) = h+  descriptionDigest (DModIntegralTerm h _ _) = h+  descriptionDigest (DQuotIntegralTerm h _ _) = h+  descriptionDigest (DRemIntegralTerm h _ _) = h+  descriptionDigest (DApplyTerm h _ _) = h+  descriptionDigest (DFPTraitTerm h _ _) = h+  descriptionDigest (DFdivTerm h _ _) = h+  descriptionDigest (DRecipTerm h _) = h+  descriptionDigest (DFloatingUnaryTerm h _ _) = h+  descriptionDigest (DPowerTerm h _ _) = h+  descriptionDigest (DFPUnaryTerm h _ _) = h+  descriptionDigest (DFPBinaryTerm h _ _ _) = h+  descriptionDigest (DFPRoundingUnaryTerm h _ _ _) = h+  descriptionDigest (DFPRoundingBinaryTerm h _ _ _ _) = h+  descriptionDigest (DFPFMATerm h _ _ _ _) = h+  descriptionDigest (DFromIntegralTerm h _) = h+  descriptionDigest (DFromFPOrTerm h _ _ _) = h+  descriptionDigest (DToFPTerm h _ _) = h++-- {-# INLINE descriptionDigest #-}+{-# NOINLINE goPhantomCon #-}+goPhantomCon ::+  CachedInfo ->+  PhantomDict t ->+  t ->+  Term t+goPhantomCon info PhantomDict v = ConTerm' info v++{-# NOINLINE goPhantomBitCast #-}+goPhantomBitCast ::+  (PEvalBitCastTerm a t) =>+  CachedInfo ->+  PhantomDict t ->+  Term a ->+  Term t+goPhantomBitCast info PhantomDict arg = BitCastTerm' info arg++{-# NOINLINE goPhantomBVConcat #-}+goPhantomBVConcat ::+  ( PEvalBVTerm bv,+    KnownNat l,+    KnownNat r,+    KnownNat (l + r),+    1 <= l,+    1 <= r,+    1 <= l + r+  ) =>+  CachedInfo ->+  PhantomDict (bv (l + r)) ->+  Term (bv l) ->+  Term (bv r) ->+  Term (bv (l + r))+goPhantomBVConcat info PhantomDict arg1 arg2 =+  BVConcatTerm' info arg1 arg2++{-# NOINLINE goPhantomBVSelect #-}+goPhantomBVSelect ::+  ( PEvalBVTerm bv,+    KnownNat n,+    KnownNat ix,+    KnownNat w,+    1 <= n,+    1 <= w,+    ix + w <= n+  ) =>+  CachedInfo ->+  PhantomDict (bv w) ->+  Proxy ix ->+  Proxy w ->+  Term (bv n) ->+  Term (bv w)+goPhantomBVSelect info PhantomDict ix w arg =+  BVSelectTerm' info ix w arg++{-# NOINLINE goPhantomBVExtend #-}+goPhantomBVExtend ::+  ( PEvalBVTerm bv,+    KnownNat l,+    KnownNat r,+    1 <= l,+    1 <= r,+    l <= r+  ) =>+  CachedInfo ->+  PhantomDict (bv r) ->+  Bool ->+  Proxy r ->+  Term (bv l) ->+  Term (bv r)+goPhantomBVExtend info PhantomDict signed n arg =+  BVExtendTerm' info signed n arg++{-# NOINLINE goPhantomApply #-}+goPhantomApply ::+  (PEvalApplyTerm f a t) =>+  CachedInfo ->+  PhantomDict t ->+  Term f ->+  Term a ->+  Term t+goPhantomApply info PhantomDict f arg = ApplyTerm' info f arg++{-# NOINLINE goPhantomFPTrait #-}+goPhantomFPTrait ::+  (ValidFP eb sb, PEvalFPTerm fp) =>+  CachedInfo ->+  PhantomDict (fp eb sb) ->+  FPTrait ->+  Term (fp eb sb) ->+  Term Bool+goPhantomFPTrait info PhantomDict trait arg = FPTraitTerm' info trait arg++{-# NOINLINE goPhantomFPUnary #-}+goPhantomFPUnary ::+  (ValidFP eb sb, PEvalFPTerm fp) =>+  CachedInfo ->+  PhantomDict (fp eb sb) ->+  FPUnaryOp ->+  Term (fp eb sb) ->+  Term (fp eb sb)+goPhantomFPUnary info PhantomDict op arg = FPUnaryTerm' info op arg++{-# NOINLINE goPhantomFPBinary #-}+goPhantomFPBinary ::+  (ValidFP eb sb, PEvalFPTerm fp) =>+  CachedInfo ->+  PhantomDict (fp eb sb) ->+  FPBinaryOp ->+  Term (fp eb sb) ->+  Term (fp eb sb) ->+  Term (fp eb sb)+goPhantomFPBinary info PhantomDict op arg1 arg2 =+  FPBinaryTerm' info op arg1 arg2++{-# NOINLINE goPhantomFPRoundingUnary #-}+goPhantomFPRoundingUnary ::+  (ValidFP eb sb, PEvalFPTerm fp) =>+  CachedInfo ->+  PhantomDict (fp eb sb) ->+  FPRoundingUnaryOp ->+  Term FPRoundingMode ->+  Term (fp eb sb) ->+  Term (fp eb sb)+goPhantomFPRoundingUnary info PhantomDict op mode arg =+  FPRoundingUnaryTerm' info op mode arg++{-# NOINLINE goPhantomFPRoundingBinary #-}+goPhantomFPRoundingBinary ::+  (ValidFP eb sb, PEvalFPTerm fp) =>+  CachedInfo ->+  PhantomDict (fp eb sb) ->+  FPRoundingBinaryOp ->+  Term FPRoundingMode ->+  Term (fp eb sb) ->+  Term (fp eb sb) ->+  Term (fp eb sb)+goPhantomFPRoundingBinary info PhantomDict op mode arg1 arg2 =+  FPRoundingBinaryTerm' info op mode arg1 arg2++{-# NOINLINE goPhantomFPFMA #-}+goPhantomFPFMA ::+  (ValidFP eb sb, PEvalFPTerm fp) =>+  CachedInfo ->+  PhantomDict (fp eb sb) ->+  Term FPRoundingMode ->+  Term (fp eb sb) ->+  Term (fp eb sb) ->+  Term (fp eb sb) ->+  Term (fp eb sb)+goPhantomFPFMA info PhantomDict mode arg1 arg2 arg3 =+  FPFMATerm' info mode arg1 arg2 arg3++{-# NOINLINE goPhantomFromIntegral #-}+goPhantomFromIntegral ::+  (PEvalFromIntegralTerm a b) =>+  CachedInfo ->+  PhantomDict b ->+  Term a ->+  Term b+goPhantomFromIntegral info PhantomDict arg = FromIntegralTerm' info arg++{-# NOINLINE goPhantomToFP #-}+goPhantomToFP ::+  forall a eb sb.+  (ValidFP eb sb, PEvalIEEEFPConvertibleTerm a) =>+  CachedInfo ->+  PhantomDict (FP eb sb) ->+  Term FPRoundingMode ->+  Term a ->+  Term (FP eb sb)+goPhantomToFP info PhantomDict mode arg =+  ToFPTerm' info mode arg (Proxy @eb) (Proxy @sb)++instance Eq (Description (Term t)) where+  DConTerm eqFunc _ l == DConTerm _ _ r =+    eqFunc l r+  DSymTerm _ ls == DSymTerm _ rs = ls == rs+  DForallTerm _ ls li == DForallTerm _ rs ri =+    eqHeteroSymbol ls rs && eqHashId li ri+  DExistsTerm _ ls li == DExistsTerm _ rs ri =+    eqHeteroSymbol ls rs && eqHashId li ri+  DNotTerm _ li == DNotTerm _ ri = eqHashId li ri+  DOrTerm _ li1 li2 _ == DOrTerm _ ri1 ri2 _ = eqHashId li1 ri1 && eqHashId li2 ri2+  DAndTerm _ li1 li2 _ == DAndTerm _ ri1 ri2 _ = eqHashId li1 ri1 && eqHashId li2 ri2+  DEqTerm _ lfp li1 li2 == DEqTerm _ rfp ri1 ri2 = lfp == rfp && eqHashId li1 ri1 && eqHashId li2 ri2+  DDistinctTerm _ lfp li == DDistinctTerm _ rfp ri =+    lfp == rfp+      && length li == length ri+      && and (zipWith eqHashId (toList li) (toList ri))+  DITETerm _ lc li1 li2 == DITETerm _ rc ri1 ri2 = eqHashId lc rc && eqHashId li1 ri1 && eqHashId li2 ri2+  DAddNumTerm _ li1 li2 == DAddNumTerm _ ri1 ri2 = eqHashId li1 ri1 && eqHashId li2 ri2+  DNegNumTerm _ li == DNegNumTerm _ ri = eqHashId li ri+  DMulNumTerm _ li1 li2 == DMulNumTerm _ ri1 ri2 = eqHashId li1 ri1 && eqHashId li2 ri2+  DAbsNumTerm _ li == DAbsNumTerm _ ri = eqHashId li ri+  DSignumNumTerm _ li == DSignumNumTerm _ ri = eqHashId li ri+  DLtOrdTerm _ lrep li1 li2 == DLtOrdTerm _ rrep ri1 ri2 = lrep == rrep && eqHashId li1 ri1 && eqHashId li2 ri2+  DLeOrdTerm _ lrep li1 li2 == DLeOrdTerm _ rrep ri1 ri2 = lrep == rrep && eqHashId li1 ri1 && eqHashId li2 ri2+  DAndBitsTerm _ li1 li2 == DAndBitsTerm _ ri1 ri2 = eqHashId li1 ri1 && eqHashId li2 ri2+  DOrBitsTerm _ li1 li2 == DOrBitsTerm _ ri1 ri2 = eqHashId li1 ri1 && eqHashId li2 ri2+  DXorBitsTerm _ li1 li2 == DXorBitsTerm _ ri1 ri2 = eqHashId li1 ri1 && eqHashId li2 ri2+  DComplementBitsTerm _ li == DComplementBitsTerm _ ri = eqHashId li ri+  DShiftLeftTerm _ li ln == DShiftLeftTerm _ ri rn = eqHashId li ri && eqHashId ln rn+  DShiftRightTerm _ li ln == DShiftRightTerm _ ri rn = eqHashId li ri && eqHashId ln rn+  DRotateLeftTerm _ li ln == DRotateLeftTerm _ ri rn = eqHashId li ri && eqHashId ln rn+  DRotateRightTerm _ li ln == DRotateRightTerm _ ri rn = eqHashId li ri && eqHashId ln rn+  DBitCastTerm _ li == DBitCastTerm _ ri = li == ri+  DBitCastOrTerm _ ld li == DBitCastOrTerm _ rd ri = ld == rd && li == ri+  DBVConcatTerm _ li1 li2 == DBVConcatTerm _ ri1 ri2 = li1 == ri1 && li2 == ri2+  DBVSelectTerm _ lix li == DBVSelectTerm _ rix ri =+    lix == rix && li == ri+  DBVExtendTerm _ lIsSigned _ li == DBVExtendTerm _ rIsSigned _ ri =+    lIsSigned == rIsSigned+      && li == ri+  DApplyTerm _ lf li == DApplyTerm _ rf ri = lf == rf && li == ri+  DDivIntegralTerm _ li1 li2 == DDivIntegralTerm _ ri1 ri2 = eqHashId li1 ri1 && eqHashId li2 ri2+  DModIntegralTerm _ li1 li2 == DModIntegralTerm _ ri1 ri2 = eqHashId li1 ri1 && eqHashId li2 ri2+  DQuotIntegralTerm _ li1 li2 == DQuotIntegralTerm _ ri1 ri2 = eqHashId li1 ri1 && eqHashId li2 ri2+  DRemIntegralTerm _ li1 li2 == DRemIntegralTerm _ ri1 ri2 = eqHashId li1 ri1 && eqHashId li2 ri2+  DFPTraitTerm _ lt li == DFPTraitTerm _ rt ri = lt == rt && li == ri+  DFdivTerm _ li1 li2 == DFdivTerm _ ri1 ri2 = eqHashId li1 ri1 && eqHashId li2 ri2+  DRecipTerm _ li == DRecipTerm _ ri = eqHashId li ri+  DFloatingUnaryTerm _ lop li == DFloatingUnaryTerm _ rop ri = lop == rop && eqHashId li ri+  DPowerTerm _ li1 li2 == DPowerTerm _ ri1 ri2 = eqHashId li1 ri1 && eqHashId li2 ri2+  DFPUnaryTerm _ lop li == DFPUnaryTerm _ rop ri = lop == rop && eqHashId li ri+  DFPBinaryTerm _ lop li1 li2 == DFPBinaryTerm _ rop ri1 ri2 = lop == rop && eqHashId li1 ri1 && eqHashId li2 ri2+  DFPRoundingUnaryTerm _ lop lmode li == DFPRoundingUnaryTerm _ rop rmode ri =+    lop == rop && eqHashId lmode rmode && eqHashId li ri+  DFPRoundingBinaryTerm _ lop lmode li1 li2 == DFPRoundingBinaryTerm _ rop rmode ri1 ri2 =+    lop == rop && eqHashId lmode rmode && eqHashId li1 ri1 && eqHashId li2 ri2+  DFPFMATerm _ lmode li1 li2 li3 == DFPFMATerm _ rmode ri1 ri2 ri3 =+    eqHashId lmode rmode && eqHashId li1 ri1 && eqHashId li2 ri2 && eqHashId li3 ri3+  DFromIntegralTerm _ li == DFromIntegralTerm _ ri = li == ri+  DFromFPOrTerm _ ld li lai == DFromFPOrTerm _ rd ri rai = eqHashId ld rd && eqHashId li ri && lai == rai+  DToFPTerm _ li lai == DToFPTerm _ ri rai = eqHashId li ri && lai == rai+  _ == _ = False++-- {-# INLINE (==) #-}++instance Hashable (Description (Term t)) where+  hashWithSalt s = hashWithSalt s . descriptionDigest+  {-# INLINE hashWithSalt #-}++fullReconstructTerm1 ::+  forall a b.+  (Term a -> IO (Term b)) ->+  Term a ->+  IO (Term b)+fullReconstructTerm1 f x = fullReconstructTerm x >>= f+{-# INLINE fullReconstructTerm1 #-}++fullReconstructTerm2 ::+  forall a b c.+  (Term a -> Term b -> IO (Term c)) ->+  Term a ->+  Term b ->+  IO (Term c)+fullReconstructTerm2 f x y = do+  rx <- fullReconstructTerm x+  ry <- fullReconstructTerm y+  f rx ry+{-# INLINE fullReconstructTerm2 #-}++fullReconstructTerm3 ::+  forall a b c d.+  (Term a -> Term b -> Term c -> IO (Term d)) ->+  Term a ->+  Term b ->+  Term c ->+  IO (Term d)+fullReconstructTerm3 f x y z = do+  rx <- fullReconstructTerm x+  ry <- fullReconstructTerm y+  rz <- fullReconstructTerm z+  f rx ry rz+{-# INLINE fullReconstructTerm3 #-}++fullReconstructTerm2Set ::+  forall a c.+  (Term a -> Term a -> HS.HashSet (Term a) -> IO (Term c)) ->+  Term a ->+  Term a ->+  HS.HashSet (Term a) ->+  IO (Term c)+fullReconstructTerm2Set f x y s = do+  rx@SupportedTerm <- fullReconstructTerm x+  ry <- fullReconstructTerm y+  rs <- traverse fullReconstructTerm (HS.toList s)+  f rx ry (HS.fromList rs)+{-# INLINE fullReconstructTerm2Set #-}++fullReconstructTerm :: forall t. Term t -> IO (Term t)+fullReconstructTerm (ConTerm i) = curThreadConTerm i+fullReconstructTerm (SymTerm sym) = curThreadSymTerm sym+fullReconstructTerm (ForallTerm sym arg) =+  fullReconstructTerm1 (curThreadForallTerm sym) arg+fullReconstructTerm (ExistsTerm sym arg) =+  fullReconstructTerm1 (curThreadExistsTerm sym) arg+fullReconstructTerm (NotTerm arg) =+  fullReconstructTerm1 curThreadNotTerm arg+fullReconstructTerm (OrTermAll arg1 arg2 s) =+  fullReconstructTerm2Set curThreadOrTerm arg1 arg2 s+fullReconstructTerm (OrTerm _ _) = error "Make compiler happy"+fullReconstructTerm (AndTermAll arg1 arg2 s) =+  fullReconstructTerm2Set curThreadAndTerm arg1 arg2 s+fullReconstructTerm (AndTerm _ _) = error "Make compiler happy"+fullReconstructTerm (EqTerm arg1 arg2) =+  fullReconstructTerm2 curThreadEqTerm arg1 arg2+fullReconstructTerm (DistinctTerm args) =+  traverse fullReconstructTerm args >>= curThreadDistinctTerm+fullReconstructTerm (ITETerm cond arg1 arg2) =+  fullReconstructTerm3 curThreadIteTerm cond arg1 arg2+fullReconstructTerm (AddNumTerm arg1 arg2) =+  fullReconstructTerm2 curThreadAddNumTerm arg1 arg2+fullReconstructTerm (NegNumTerm arg) =+  fullReconstructTerm1 curThreadNegNumTerm arg+fullReconstructTerm (MulNumTerm arg1 arg2) =+  fullReconstructTerm2 curThreadMulNumTerm arg1 arg2+fullReconstructTerm (AbsNumTerm arg) =+  fullReconstructTerm1 curThreadAbsNumTerm arg+fullReconstructTerm (SignumNumTerm arg) =+  fullReconstructTerm1 curThreadSignumNumTerm arg+fullReconstructTerm (LtOrdTerm arg1 arg2) =+  fullReconstructTerm2 curThreadLtOrdTerm arg1 arg2+fullReconstructTerm (LeOrdTerm arg1 arg2) =+  fullReconstructTerm2 curThreadLeOrdTerm arg1 arg2+fullReconstructTerm (AndBitsTerm arg1 arg2) =+  fullReconstructTerm2 curThreadAndBitsTerm arg1 arg2+fullReconstructTerm (OrBitsTerm arg1 arg2) =+  fullReconstructTerm2 curThreadOrBitsTerm arg1 arg2+fullReconstructTerm (XorBitsTerm arg1 arg2) =+  fullReconstructTerm2 curThreadXorBitsTerm arg1 arg2+fullReconstructTerm (ComplementBitsTerm arg) =+  fullReconstructTerm1 curThreadComplementBitsTerm arg+fullReconstructTerm (ShiftLeftTerm arg n) =+  fullReconstructTerm1 (curThreadShiftLeftTerm arg) n+fullReconstructTerm (ShiftRightTerm arg n) =+  fullReconstructTerm1 (curThreadShiftRightTerm arg) n+fullReconstructTerm (RotateLeftTerm arg n) =+  fullReconstructTerm1 (curThreadRotateLeftTerm arg) n+fullReconstructTerm (RotateRightTerm arg n) =+  fullReconstructTerm1 (curThreadRotateRightTerm arg) n+fullReconstructTerm (BitCastTerm v) =+  fullReconstructTerm1 curThreadBitCastTerm v+fullReconstructTerm (BitCastOrTerm d v) =+  fullReconstructTerm2 curThreadBitCastOrTerm d v+fullReconstructTerm (BVConcatTerm arg1 arg2) =+  fullReconstructTerm2 curThreadBVConcatTerm arg1 arg2+fullReconstructTerm (BVSelectTerm (_ :: Proxy ix) (_ :: Proxy w) arg) =+  fullReconstructTerm1 (curThreadBVSelectTerm (Proxy @ix) (Proxy @w)) arg+fullReconstructTerm (BVExtendTerm signed p arg) =+  fullReconstructTerm1 (curThreadBVExtendTerm signed p) arg+fullReconstructTerm (ApplyTerm f arg) =+  fullReconstructTerm2 curThreadApplyTerm f arg+fullReconstructTerm (DivIntegralTerm arg1 arg2) =+  fullReconstructTerm2 curThreadDivIntegralTerm arg1 arg2+fullReconstructTerm (ModIntegralTerm arg1 arg2) =+  fullReconstructTerm2 curThreadModIntegralTerm arg1 arg2+fullReconstructTerm (QuotIntegralTerm arg1 arg2) =+  fullReconstructTerm2 curThreadQuotIntegralTerm arg1 arg2+fullReconstructTerm (RemIntegralTerm arg1 arg2) =+  fullReconstructTerm2 curThreadRemIntegralTerm arg1 arg2+fullReconstructTerm (FPTraitTerm trait arg) =+  fullReconstructTerm1 (curThreadFpTraitTerm trait) arg+fullReconstructTerm (FdivTerm arg1 arg2) =+  fullReconstructTerm2 curThreadFdivTerm arg1 arg2+fullReconstructTerm (RecipTerm arg) =+  fullReconstructTerm1 curThreadRecipTerm arg+fullReconstructTerm (FloatingUnaryTerm op arg) =+  fullReconstructTerm1 (curThreadFloatingUnaryTerm op) arg+fullReconstructTerm (PowerTerm arg1 arg2) =+  fullReconstructTerm2 curThreadPowerTerm arg1 arg2+fullReconstructTerm (FPUnaryTerm op arg) =+  fullReconstructTerm1 (curThreadFpUnaryTerm op) arg+fullReconstructTerm (FPBinaryTerm op arg1 arg2) =+  fullReconstructTerm2 (curThreadFpBinaryTerm op) arg1 arg2+fullReconstructTerm (FPRoundingUnaryTerm op mode arg) =+  fullReconstructTerm2 (curThreadFpRoundingUnaryTerm op) mode arg+fullReconstructTerm (FPRoundingBinaryTerm op mode arg1 arg2) =+  fullReconstructTerm3 (curThreadFpRoundingBinaryTerm op) mode arg1 arg2+fullReconstructTerm (FPFMATerm mode arg1 arg2 arg3) = do+  rmode <- fullReconstructTerm mode+  rarg1 <- fullReconstructTerm arg1+  rarg2 <- fullReconstructTerm arg2+  rarg3 <- fullReconstructTerm arg3+  curThreadFpFMATerm rmode rarg1 rarg2 rarg3+fullReconstructTerm (FromIntegralTerm arg) =+  fullReconstructTerm1 curThreadFromIntegralTerm arg+fullReconstructTerm (FromFPOrTerm d r arg) =+  fullReconstructTerm3 curThreadFromFPOrTerm d r arg+fullReconstructTerm (ToFPTerm r arg _ _) =+  fullReconstructTerm2 curThreadToFPTerm r arg++toCurThreadImpl :: forall t. WeakThreadId -> Term t -> IO (Term t)+toCurThreadImpl tid t | termThreadId t == tid = return t+toCurThreadImpl _ t = fullReconstructTerm t+{-# INLINE toCurThreadImpl #-}++-- | Convert a term to the current thread.+toCurThread :: forall t. Term t -> IO (Term t)+toCurThread t = do+  tid <- myWeakThreadId+  toCurThreadImpl tid t+{-# INLINE toCurThread #-}++-- | Construct and internalizing a 'ConTerm'.+curThreadConTerm :: forall t. (SupportedPrim t) => t -> IO (Term t)+curThreadConTerm t = intern $ UConTerm t+{-# INLINE curThreadConTerm #-}++-- | Construct and internalizing a 'SymTerm'.+curThreadSymTerm :: forall knd t. TypedSymbol knd t -> IO (Term t)+curThreadSymTerm (TypedSymbol s) = intern $ USymTerm $ TypedSymbol s+{-# INLINE curThreadSymTerm #-}++-- | Construct and internalizing a 'ForallTerm'.+curThreadForallTerm ::+  TypedSymbol 'ConstantKind t ->+  Term Bool ->+  IO (Term Bool)+curThreadForallTerm sym arg = intern $ UForallTerm sym arg+{-# INLINE curThreadForallTerm #-}++-- | Construct and internalizing a 'ExistsTerm'.+curThreadExistsTerm ::+  TypedSymbol 'ConstantKind t ->+  Term Bool ->+  IO (Term Bool)+curThreadExistsTerm sym arg = intern $ UExistsTerm sym arg+{-# INLINE curThreadExistsTerm #-}++-- | Construct and internalizing a 'SymTerm' with an identifier, using simple+-- symbols.+curThreadSsymTerm :: (SupportedPrim t) => Identifier -> IO (Term t)+curThreadSsymTerm ident =+  curThreadSymTerm @AnyKind $ TypedSymbol $ SimpleSymbol ident+{-# INLINE curThreadSsymTerm #-}++-- | Construct and internalizing a 'SymTerm' with an identifier and an index,+-- using indexed symbols.+curThreadIsymTerm :: (SupportedPrim t) => Identifier -> Int -> IO (Term t)+curThreadIsymTerm str idx =+  curThreadSymTerm @AnyKind $ TypedSymbol $ IndexedSymbol str idx+{-# INLINE curThreadIsymTerm #-}++-- | Construct and internalizing a 'NotTerm'.+curThreadNotTerm :: Term Bool -> IO (Term Bool)+curThreadNotTerm = intern . UNotTerm+{-# INLINE curThreadNotTerm #-}++-- | Construct and internalizing a 'OrTerm'.+curThreadOrTerm :: Term Bool -> Term Bool -> HS.HashSet (Term Bool) -> IO (Term Bool)+curThreadOrTerm l r s = intern $ UOrTerm l r s+{-# INLINE curThreadOrTerm #-}++-- | Construct and internalizing a 'AndTerm'.+curThreadAndTerm :: Term Bool -> Term Bool -> HS.HashSet (Term Bool) -> IO (Term Bool)+curThreadAndTerm l r s = intern $ UAndTerm l r s+{-# INLINE curThreadAndTerm #-}++-- | Construct and internalizing a 'EqTerm'.+curThreadEqTerm :: Term a -> Term a -> IO (Term Bool)+curThreadEqTerm l r = intern $ UEqTerm l r+{-# INLINE curThreadEqTerm #-}++-- | Construct and internalizing a 'DistinctTerm'.+curThreadDistinctTerm :: NonEmpty (Term a) -> IO (Term Bool)+curThreadDistinctTerm args = intern $ UDistinctTerm args+{-# INLINE curThreadDistinctTerm #-}++-- | Construct and internalizing a 'ITETerm'.+curThreadIteTerm :: Term Bool -> Term a -> Term a -> IO (Term a)+curThreadIteTerm c l@SupportedTerm r = intern $ UITETerm c l r+{-# INLINE curThreadIteTerm #-}++-- | Construct and internalizing a 'AddNumTerm'.+curThreadAddNumTerm :: (PEvalNumTerm a) => Term a -> Term a -> IO (Term a)+curThreadAddNumTerm l@SupportedTerm r = intern $ UAddNumTerm l r+{-# INLINE curThreadAddNumTerm #-}++-- | Construct and internalizing a 'NegNumTerm'.+curThreadNegNumTerm :: (PEvalNumTerm a) => Term a -> IO (Term a)+curThreadNegNumTerm l@SupportedTerm = intern $ UNegNumTerm l+{-# INLINE curThreadNegNumTerm #-}++-- | Construct and internalizing a 'MulNumTerm'.+curThreadMulNumTerm :: (PEvalNumTerm a) => Term a -> Term a -> IO (Term a)+curThreadMulNumTerm l@SupportedTerm r = intern $ UMulNumTerm l r+{-# INLINE curThreadMulNumTerm #-}++-- | Construct and internalizing a 'AbsNumTerm'.+curThreadAbsNumTerm :: (PEvalNumTerm a) => Term a -> IO (Term a)+curThreadAbsNumTerm l@SupportedTerm = intern $ UAbsNumTerm l+{-# INLINE curThreadAbsNumTerm #-}++-- | Construct and internalizing a 'SignumNumTerm'.+curThreadSignumNumTerm :: (PEvalNumTerm a) => Term a -> IO (Term a)+curThreadSignumNumTerm l@SupportedTerm = intern $ USignumNumTerm l+{-# INLINE curThreadSignumNumTerm #-}++-- | Construct and internalizing a 'LtOrdTerm'.+curThreadLtOrdTerm :: (PEvalOrdTerm a) => Term a -> Term a -> IO (Term Bool)+curThreadLtOrdTerm l@SupportedTerm r = intern $ ULtOrdTerm l r+{-# INLINE curThreadLtOrdTerm #-}++-- | Construct and internalizing a 'LeOrdTerm'.+curThreadLeOrdTerm :: (PEvalOrdTerm a) => Term a -> Term a -> IO (Term Bool)+curThreadLeOrdTerm l@SupportedTerm r = intern $ ULeOrdTerm l r+{-# INLINE curThreadLeOrdTerm #-}++-- | Construct and internalizing a 'AndBitsTerm'.+curThreadAndBitsTerm :: (PEvalBitwiseTerm a) => Term a -> Term a -> IO (Term a)+curThreadAndBitsTerm l@SupportedTerm r = intern $ UAndBitsTerm l r+{-# INLINE curThreadAndBitsTerm #-}++-- | Construct and internalizing a 'OrBitsTerm'.+curThreadOrBitsTerm :: (PEvalBitwiseTerm a) => Term a -> Term a -> IO (Term a)+curThreadOrBitsTerm l@SupportedTerm r = intern $ UOrBitsTerm l r+{-# INLINE curThreadOrBitsTerm #-}++-- | Construct and internalizing a 'XorBitsTerm'.+curThreadXorBitsTerm :: (PEvalBitwiseTerm a) => Term a -> Term a -> IO (Term a)+curThreadXorBitsTerm l@SupportedTerm r = intern $ UXorBitsTerm l r+{-# INLINE curThreadXorBitsTerm #-}++-- | Construct and internalizing a 'ComplementBitsTerm'.+curThreadComplementBitsTerm :: (PEvalBitwiseTerm a) => Term a -> IO (Term a)+curThreadComplementBitsTerm l@SupportedTerm = intern $ UComplementBitsTerm l+{-# INLINE curThreadComplementBitsTerm #-}++-- | Construct and internalizing a 'ShiftLeftTerm'.+curThreadShiftLeftTerm :: (PEvalShiftTerm a) => Term a -> Term a -> IO (Term a)+curThreadShiftLeftTerm t@SupportedTerm n = intern $ UShiftLeftTerm t n+{-# INLINE curThreadShiftLeftTerm #-}++-- | Construct and internalizing a 'ShiftRightTerm'.+curThreadShiftRightTerm :: (PEvalShiftTerm a) => Term a -> Term a -> IO (Term a)+curThreadShiftRightTerm t@SupportedTerm n = intern $ UShiftRightTerm t n+{-# INLINE curThreadShiftRightTerm #-}++-- | Construct and internalizing a 'RotateLeftTerm'.+curThreadRotateLeftTerm ::+  (PEvalRotateTerm a) => Term a -> Term a -> IO (Term a)+curThreadRotateLeftTerm t@SupportedTerm n = intern $ URotateLeftTerm t n+{-# INLINE curThreadRotateLeftTerm #-}++-- | Construct and internalizing a 'RotateRightTerm'.+curThreadRotateRightTerm ::+  (PEvalRotateTerm a) => Term a -> Term a -> IO (Term a)+curThreadRotateRightTerm t@SupportedTerm n = intern $ URotateRightTerm t n+{-# INLINE curThreadRotateRightTerm #-}++-- | Construct and internalizing a 'BitCastTerm'.+curThreadBitCastTerm ::+  forall a b.+  (SupportedPrim b, PEvalBitCastTerm a b) =>+  Term a ->+  IO (Term b)+curThreadBitCastTerm = intern . UBitCastTerm+{-# INLINE curThreadBitCastTerm #-}++-- | Construct and internalizing a 'BitCastOrTerm'.+curThreadBitCastOrTerm ::+  (PEvalBitCastOrTerm a b) =>+  Term b ->+  Term a ->+  IO (Term b)+curThreadBitCastOrTerm d@SupportedTerm a = intern $ UBitCastOrTerm d a+{-# INLINE curThreadBitCastOrTerm #-}++-- | Construct and internalizing a 'BVConcatTerm'.+curThreadBVConcatTerm ::+  forall bv l r.+  ( PEvalBVTerm bv,+    KnownNat l,+    KnownNat r,+    KnownNat (l + r),+    1 <= l,+    1 <= r,+    1 <= l + r,+    SupportedPrim (bv (l + r))+  ) =>+  Term (bv l) ->+  Term (bv r) ->+  IO (Term (bv (l + r)))+curThreadBVConcatTerm l r = intern $ UBVConcatTerm l r+{-# INLINE curThreadBVConcatTerm #-}++-- | Construct and internalizing a 'BVSelectTerm'.+curThreadBVSelectTerm ::+  forall bv n ix w p q.+  ( PEvalBVTerm bv,+    KnownNat n,+    KnownNat ix,+    KnownNat w,+    1 <= n,+    1 <= w,+    ix + w <= n,+    SupportedPrim (bv w)+  ) =>+  p ix ->+  q w ->+  Term (bv n) ->+  IO (Term (bv w))+curThreadBVSelectTerm _ _ v = intern $ UBVSelectTerm (Proxy @ix) (Proxy @w) v+{-# INLINE curThreadBVSelectTerm #-}++-- | Construct and internalizing a 'BVExtendTerm'.+curThreadBVExtendTerm ::+  forall bv l r proxy.+  ( PEvalBVTerm bv,+    KnownNat l,+    KnownNat r,+    1 <= l,+    1 <= r,+    l <= r,+    SupportedPrim (bv r)+  ) =>+  Bool ->+  proxy r ->+  Term (bv l) ->+  IO (Term (bv r))+curThreadBVExtendTerm signed _ v = intern $ UBVExtendTerm signed (Proxy @r) v+{-# INLINE curThreadBVExtendTerm #-}++-- | Construct and internalizing a 'BVExtendTerm' with sign extension.+curThreadBvsignExtendTerm ::+  forall bv l r proxy.+  ( PEvalBVTerm bv,+    KnownNat l,+    KnownNat r,+    1 <= l,+    1 <= r,+    l <= r,+    SupportedPrim (bv r)+  ) =>+  proxy r ->+  Term (bv l) ->+  IO (Term (bv r))+curThreadBvsignExtendTerm _ v = intern $ UBVExtendTerm True (Proxy @r) v+{-# INLINE curThreadBvsignExtendTerm #-}++-- | Construct and internalizing a 'BVExtendTerm' with zero extension.+curThreadBvzeroExtendTerm ::+  forall bv l r proxy.+  ( PEvalBVTerm bv,+    KnownNat l,+    KnownNat r,+    1 <= l,+    1 <= r,+    l <= r,+    SupportedPrim (bv r)+  ) =>+  proxy r ->+  Term (bv l) ->+  IO (Term (bv r))+curThreadBvzeroExtendTerm _ v = intern $ UBVExtendTerm False (Proxy @r) v+{-# INLINE curThreadBvzeroExtendTerm #-}++-- | Construct and internalizing a 'ApplyTerm'.+curThreadApplyTerm ::+  forall f a b.+  (PEvalApplyTerm f a b, SupportedPrim b) =>+  Term f ->+  Term a ->+  IO (Term b)+curThreadApplyTerm f a = intern $ UApplyTerm f a+{-# INLINE curThreadApplyTerm #-}++-- | Construct and internalizing a 'DivIntegralTerm'.+curThreadDivIntegralTerm ::+  (PEvalDivModIntegralTerm a) => Term a -> Term a -> IO (Term a)+curThreadDivIntegralTerm l@SupportedTerm r = intern $ UDivIntegralTerm l r+{-# INLINE curThreadDivIntegralTerm #-}++-- | Construct and internalizing a 'ModIntegralTerm'.+curThreadModIntegralTerm ::+  (PEvalDivModIntegralTerm a) => Term a -> Term a -> IO (Term a)+curThreadModIntegralTerm l@SupportedTerm r = intern $ UModIntegralTerm l r+{-# INLINE curThreadModIntegralTerm #-}++-- | Construct and internalizing a 'QuotIntegralTerm'.+curThreadQuotIntegralTerm ::+  (PEvalDivModIntegralTerm a) => Term a -> Term a -> IO (Term a)+curThreadQuotIntegralTerm l@SupportedTerm r = intern $ UQuotIntegralTerm l r+{-# INLINE curThreadQuotIntegralTerm #-}++-- | Construct and internalizing a 'RemIntegralTerm'.+curThreadRemIntegralTerm ::+  (PEvalDivModIntegralTerm a) => Term a -> Term a -> IO (Term a)+curThreadRemIntegralTerm l@SupportedTerm r = intern $ URemIntegralTerm l r+{-# INLINE curThreadRemIntegralTerm #-}++-- | Construct and internalizing a 'FPTraitTerm'.+curThreadFpTraitTerm ::+  (ValidFP eb sb, SupportedPrim (fp eb sb), PEvalFPTerm fp) =>+  FPTrait ->+  Term (fp eb sb) ->+  IO (Term Bool)+curThreadFpTraitTerm trait v = intern $ UFPTraitTerm trait v+{-# INLINE curThreadFpTraitTerm #-}++-- | Construct and internalizing a 'FdivTerm'.+curThreadFdivTerm :: (PEvalFractionalTerm a) => Term a -> Term a -> IO (Term a)+curThreadFdivTerm l@SupportedTerm r = intern $ UFdivTerm l r+{-# INLINE curThreadFdivTerm #-}++-- | Construct and internalizing a 'RecipTerm'.+curThreadRecipTerm :: (PEvalFractionalTerm a) => Term a -> IO (Term a)+curThreadRecipTerm l@SupportedTerm = intern $ URecipTerm l+{-# INLINE curThreadRecipTerm #-}++-- | Construct and internalizing a 'FloatingUnaryTerm'.+curThreadFloatingUnaryTerm ::+  (PEvalFloatingTerm a) => FloatingUnaryOp -> Term a -> IO (Term a)+curThreadFloatingUnaryTerm op a@SupportedTerm = intern $ UFloatingUnaryTerm op a+{-# INLINE curThreadFloatingUnaryTerm #-}++-- | Construct and internalizing a 'PowerTerm'.+curThreadPowerTerm :: (PEvalFloatingTerm a) => Term a -> Term a -> IO (Term a)+curThreadPowerTerm l@SupportedTerm r = intern $ UPowerTerm l r+{-# INLINE curThreadPowerTerm #-}++-- | Construct and internalizing a 'FPUnaryTerm'.+curThreadFpUnaryTerm ::+  (ValidFP eb sb, SupportedPrim (fp eb sb), PEvalFPTerm fp) =>+  FPUnaryOp ->+  Term (fp eb sb) ->+  IO (Term (fp eb sb))+curThreadFpUnaryTerm op v = intern $ UFPUnaryTerm op v+{-# INLINE curThreadFpUnaryTerm #-}++-- | Construct and internalizing a 'FPBinaryTerm'.+curThreadFpBinaryTerm ::+  (ValidFP eb sb, SupportedPrim (fp eb sb), PEvalFPTerm fp) =>+  FPBinaryOp ->+  Term (fp eb sb) ->+  Term (fp eb sb) ->+  IO (Term (fp eb sb))+curThreadFpBinaryTerm op l r = intern $ UFPBinaryTerm op l r+{-# INLINE curThreadFpBinaryTerm #-}++-- | Construct and internalizing a 'FPRoundingUnaryTerm'.+curThreadFpRoundingUnaryTerm ::+  (ValidFP eb sb, SupportedPrim (fp eb sb), PEvalFPTerm fp) =>+  FPRoundingUnaryOp ->+  Term FPRoundingMode ->+  Term (fp eb sb) ->+  IO (Term (fp eb sb))+curThreadFpRoundingUnaryTerm op mode v = intern $ UFPRoundingUnaryTerm op mode v+{-# INLINE curThreadFpRoundingUnaryTerm #-}++-- | Construct and internalizing a 'FPRoundingBinaryTerm'.+curThreadFpRoundingBinaryTerm ::+  (ValidFP eb sb, SupportedPrim (fp eb sb), PEvalFPTerm fp) =>+  FPRoundingBinaryOp ->+  Term FPRoundingMode ->+  Term (fp eb sb) ->+  Term (fp eb sb) ->+  IO (Term (fp eb sb))+curThreadFpRoundingBinaryTerm op mode l r =+  intern $ UFPRoundingBinaryTerm op mode l r+{-# INLINE curThreadFpRoundingBinaryTerm #-}++-- | Construct and internalizing a 'FPFMATerm'.+curThreadFpFMATerm ::+  (ValidFP eb sb, SupportedPrim (fp eb sb), PEvalFPTerm fp) =>+  Term FPRoundingMode ->+  Term (fp eb sb) ->+  Term (fp eb sb) ->+  Term (fp eb sb) ->+  IO (Term (fp eb sb))+curThreadFpFMATerm mode l r s = intern $ UFPFMATerm mode l r s+{-# INLINE curThreadFpFMATerm #-}++-- | Construct and internalizing a 'FromIntegralTerm'.+curThreadFromIntegralTerm ::+  forall a b.+  (PEvalFromIntegralTerm a b, SupportedPrim b) =>+  Term a ->+  IO (Term b)+curThreadFromIntegralTerm = intern . UFromIntegralTerm+{-# INLINE curThreadFromIntegralTerm #-}++-- | Construct and internalizing a 'FromFPOrTerm'.+curThreadFromFPOrTerm ::+  forall a eb sb.+  ( PEvalIEEEFPConvertibleTerm a,+    ValidFP eb sb+  ) =>+  Term a ->+  Term FPRoundingMode ->+  Term (FP eb sb) ->+  IO (Term a)+curThreadFromFPOrTerm d@SupportedTerm r f = intern $ UFromFPOrTerm d r f+{-# INLINE curThreadFromFPOrTerm #-}++-- | Construct and internalizing a 'ToFPTerm'.+curThreadToFPTerm ::+  forall a eb sb.+  ( PEvalIEEEFPConvertibleTerm a,+    ValidFP eb sb,+    SupportedPrim (FP eb sb)+  ) =>+  Term FPRoundingMode ->+  Term a ->+  IO (Term (FP eb sb))+curThreadToFPTerm r f = intern $ UToFPTerm r f (Proxy @eb) (Proxy @sb)+{-# INLINE curThreadToFPTerm #-}++inCurThread1 ::+  forall a b.+  (Term a -> IO (Term b)) ->+  Term a ->+  IO (Term b)+inCurThread1 f t = do+  tid <- myWeakThreadId+  toCurThreadImpl tid t >>= f+{-# INLINE inCurThread1 #-}++inCurThread2 ::+  forall a b c.+  (Term a -> Term b -> IO (Term c)) ->+  Term a ->+  Term b ->+  IO (Term c)+inCurThread2 f a b = do+  tid <- myWeakThreadId+  ra <- toCurThreadImpl tid a+  rb <- toCurThreadImpl tid b+  f ra rb+{-# INLINE inCurThread2 #-}++inCurThread3 ::+  forall a b c d.+  (Term a -> Term b -> Term c -> IO (Term d)) ->+  Term a ->+  Term b ->+  Term c ->+  IO (Term d)+inCurThread3 f a b c = do+  tid <- myWeakThreadId+  ra <- toCurThreadImpl tid a+  rb <- toCurThreadImpl tid b+  rc <- toCurThreadImpl tid c+  f ra rb rc+{-# INLINE inCurThread3 #-}++unsafeInCurThread1 ::+  forall a b.+  (Term a -> IO (Term b)) ->+  Term a ->+  Term b+unsafeInCurThread1 f = unsafePerformIO . inCurThread1 f+{-# NOINLINE unsafeInCurThread1 #-}++unsafeInCurThread2 ::+  forall a b c.+  (Term a -> Term b -> IO (Term c)) ->+  Term a ->+  Term b ->+  Term c+unsafeInCurThread2 f a b = unsafePerformIO $ inCurThread2 f a b+{-# NOINLINE unsafeInCurThread2 #-}++unsafeInCurThread3 ::+  forall a b c d.+  (Term a -> Term b -> Term c -> IO (Term d)) ->+  Term a ->+  Term b ->+  Term c ->+  Term d+unsafeInCurThread3 f a b c = unsafePerformIO $ inCurThread3 f a b c+{-# NOINLINE unsafeInCurThread3 #-}++-- | Construct and internalizing a 'ConTerm'.+conTerm :: (SupportedPrim t) => t -> Term t+conTerm = unsafePerformIO . curThreadConTerm+{-# NOINLINE conTerm #-}++-- | Construct and internalizing a 'SymTerm'.+symTerm :: TypedSymbol knd t -> Term t+symTerm = unsafePerformIO . curThreadSymTerm+{-# NOINLINE symTerm #-}++-- | Construct and internalizing a 'ForallTerm'.+forallTerm ::+  TypedSymbol 'ConstantKind t ->+  Term Bool ->+  Term Bool+forallTerm sym@TypedSymbol {} = unsafeInCurThread1 (curThreadForallTerm sym)+{-# NOINLINE forallTerm #-}++-- | Construct and internalizing a 'ExistsTerm'.+existsTerm ::+  TypedSymbol 'ConstantKind t ->+  Term Bool ->+  Term Bool+existsTerm sym@TypedSymbol {} = unsafeInCurThread1 (curThreadExistsTerm sym)+{-# NOINLINE existsTerm #-}++-- | Construct and internalizing a 'SymTerm' with an identifier, using simple+-- symbols.+ssymTerm :: (SupportedPrim t) => Identifier -> Term t+ssymTerm = unsafePerformIO . curThreadSsymTerm+{-# NOINLINE ssymTerm #-}++-- | Construct and internalizing a 'SymTerm' with an identifier and an index,+-- using indexed symbols.+isymTerm :: (SupportedPrim t) => Identifier -> Int -> Term t+isymTerm ident index = unsafePerformIO $ curThreadIsymTerm ident index+{-# NOINLINE isymTerm #-}++-- | Construct and internalizing a 'NotTerm'.+notTerm :: Term Bool -> Term Bool+notTerm = unsafeInCurThread1 curThreadNotTerm+{-# NOINLINE notTerm #-}++inCurThread2Set ::+  forall a c.+  (Term a -> Term a -> HS.HashSet (Term a) -> IO (Term c)) ->+  Term a ->+  Term a ->+  HS.HashSet (Term a) ->+  IO (Term c)+inCurThread2Set f a b s = do+  tid <- myWeakThreadId+  ra@SupportedTerm <- toCurThreadImpl tid a+  rb <- toCurThreadImpl tid b+  rs <- traverse (toCurThreadImpl tid) (HS.toList s)+  f ra rb (HS.fromList rs)+{-# INLINE inCurThread2Set #-}++unsafeInCurThread2Set ::+  forall a c.+  (Term a -> Term a -> HS.HashSet (Term a) -> IO (Term c)) ->+  Term a ->+  Term a ->+  HS.HashSet (Term a) ->+  Term c+unsafeInCurThread2Set f a b s = unsafePerformIO $ inCurThread2Set f a b s+{-# NOINLINE unsafeInCurThread2Set #-}++-- | Construct and internalizing a 'OrTerm'.+orTerm :: Term Bool -> Term Bool -> Term Bool+orTerm l@(OrTermAll _ _ s1) r@(OrTermAll _ _ s2) =+  unsafeInCurThread2Set+    curThreadOrTerm+    l+    r+    ( if HS.size s1 + HS.size s2 > 30+        then HS.fromList [l, r]+        else HS.insert l $ HS.insert r $ HS.union s1 s2+    )+orTerm l@(OrTermAll _ _ s1) r =+  unsafeInCurThread2Set+    curThreadOrTerm+    l+    r+    ( if HS.size s1 > 30+        then HS.fromList [l, r]+        else HS.insert r $ HS.insert l s1+    )+orTerm l r@(OrTermAll _ _ s2) =+  unsafeInCurThread2Set+    curThreadOrTerm+    l+    r+    ( if HS.size s2 > 30+        then HS.fromList [l, r]+        else HS.insert l $ HS.insert r s2+    )+orTerm l r = unsafeInCurThread2Set curThreadOrTerm l r (HS.fromList [l, r])+{-# NOINLINE orTerm #-}++-- | Construct and internalizing a 'AndTerm'.+andTerm :: Term Bool -> Term Bool -> Term Bool+andTerm l@(AndTermAll _ _ s1) r@(AndTermAll _ _ s2) =+  unsafeInCurThread2Set+    curThreadAndTerm+    l+    r+    ( if HS.size s1 + HS.size s2 > 30+        then HS.fromList [l, r]+        else HS.insert l $ HS.insert r $ HS.union s1 s2+    )+andTerm l@(AndTermAll _ _ s1) r =+  unsafeInCurThread2Set+    curThreadAndTerm+    l+    r+    ( if HS.size s1 > 30+        then HS.fromList [l, r]+        else HS.insert r $ HS.insert l s1+    )+andTerm l r@(AndTermAll _ _ s2) =+  unsafeInCurThread2Set+    curThreadAndTerm+    l+    r+    ( if HS.size s2 > 30+        then HS.fromList [l, r]+        else HS.insert l $ HS.insert r s2+    )+andTerm l r = unsafeInCurThread2Set curThreadAndTerm l r (HS.fromList [l, r])+{-# NOINLINE andTerm #-}++-- | Construct and internalizing a 'EqTerm'.+eqTerm :: Term a -> Term a -> Term Bool+eqTerm = unsafeInCurThread2 curThreadEqTerm+{-# NOINLINE eqTerm #-}++-- | Construct and internalizing a 'DistinctTerm'.+distinctTerm :: NonEmpty (Term a) -> Term Bool+distinctTerm args =+  unsafePerformIO $ do+    tid <- myWeakThreadId+    traverse (toCurThreadImpl tid) args >>= curThreadDistinctTerm+{-# NOINLINE distinctTerm #-}++-- | Construct and internalizing a 'ITETerm'.+iteTerm :: Term Bool -> Term a -> Term a -> Term a+iteTerm = unsafeInCurThread3 curThreadIteTerm+{-# NOINLINE iteTerm #-}++-- | Construct and internalizing a 'AddNumTerm'.+addNumTerm :: (PEvalNumTerm a) => Term a -> Term a -> Term a+addNumTerm = unsafeInCurThread2 curThreadAddNumTerm+{-# NOINLINE addNumTerm #-}++-- | Construct and internalizing a 'NegNumTerm'.+negNumTerm :: (PEvalNumTerm a) => Term a -> Term a+negNumTerm = unsafeInCurThread1 curThreadNegNumTerm+{-# NOINLINE negNumTerm #-}++-- | Construct and internalizing a 'MulNumTerm'.+mulNumTerm :: (PEvalNumTerm a) => Term a -> Term a -> Term a+mulNumTerm = unsafeInCurThread2 curThreadMulNumTerm+{-# NOINLINE mulNumTerm #-}++-- | Construct and internalizing a 'AbsNumTerm'.+absNumTerm :: (PEvalNumTerm a) => Term a -> Term a+absNumTerm = unsafeInCurThread1 curThreadAbsNumTerm+{-# NOINLINE absNumTerm #-}++-- | Construct and internalizing a 'SignumNumTerm'.+signumNumTerm :: (PEvalNumTerm a) => Term a -> Term a+signumNumTerm = unsafeInCurThread1 curThreadSignumNumTerm+{-# NOINLINE signumNumTerm #-}++-- | Construct and internalizing a 'LtOrdTerm'.+ltOrdTerm :: (PEvalOrdTerm a) => Term a -> Term a -> Term Bool+ltOrdTerm = unsafeInCurThread2 curThreadLtOrdTerm+{-# NOINLINE ltOrdTerm #-}++-- | Construct and internalizing a 'LeOrdTerm'.+leOrdTerm :: (PEvalOrdTerm a) => Term a -> Term a -> Term Bool+leOrdTerm = unsafeInCurThread2 curThreadLeOrdTerm+{-# NOINLINE leOrdTerm #-}++-- | Construct and internalizing a 'AndBitsTerm'.+andBitsTerm :: (PEvalBitwiseTerm a) => Term a -> Term a -> Term a+andBitsTerm a b =+  unsafeInCurThread2 curThreadAndBitsTerm a b+{-# NOINLINE andBitsTerm #-}++-- | Construct and internalizing a 'OrBitsTerm'.+orBitsTerm :: (PEvalBitwiseTerm a) => Term a -> Term a -> Term a+orBitsTerm = unsafeInCurThread2 curThreadOrBitsTerm+{-# NOINLINE orBitsTerm #-}++-- | Construct and internalizing a 'XorBitsTerm'.+xorBitsTerm :: (PEvalBitwiseTerm a) => Term a -> Term a -> Term a+xorBitsTerm = unsafeInCurThread2 curThreadXorBitsTerm+{-# NOINLINE xorBitsTerm #-}++-- | Construct and internalizing a 'ComplementBitsTerm'.+complementBitsTerm :: (PEvalBitwiseTerm a) => Term a -> Term a+complementBitsTerm = unsafeInCurThread1 curThreadComplementBitsTerm+{-# NOINLINE complementBitsTerm #-}++-- | Construct and internalizing a 'ShiftLeftTerm'.+shiftLeftTerm :: (PEvalShiftTerm a) => Term a -> Term a -> Term a+shiftLeftTerm = unsafeInCurThread2 curThreadShiftLeftTerm+{-# NOINLINE shiftLeftTerm #-}++-- | Construct and internalizing a 'ShiftRightTerm'.+shiftRightTerm :: (PEvalShiftTerm a) => Term a -> Term a -> Term a+shiftRightTerm = unsafeInCurThread2 curThreadShiftRightTerm+{-# NOINLINE shiftRightTerm #-}++-- | Construct and internalizing a 'RotateLeftTerm'.+rotateLeftTerm :: (PEvalRotateTerm a) => Term a -> Term a -> Term a+rotateLeftTerm = unsafeInCurThread2 curThreadRotateLeftTerm+{-# NOINLINE rotateLeftTerm #-}++-- | Construct and internalizing a 'RotateRightTerm'.+rotateRightTerm :: (PEvalRotateTerm a) => Term a -> Term a -> Term a+rotateRightTerm = unsafeInCurThread2 curThreadRotateRightTerm+{-# NOINLINE rotateRightTerm #-}++-- | Construct and internalizing a 'BitCastTerm'.+bitCastTerm ::+  (PEvalBitCastTerm a b, SupportedPrim b) =>+  Term a ->+  Term b+bitCastTerm = unsafeInCurThread1 curThreadBitCastTerm+{-# NOINLINE bitCastTerm #-}++-- | Construct and internalizing a 'BitCastOrTerm'.+bitCastOrTerm ::+  (PEvalBitCastOrTerm a b) =>+  Term b ->+  Term a ->+  Term b+bitCastOrTerm = unsafeInCurThread2 curThreadBitCastOrTerm+{-# NOINLINE bitCastOrTerm #-}++-- | Construct and internalizing a 'BVConcatTerm'.+bvConcatTerm ::+  forall bv l r.+  ( PEvalBVTerm bv,+    KnownNat l,+    KnownNat r,+    KnownNat (l + r),+    1 <= l,+    1 <= r,+    1 <= l + r,+    SupportedPrim (bv (l + r))+  ) =>+  Term (bv l) ->+  Term (bv r) ->+  Term (bv (l + r))+bvConcatTerm = unsafeInCurThread2 curThreadBVConcatTerm+{-# NOINLINE bvConcatTerm #-}++-- | Construct and internalizing a 'BVSelectTerm'.+bvSelectTerm ::+  forall bv n ix w p q.+  ( PEvalBVTerm bv,+    KnownNat n,+    KnownNat ix,+    KnownNat w,+    1 <= n,+    1 <= w,+    ix + w <= n,+    SupportedPrim (bv w)+  ) =>+  p ix ->+  q w ->+  Term (bv n) ->+  Term (bv w)+bvSelectTerm ix w = unsafeInCurThread1 (curThreadBVSelectTerm ix w)+{-# NOINLINE bvSelectTerm #-}++-- | Construct and internalizing a 'BVExtendTerm'.+bvExtendTerm ::+  forall bv l r proxy.+  ( PEvalBVTerm bv,+    KnownNat l,+    KnownNat r,+    1 <= l,+    1 <= r,+    l <= r,+    SupportedPrim (bv r)+  ) =>+  Bool ->+  proxy r ->+  Term (bv l) ->+  Term (bv r)+bvExtendTerm signed r = unsafeInCurThread1 (curThreadBVExtendTerm signed r)+{-# NOINLINE bvExtendTerm #-}++-- | Construct and internalizing a 'BVExtendTerm' with sign extension.+bvsignExtendTerm ::+  forall bv l r proxy.+  ( PEvalBVTerm bv,+    KnownNat l,+    KnownNat r,+    1 <= l,+    1 <= r,+    l <= r,+    SupportedPrim (bv r)+  ) =>+  proxy r ->+  Term (bv l) ->+  Term (bv r)+bvsignExtendTerm r = unsafeInCurThread1 (curThreadBvsignExtendTerm r)+{-# NOINLINE bvsignExtendTerm #-}++-- | Construct and internalizing a 'BVExtendTerm' with zero extension.+bvzeroExtendTerm ::+  forall bv l r proxy.+  ( PEvalBVTerm bv,+    KnownNat l,+    KnownNat r,+    1 <= l,+    1 <= r,+    l <= r,+    SupportedPrim (bv r)+  ) =>+  proxy r ->+  Term (bv l) ->+  Term (bv r)+bvzeroExtendTerm r = unsafeInCurThread1 (curThreadBvzeroExtendTerm r)+{-# NOINLINE bvzeroExtendTerm #-}++-- | Construct and internalizing a 'ApplyTerm'.+applyTerm ::+  (PEvalApplyTerm f a b, SupportedPrim b) => Term f -> Term a -> Term b+applyTerm = unsafeInCurThread2 curThreadApplyTerm+{-# NOINLINE applyTerm #-}++-- | Construct and internalizing a 'DivIntegralTerm'.+divIntegralTerm :: (PEvalDivModIntegralTerm a) => Term a -> Term a -> Term a+divIntegralTerm = unsafeInCurThread2 curThreadDivIntegralTerm+{-# NOINLINE divIntegralTerm #-}++-- | Construct and internalizing a 'ModIntegralTerm'.+modIntegralTerm :: (PEvalDivModIntegralTerm a) => Term a -> Term a -> Term a+modIntegralTerm = unsafeInCurThread2 curThreadModIntegralTerm+{-# NOINLINE modIntegralTerm #-}++-- | Construct and internalizing a 'QuotIntegralTerm'.+quotIntegralTerm :: (PEvalDivModIntegralTerm a) => Term a -> Term a -> Term a+quotIntegralTerm = unsafeInCurThread2 curThreadQuotIntegralTerm+{-# NOINLINE quotIntegralTerm #-}++-- | Construct and internalizing a 'RemIntegralTerm'.+remIntegralTerm :: (PEvalDivModIntegralTerm a) => Term a -> Term a -> Term a+remIntegralTerm = unsafeInCurThread2 curThreadRemIntegralTerm+{-# NOINLINE remIntegralTerm #-}++-- | Construct and internalizing a 'FPTraitTerm'.+fpTraitTerm ::+  (ValidFP eb sb, SupportedPrim (fp eb sb), PEvalFPTerm fp) =>+  FPTrait ->+  Term (fp eb sb) ->+  Term Bool+fpTraitTerm trait = unsafeInCurThread1 (curThreadFpTraitTerm trait)+{-# NOINLINE fpTraitTerm #-}++-- | Construct and internalizing a 'FdivTerm'.+fdivTerm :: (PEvalFractionalTerm a) => Term a -> Term a -> Term a+fdivTerm = unsafeInCurThread2 curThreadFdivTerm+{-# NOINLINE fdivTerm #-}++-- | Construct and internalizing a 'RecipTerm'.+recipTerm :: (PEvalFractionalTerm a) => Term a -> Term a+recipTerm = unsafeInCurThread1 curThreadRecipTerm+{-# NOINLINE recipTerm #-}++-- | Construct and internalizing a 'FloatingUnaryTerm'.+floatingUnaryTerm :: (PEvalFloatingTerm a) => FloatingUnaryOp -> Term a -> Term a+floatingUnaryTerm op = unsafeInCurThread1 (curThreadFloatingUnaryTerm op)+{-# NOINLINE floatingUnaryTerm #-}++-- | Construct and internalizing a 'PowerTerm'.+powerTerm :: (PEvalFloatingTerm a) => Term a -> Term a -> Term a+powerTerm = unsafeInCurThread2 curThreadPowerTerm+{-# NOINLINE powerTerm #-}++-- | Construct and internalizing a 'FPUnaryTerm'.+fpUnaryTerm ::+  (ValidFP eb sb, SupportedPrim (fp eb sb), PEvalFPTerm fp) =>+  FPUnaryOp ->+  Term (fp eb sb) ->+  Term (fp eb sb)+fpUnaryTerm op = unsafeInCurThread1 (curThreadFpUnaryTerm op)+{-# NOINLINE fpUnaryTerm #-}++-- | Construct and internalizing a 'FPBinaryTerm'.+fpBinaryTerm ::+  (ValidFP eb sb, SupportedPrim (fp eb sb), PEvalFPTerm fp) =>+  FPBinaryOp ->+  Term (fp eb sb) ->+  Term (fp eb sb) ->+  Term (fp eb sb)+fpBinaryTerm op = unsafeInCurThread2 (curThreadFpBinaryTerm op)+{-# NOINLINE fpBinaryTerm #-}++-- | Construct and internalizing a 'FPRoundingUnaryTerm'.+fpRoundingUnaryTerm ::+  (ValidFP eb sb, SupportedPrim (fp eb sb), PEvalFPTerm fp) =>+  FPRoundingUnaryOp ->+  Term FPRoundingMode ->+  Term (fp eb sb) ->+  Term (fp eb sb)+fpRoundingUnaryTerm op = unsafeInCurThread2 (curThreadFpRoundingUnaryTerm op)+{-# NOINLINE fpRoundingUnaryTerm #-}++-- | Construct and internalizing a 'FPRoundingBinaryTerm'.+fpRoundingBinaryTerm ::+  (ValidFP eb sb, SupportedPrim (fp eb sb), PEvalFPTerm fp) =>+  FPRoundingBinaryOp ->+  Term FPRoundingMode ->+  Term (fp eb sb) ->+  Term (fp eb sb) ->+  Term (fp eb sb)+fpRoundingBinaryTerm op = unsafeInCurThread3 (curThreadFpRoundingBinaryTerm op)+{-# NOINLINE fpRoundingBinaryTerm #-}++-- | Construct and internalizing a 'FPFMATerm'.+fpFMATerm ::+  (ValidFP eb sb, SupportedPrim (fp eb sb), PEvalFPTerm fp) =>+  Term FPRoundingMode ->+  Term (fp eb sb) ->+  Term (fp eb sb) ->+  Term (fp eb sb) ->+  Term (fp eb sb)+fpFMATerm mode a b c = unsafePerformIO $ do+  tid <- myWeakThreadId+  mode' <- toCurThreadImpl tid mode+  a' <- toCurThreadImpl tid a+  b' <- toCurThreadImpl tid b+  c' <- toCurThreadImpl tid c+  curThreadFpFMATerm mode' a' b' c'+{-# NOINLINE fpFMATerm #-}++-- | Construct and internalizing a 'FromIntegralTerm'.+fromIntegralTerm ::+  (PEvalFromIntegralTerm a b, SupportedPrim b) => Term a -> Term b+fromIntegralTerm = unsafeInCurThread1 curThreadFromIntegralTerm+{-# NOINLINE fromIntegralTerm #-}++-- | Construct and internalizing a 'FromFPOrTerm'.+fromFPOrTerm ::+  ( PEvalIEEEFPConvertibleTerm a,+    ValidFP eb sb+  ) =>+  Term a ->+  Term FPRoundingMode ->+  Term (FP eb sb) ->+  Term a+fromFPOrTerm = unsafeInCurThread3 curThreadFromFPOrTerm+{-# NOINLINE fromFPOrTerm #-}++-- | Construct and internalizing a 'ToFPTerm'.+toFPTerm ::+  forall a eb sb.+  ( PEvalIEEEFPConvertibleTerm a,+    ValidFP eb sb,+    SupportedPrim (FP eb sb)+  ) =>+  Term FPRoundingMode ->+  Term a ->+  Term (FP eb sb)+toFPTerm = unsafeInCurThread2 curThreadToFPTerm+{-# NOINLINE toFPTerm #-}++-- Support for boolean type+defaultValueForBool :: Bool+defaultValueForBool = False++-- | Construct and internalizing 'True' term.+trueTerm :: Term Bool+trueTerm = conTerm True+{-# NOINLINE trueTerm #-}++-- | Construct and internalizing 'False' term.+falseTerm :: Term Bool+falseTerm = conTerm False+{-# NOINLINE falseTerm #-}++boolConTermView :: forall a. Term a -> Maybe Bool+boolConTermView (ConTerm b) = cast b+boolConTermView _ = Nothing+{-# INLINE boolConTermView #-}++-- | Pattern matcher for concrete 'Bool' terms.+pattern BoolConTerm :: Bool -> Term a+pattern BoolConTerm b <- (boolConTermView -> Just b)++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE BoolConTerm #-}+#endif++-- | Pattern matcher for 'True' term.+pattern TrueTerm :: Term a+pattern TrueTerm <- BoolConTerm True++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE TrueTerm #-}+#endif++-- | Pattern matcher for 'False' term.+pattern FalseTerm :: Term a+pattern FalseTerm <- BoolConTerm False++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE FalseTerm #-}+#endif++boolTermView :: forall a. Term a -> Maybe (Term Bool)+boolTermView t@SupportedTerm = cast t+{-# INLINE boolTermView #-}++-- | Pattern matcher for 'Bool' terms.+pattern BoolTerm :: Term Bool -> Term a+pattern BoolTerm b <- (boolTermView -> Just b)++#if MIN_VERSION_base(4, 16, 4)+{-# INLINE BoolTerm #-}+#endif++-- | Partial evaluation for not terms.+pevalNotTerm :: Term Bool -> Term Bool+pevalNotTerm (NotTerm tm) = tm+pevalNotTerm (ConTerm a) = if a then falseTerm else trueTerm+pevalNotTerm (OrTerm (NotTerm n1) n2) = pevalAndTerm n1 (pevalNotTerm n2)+pevalNotTerm (OrTerm (DistinctTerm (n1 :| [n2])) n3) =+  pevalAndTerm (pevalEqTerm n1 n2) (pevalNotTerm n3)+pevalNotTerm (OrTerm n1 (NotTerm n2)) = pevalAndTerm (pevalNotTerm n1) n2+pevalNotTerm (OrTerm n1 (DistinctTerm (n2 :| [n3]))) =+  pevalAndTerm (pevalNotTerm n1) (pevalEqTerm n2 n3)+pevalNotTerm (AndTerm (NotTerm n1) n2) = pevalOrTerm n1 (pevalNotTerm n2)+pevalNotTerm (AndTerm (DistinctTerm (n1 :| [n2])) n3) =+  pevalOrTerm (pevalEqTerm n1 n2) (pevalNotTerm n3)+pevalNotTerm (AndTerm n1 (NotTerm n2)) = pevalOrTerm (pevalNotTerm n1) n2+pevalNotTerm (AndTerm n1 (DistinctTerm (n2 :| [n3]))) =+  pevalOrTerm (pevalNotTerm n1) (pevalEqTerm n2 n3)+pevalNotTerm+  (EqTerm a (DynTerm (ConTerm b :: Term (WordN 1))))+    | b == 0 = eqTerm (unsafeCoerce a) (conTerm 1 :: Term (WordN 1))+    | b == 1 = eqTerm (unsafeCoerce a) (conTerm 0 :: Term (WordN 1))+pevalNotTerm+  (EqTerm a (DynTerm (ConTerm b :: Term (IntN 1))))+    | b == 0 = eqTerm (unsafeCoerce a) (conTerm 1 :: Term (IntN 1))+    | b == 1 = eqTerm (unsafeCoerce a) (conTerm 0 :: Term (IntN 1))+-- pevalNotTerm (EqTerm a b) = distinctTerm $ a :| [b]+pevalNotTerm (DistinctTerm (a :| [b])) = eqTerm a b+pevalNotTerm tm = notTerm tm+{-# INLINEABLE pevalNotTerm #-}++orEqFirst' :: Term Bool -> Term Bool -> Bool+orEqFirst'+  (DistinctTerm ((e1 :: Term a) :| [ec1@ConTerm {} :: Term b]))+  (EqTerm (DynTerm (e2 :: Term a)) (DynTerm (ec2@ConTerm {} :: Term b)))+    | e1 == e2 && ec1 /= ec2 = True+orEqFirst'+  (NotTerm (EqTerm (e1 :: Term a) (ec1@ConTerm {} :: Term b)))+  (EqTerm (DynTerm (e2 :: Term a)) (DynTerm (ec2@ConTerm {} :: Term b)))+    | e1 == e2 && ec1 /= ec2 = True+orEqFirst' _ _ = False+{-# INLINE orEqFirst' #-}++orEqFirst :: Term Bool -> Term Bool -> Bool+orEqFirst _ (ConTerm False) = True+orEqFirst x y+  | x == y = True+  | otherwise = orEqFirst' x y+{-# INLINE orEqFirst #-}++orEqTrue' :: Term Bool -> Term Bool -> Bool+orEqTrue'+  (DistinctTerm ((e1 :: Term a) :| [ec1@ConTerm {} :: Term b]))+  (DistinctTerm ((DynTerm (e2 :: Term a)) :| [DynTerm (ec2@ConTerm {} :: Term b)]))+    | e1 == e2 && ec1 /= ec2 = True+orEqTrue'+  (NotTerm (EqTerm (e1 :: Term a) (ec1@ConTerm {} :: Term b)))+  (NotTerm (EqTerm (DynTerm (e2 :: Term a)) (DynTerm (ec2@ConTerm {} :: Term b))))+    | e1 == e2 && ec1 /= ec2 = True+orEqTrue' _ _ = False+{-# INLINE orEqTrue' #-}++orEqTrue :: Term Bool -> Term Bool -> Bool+orEqTrue (ConTerm True) ~_ = True+orEqTrue _ (ConTerm True) = True+orEqTrue (NotTerm l) r | l == r = True+orEqTrue l (NotTerm r) | l == r = True+orEqTrue l r = orEqTrue' l r+{-# INLINE orEqTrue #-}++-- | Partial evaluation for or terms.+pevalOrTerm :: Term Bool -> Term Bool -> Term Bool+pevalOrTerm (ConTerm True) ~_ = trueTerm+pevalOrTerm _ (ConTerm True) = trueTerm+pevalOrTerm (ConTerm False) y = y+pevalOrTerm x (ConTerm False) = x+pevalOrTerm (NotTerm x) y | x == y = trueTerm+pevalOrTerm x (NotTerm y) | x == y = trueTerm+pevalOrTerm x y | x == y = x+pevalOrTerm l ~r+  | orEqTrue' l r = trueTerm+  | orEqFirst' l r = l+  | orEqFirst' r l = r+pevalOrTerm l r@(OrTermAll r1 r2 s)+  | HS.member l s = r+  | HS.member (simpleNot l) s = trueTerm+  | orEqTrue' l r1 = trueTerm+  | orEqTrue' l r2 = trueTerm+  | orEqFirst' r1 l = r+  | orEqFirst' r2 l = r+  | orEqFirst' l r1 = pevalOrTerm l r2+  | orEqFirst' l r2 = pevalOrTerm l r1+pevalOrTerm l@(OrTermAll l1 l2 s) r+  | HS.member r s = l+  | HS.member (simpleNot r) s = trueTerm+  | orEqTrue' l1 r = trueTerm+  | orEqTrue' l2 r = trueTerm+  | orEqFirst' l1 r = l+  | orEqFirst' l2 r = l+  | orEqFirst' r l1 = pevalOrTerm l2 r+  | orEqFirst' r l2 = pevalOrTerm l1 r+pevalOrTerm (AndTerm l1 l2) (AndTerm r1 r2)+  | l1 == r1 = pevalAndTerm l1 (pevalOrTerm l2 r2)+  | l1 == r2 = pevalAndTerm l1 (pevalOrTerm l2 r1)+  | l2 == r1 = pevalAndTerm l2 (pevalOrTerm l1 r2)+  | l2 == r2 = pevalAndTerm l2 (pevalOrTerm l1 r1)+pevalOrTerm l (AndTermAll r1 r2 s)+  | HS.member l s = l+  | orEqFirst l r1 = l+  | orEqFirst l r2 = l+  | orEqTrue l r1 = pevalOrTerm l r2+  | orEqTrue l r2 = pevalOrTerm l r1+pevalOrTerm (AndTermAll l1 l2 s) r+  | HS.member r s = r+  | orEqFirst r l1 = r+  | orEqFirst r l2 = r+  | orEqTrue l1 r = pevalOrTerm l2 r+  | orEqTrue l2 r = pevalOrTerm l1 r+pevalOrTerm+  (AndTerm nl1@(NotTerm l1) l2)+  (EqTerm (DynTerm (e1 :: Term Bool)) (DynTerm (e2 :: Term Bool)))+    | l1 == e1 && l2 == e2 = pevalOrTerm nl1 l2+pevalOrTerm (NotTerm nl) (NotTerm nr) =+  pevalNotTerm $ pevalAndTerm nl nr+pevalOrTerm (AndTermAll _ _ sa) r@(OrTermAll _ _ so)+  | sa `HS.intersection` so /= HS.empty = r+pevalOrTerm l@(OrTermAll _ _ so) (AndTermAll _ _ sa)+  | sa `HS.intersection` so /= HS.empty = l+pevalOrTerm+  (EqTerm a (BVTerm bt@(ConTerm (b :: bv n))))+  (EqTerm c (DynTerm (BVTerm (ConTerm d) :: Term (bv n))))+    | natVal (Proxy @n) == 1 && b == -1 && d == -1 =+        pevalEqTerm+          ( pevalOrBitsTerm+              (unsafeCoerce a :: Term (bv n))+              (unsafeCoerce c :: Term (bv n))+          )+          bt+pevalOrTerm+  (EqTerm a (BVTerm bt@(ConTerm (b :: bv n))))+  (EqTerm c (DynTerm (BVTerm (ConTerm d) :: Term (bv n))))+    | natVal (Proxy @n) == 1 && b == 0 && d == 0 =+        pevalEqTerm+          ( pevalAndBitsTerm+              (unsafeCoerce a :: Term (bv n))+              (unsafeCoerce c :: Term (bv n))+          )+          bt+pevalOrTerm l r = orTerm l r+{-# INLINEABLE pevalOrTerm #-}++andEqFalse' :: Term Bool -> Term Bool -> Bool+andEqFalse'+  (EqTerm (e1 :: Term a) (ec1@ConTerm {} :: Term b))+  (EqTerm (DynTerm (e2 :: Term a)) (DynTerm (ec2@ConTerm {} :: Term b)))+    | e1 == e2 && ec1 /= ec2 = True+andEqFalse' _ _ = False+{-# INLINE andEqFalse' #-}++andEqFalse :: Term Bool -> Term Bool -> Bool+andEqFalse (NotTerm x) y | x == y = True+andEqFalse x (NotTerm y) | x == y = True+andEqFalse l r = andEqFalse' l r+{-# INLINE andEqFalse #-}++andEqFirst' :: Term Bool -> Term Bool -> Bool+andEqFirst'+  (EqTerm (e1 :: Term a) (ec1@ConTerm {} :: Term b))+  (DistinctTerm ((DynTerm (e2 :: Term a)) :| [DynTerm (ec2@ConTerm {} :: Term b)]))+    | e1 == e2 && ec1 /= ec2 = True+andEqFirst'+  (EqTerm (e1 :: Term a) (ec1@ConTerm {} :: Term b))+  (NotTerm (EqTerm (DynTerm (e2 :: Term a)) (DynTerm (ec2@ConTerm {} :: Term b))))+    | e1 == e2 && ec1 /= ec2 = True+andEqFirst' _ _ = False+{-# INLINE andEqFirst' #-}++andEqFirst :: Term Bool -> Term Bool -> Bool+andEqFirst _ (ConTerm True) = True+andEqFirst x y+  | x == y = True+  | otherwise = andEqFirst' x y+{-# INLINE andEqFirst #-}++simpleNot :: Term Bool -> Term Bool+simpleNot (NotTerm n) = n+simpleNot n = notTerm n+{-# INLINEABLE simpleNot #-}++-- | Partial evaluation for and terms.+pevalAndTerm :: Term Bool -> Term Bool -> Term Bool+pevalAndTerm (ConTerm False) ~_ = falseTerm+pevalAndTerm _ (ConTerm False) = falseTerm+pevalAndTerm (ConTerm True) y = y+pevalAndTerm x (ConTerm True) = x+pevalAndTerm (NotTerm x) y | x == y = falseTerm+pevalAndTerm x (NotTerm y) | x == y = falseTerm+pevalAndTerm x y | x == y = x+pevalAndTerm l ~r+  | andEqFalse' l r = falseTerm+  | andEqFirst' l r = l+  | andEqFirst' r l = r+pevalAndTerm l r@(AndTermAll r1 r2 s)+  | HS.member l s = r+  | HS.member (simpleNot l) s = falseTerm+  | andEqFalse' l r1 = falseTerm+  | andEqFalse' l r2 = falseTerm+  | andEqFirst' r1 l = r+  | andEqFirst' r2 l = r+  | andEqFirst' l r1 = pevalAndTerm l r2+  | andEqFirst' l r2 = pevalAndTerm l r1+pevalAndTerm l@(AndTermAll l1 l2 s) r+  | HS.member r s = l+  | HS.member (simpleNot r) s = falseTerm+  | andEqFalse' l1 r = falseTerm+  | andEqFalse' l2 r = falseTerm+  | andEqFirst' l1 r = l+  | andEqFirst' l2 r = l+  | andEqFirst' r l1 = pevalAndTerm l2 r+  | andEqFirst' r l2 = pevalAndTerm l1 r+pevalAndTerm (OrTerm l1 l2) (OrTerm r1 r2)+  | l1 == r1 = pevalOrTerm l1 (pevalAndTerm l2 r2)+  | l1 == r2 = pevalOrTerm l1 (pevalAndTerm l2 r1)+  | l2 == r1 = pevalOrTerm l2 (pevalAndTerm l1 r2)+  | l2 == r2 = pevalOrTerm l2 (pevalAndTerm l1 r1)+pevalAndTerm l (OrTermAll r1 r2 s)+  | HS.member l s = l+  | andEqFirst l r1 = l+  | andEqFirst l r2 = l+  | andEqFalse l r1 = pevalAndTerm l r2+  | andEqFalse l r2 = pevalAndTerm l r1+pevalAndTerm (OrTermAll l1 l2 s) r+  | HS.member r s = r+  | andEqFirst r l1 = r+  | andEqFirst r l2 = r+  | andEqFalse l1 r = pevalAndTerm l2 r+  | andEqFalse l2 r = pevalAndTerm l1 r+pevalAndTerm+  (OrTerm l1 nl2@(NotTerm l2))+  (NotTerm (EqTerm (DynTerm (e1 :: Term Bool)) (DynTerm (e2 :: Term Bool))))+    | l1 == e1 && l2 == e2 = pevalAndTerm l1 nl2+pevalAndTerm (NotTerm nl) (NotTerm nr) = pevalNotTerm $ pevalOrTerm nl nr+pevalAndTerm (OrTermAll _ _ so) r@(AndTermAll _ _ sa)+  | sa `HS.intersection` so /= HS.empty = r+pevalAndTerm l@(AndTermAll _ _ sa) (OrTermAll _ _ so)+  | sa `HS.intersection` so /= HS.empty = l+pevalAndTerm+  (EqTerm a (BVTerm bt@(ConTerm (b :: bv n))))+  (EqTerm c (DynTerm (BVTerm (ConTerm d) :: Term (bv n))))+    | natVal (Proxy @n) == 1 && b == 0 && d == 0 =+        pevalEqTerm+          ( pevalOrBitsTerm+              (unsafeCoerce a :: Term (bv n))+              (unsafeCoerce c :: Term (bv n))+          )+          bt+pevalAndTerm+  (EqTerm a (BVTerm bt@(ConTerm (b :: bv n))))+  (EqTerm c (DynTerm (BVTerm (ConTerm d) :: Term (bv n))))+    | natVal (Proxy @n) == 1 && b == -1 && d == -1 =+        pevalEqTerm+          ( pevalAndBitsTerm+              (unsafeCoerce a :: Term (bv n))+              (unsafeCoerce c :: Term (bv n))+          )+          bt+pevalAndTerm l r = andTerm l r+{-# INLINEABLE pevalAndTerm #-}++data BVTermView where+  BVTermView ::+    forall bv n.+    ( KnownNat n,+      1 <= n,+      PEvalBitwiseTerm (bv n),+      Eq (bv n),+      Num (bv n)+    ) =>+    Term (bv n) -> BVTermView++bvTermViewPattern ::+  forall a.+  (SupportedPrim a) =>+  Term a ->+  Maybe BVTermView+bvTermViewPattern b = case R.typeRep @a of+  R.App i _ -> case ( R.eqTypeRep i (R.typeRep @IntN),+                      R.eqTypeRep i (R.typeRep @WordN)+                    ) of+    (Just R.HRefl, _) -> withPrim @a $ Just (BVTermView b)+    (_, Just R.HRefl) -> withPrim @a $ Just (BVTermView b)+    _ -> Nothing+  _ -> Nothing++pattern BVTerm ::+  forall a.+  (SupportedPrim a) =>+  forall bv n.+  (KnownNat n, 1 <= n, PEvalBitwiseTerm (bv n), Eq (bv n), Num (bv n)) =>+  Term (bv n) -> Term a+pattern BVTerm x <- (bvTermViewPattern -> Just (BVTermView x))++-- | Partial evaluation for imply terms.+pevalImplyTerm :: Term Bool -> Term Bool -> Term Bool+pevalImplyTerm l r | termImplies l r = trueTerm+pevalImplyTerm l r = pevalOrTerm (pevalNotTerm l) r++-- | Partial evaluation for xor terms.+pevalXorTerm :: Term Bool -> Term Bool -> Term Bool+pevalXorTerm l r = pevalOrTerm (pevalAndTerm (pevalNotTerm l) r) (pevalAndTerm l (pevalNotTerm r))++termImplies :: Term Bool -> Term Bool -> Bool+termImplies (ConTerm False) _ = True+termImplies _ (ConTerm True) = True+termImplies+  (EqTerm (e1 :: Term a) (ec1@ConTerm {} :: Term b))+  (DistinctTerm ((DynTerm (e2 :: Term a)) :| [(DynTerm (ec2@ConTerm {} :: Term b))]))+    | e1 == e2 && ec1 /= ec2 = True+termImplies+  (EqTerm (e1 :: Term a) (ec1@ConTerm {} :: Term b))+  (NotTerm (EqTerm (DynTerm (e2 :: Term a)) ((DynTerm (ec2@ConTerm {} :: Term b)))))+    | e1 == e2 && ec1 /= ec2 = True+termImplies a (OrTermAll _ _ s) | HS.member a s = True+termImplies (AndTermAll _ _ s) b | HS.member b s = True+termImplies (AndTermAll _ _ s) (OrTermAll _ _ s2) | HS.intersection s s2 /= HS.empty = True+termImplies (AndTermAll _ _ s) (AndTermAll _ _ s2) | s2 `HS.isSubsetOf` s = True+termImplies (OrTermAll _ _ s) (OrTermAll _ _ s2) | s `HS.isSubsetOf` s2 = True+termImplies a b+  | a == b = True+  | otherwise = False+{-# INLINE termImplies #-}++pevalITEBoolLeftNot :: Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool)+pevalITEBoolLeftNot cond nIfTrue ifFalse+  -- need test+  | cond == nIfTrue = Just $ pevalAndTerm (pevalNotTerm cond) ifFalse+  | otherwise = case nIfTrue of+      AndTerm nt1 nt2 -> ra+        where+          ra+            | termImplies cond nt1 =+                Just $ pevalITETerm cond (pevalNotTerm nt2) ifFalse+            | termImplies cond nt2 =+                Just $ pevalITETerm cond (pevalNotTerm nt1) ifFalse+            | termImplies cond (pevalNotTerm nt1)+                || termImplies cond (pevalNotTerm nt2) =+                Just $ pevalOrTerm cond ifFalse+            | otherwise = Nothing+      OrTerm nt1 nt2 -> ra+        where+          ra+            | termImplies cond nt1 || termImplies cond nt2 =+                Just $ pevalAndTerm (pevalNotTerm cond) ifFalse+            | termImplies cond (pevalNotTerm nt1) =+                Just $ pevalITETerm cond (pevalNotTerm nt2) ifFalse+            | termImplies cond (pevalNotTerm nt2) =+                Just $ pevalITETerm cond (pevalNotTerm nt1) ifFalse+            | otherwise = Nothing+      _ -> Nothing++pevalITEBoolBothNot :: Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool)+pevalITEBoolBothNot cond nIfTrue nIfFalse =+  Just $ pevalNotTerm $ pevalITETerm cond nIfTrue nIfFalse++pevalITEBoolRightNot :: Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool)+pevalITEBoolRightNot cond ifTrue nIfFalse+  -- need test+  | cond == nIfFalse = Just $ pevalOrTerm (pevalNotTerm cond) ifTrue+  | otherwise = Nothing -- need work++pevalInferImplies :: Term Bool -> Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool)+pevalInferImplies+  (EqTerm (e1 :: Term a) (ec1@ConTerm {} :: Term b))+  (NotTerm (EqTerm (DynTerm (e2 :: Term a)) (DynTerm (ec2@ConTerm {} :: Term b))))+  trueRes+  _+    | e1 == e2 && ec1 /= ec2 = Just trueRes+pevalInferImplies cond (NotTerm nt1) _ falseRes+  | cond == nt1 = Just falseRes+  | otherwise = Nothing+-- \| otherwise = case (cond, nt1) of+--     ( EqTerm _ (e1 :: Term a) (ec1@(ConTerm _ _ _ _) :: Term b),+--       EqTerm _ (Dyn (e2 :: Term a)) (Dyn (ec2@(ConTerm _ _ _ _) :: Term b))+--       )+--         | e1 == e2 && ec1 /= ec2 -> Just trueRes+--     _ -> Nothing+pevalInferImplies+  (EqTerm (e1 :: Term a) (ec1@ConTerm {} :: Term b))+  (DistinctTerm ((DynTerm (e2 :: Term a)) :| [DynTerm (ec2@ConTerm {} :: Term b)]))+  trueRes+  _+    | e1 == e2 && ec1 /= ec2 = Just trueRes+pevalInferImplies+  (EqTerm (e1 :: Term a) (ec1@ConTerm {} :: Term b))+  (EqTerm (DynTerm (e2 :: Term a)) (DynTerm (ec2@ConTerm {} :: Term b)))+  _+  falseRes+    | e1 == e2 && ec1 /= ec2 = Just falseRes+pevalInferImplies _ _ _ _ = Nothing++pevalITEBoolLeftAnd :: Term Bool -> Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool)+pevalITEBoolLeftAnd cond t1 t2 ifFalse+  | t1 == ifFalse = Just $ pevalAndTerm t1 $ pevalImplyTerm cond t2+  | t2 == ifFalse = Just $ pevalAndTerm t2 $ pevalImplyTerm cond t1+  | cond == t1 = Just $ pevalITETerm cond t2 ifFalse+  | cond == t2 = Just $ pevalITETerm cond t1 ifFalse+  | otherwise =+      msum+        [ pevalInferImplies cond t1 (pevalITETerm cond t2 ifFalse) (pevalAndTerm (pevalNotTerm cond) ifFalse),+          pevalInferImplies cond t2 (pevalITETerm cond t1 ifFalse) (pevalAndTerm (pevalNotTerm cond) ifFalse)+        ]++pevalITEBoolBothAnd :: Term Bool -> Term Bool -> Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool)+pevalITEBoolBothAnd cond t1 t2 f1 f2+  | t1 == f1 = Just $ pevalAndTerm t1 $ pevalITETerm cond t2 f2+  | t1 == f2 = Just $ pevalAndTerm t1 $ pevalITETerm cond t2 f1+  | t2 == f1 = Just $ pevalAndTerm t2 $ pevalITETerm cond t1 f2+  | t2 == f2 = Just $ pevalAndTerm t2 $ pevalITETerm cond t1 f1+  | otherwise = Nothing++pevalITEBoolRightAnd :: Term Bool -> Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool)+pevalITEBoolRightAnd cond ifTrue f1 f2+  | f1 == ifTrue = Just $ pevalAndTerm f1 $ pevalOrTerm cond f2+  | f2 == ifTrue = Just $ pevalAndTerm f2 $ pevalOrTerm cond f1+  | otherwise = Nothing++pevalITEBoolLeftOr :: Term Bool -> Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool)+pevalITEBoolLeftOr cond t1 t2 ifFalse+  | t1 == ifFalse = Just $ pevalOrTerm t1 $ pevalAndTerm cond t2+  | t2 == ifFalse = Just $ pevalOrTerm t2 $ pevalAndTerm cond t1+  | cond == t1 = Just $ pevalOrTerm cond ifFalse+  | cond == t2 = Just $ pevalOrTerm cond ifFalse+  | otherwise =+      msum+        [ pevalInferImplies cond t1 (pevalOrTerm cond ifFalse) (pevalITETerm cond t2 ifFalse),+          pevalInferImplies cond t2 (pevalOrTerm cond ifFalse) (pevalITETerm cond t1 ifFalse)+        ]++pevalITEBoolBothOr :: Term Bool -> Term Bool -> Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool)+pevalITEBoolBothOr cond t1 t2 f1 f2+  | t1 == f1 = Just $ pevalOrTerm t1 $ pevalITETerm cond t2 f2+  | t1 == f2 = Just $ pevalOrTerm t1 $ pevalITETerm cond t2 f1+  | t2 == f1 = Just $ pevalOrTerm t2 $ pevalITETerm cond t1 f2+  | t2 == f2 = Just $ pevalOrTerm t2 $ pevalITETerm cond t1 f1+  | otherwise = Nothing++pevalITEBoolRightOr :: Term Bool -> Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool)+pevalITEBoolRightOr cond ifTrue f1 f2+  | f1 == ifTrue = Just $ pevalOrTerm f1 $ pevalAndTerm (pevalNotTerm cond) f2+  | f2 == ifTrue = Just $ pevalOrTerm f2 $ pevalAndTerm (pevalNotTerm cond) f1+  | otherwise = Nothing++pevalITEBoolLeft :: Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool)+pevalITEBoolLeft cond (AndTerm t1 t2) ifFalse =+  msum+    [ pevalITEBoolLeftAnd cond t1 t2 ifFalse,+      case ifFalse of+        AndTerm f1 f2 -> pevalITEBoolBothAnd cond t1 t2 f1 f2+        _ -> Nothing+    ]+pevalITEBoolLeft cond (OrTerm t1 t2) ifFalse =+  msum+    [ pevalITEBoolLeftOr cond t1 t2 ifFalse,+      case ifFalse of+        OrTerm f1 f2 -> pevalITEBoolBothOr cond t1 t2 f1 f2+        _ -> Nothing+    ]+pevalITEBoolLeft cond (NotTerm nIfTrue) ifFalse =+  msum+    [ pevalITEBoolLeftNot cond nIfTrue ifFalse,+      case ifFalse of+        NotTerm nIfFalse ->+          pevalITEBoolBothNot cond nIfTrue nIfFalse+        _ -> Nothing+    ]+pevalITEBoolLeft _ _ _ = Nothing++pevalITEBoolNoLeft :: Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool)+pevalITEBoolNoLeft cond ifTrue (AndTerm f1 f2) = pevalITEBoolRightAnd cond ifTrue f1 f2+pevalITEBoolNoLeft cond ifTrue (OrTerm f1 f2) = pevalITEBoolRightOr cond ifTrue f1 f2+pevalITEBoolNoLeft cond ifTrue (NotTerm nIfFalse) = pevalITEBoolRightNot cond ifTrue nIfFalse+pevalITEBoolNoLeft _ _ _ = Nothing++-- | Basic partial evaluation for ITE terms.+pevalITEBasic :: (SupportedPrim a) => Term Bool -> Term a -> Term a -> Maybe (Term a)+pevalITEBasic (ConTerm True) ~ifTrue ~_ = Just ifTrue+pevalITEBasic (ConTerm False) ~_ ~ifFalse = Just ifFalse+pevalITEBasic (NotTerm ncond) ifTrue ifFalse = Just $ pevalITETerm ncond ifFalse ifTrue+pevalITEBasic _ ifTrue ifFalse | ifTrue == ifFalse = Just ifTrue+pevalITEBasic (ITETerm cc ct cf) (ITETerm tc tt tf) (ITETerm fc ft ff) -- later+  | cc == tc && cc == fc = Just $ pevalITETerm cc (pevalITETerm ct tt ft) (pevalITETerm cf tf ff)+pevalITEBasic cond (ITETerm tc tt tf) ifFalse -- later+  | tt == ifFalse = Just $ pevalITETerm (pevalOrTerm (pevalNotTerm cond) tc) tt tf+  | tf == ifFalse = Just $ pevalITETerm (pevalAndTerm cond tc) tt tf+  | termImplies cond tc = Just $ pevalITETerm cond tt ifFalse+pevalITEBasic cond (ITETerm (AndTerm c1 c2) tt tf) ifFalse+  | cond == c1 = Just $ pevalITETerm cond (pevalITETerm c2 tt tf) ifFalse+  | cond == c2 = Just $ pevalITETerm cond (pevalITETerm c1 tt tf) ifFalse+pevalITEBasic cond ifTrue (ITETerm fc ft ff) -- later+  | ifTrue == ft = Just $ pevalITETerm (pevalOrTerm cond fc) ifTrue ff+  | ifTrue == ff = Just $ pevalITETerm (pevalOrTerm cond (pevalNotTerm fc)) ifTrue ft+  | termImplies fc cond = Just $ pevalITETerm cond ifTrue ff+pevalITEBasic cond ifTrue (ITETerm (OrTerm c1 c2) ft ff)+  | cond == c1 = Just $ pevalITETerm cond ifTrue (pevalITETerm c2 ft ff)+  | cond == c2 = Just $ pevalITETerm cond ifTrue (pevalITETerm c1 ft ff)+pevalITEBasic _ _ _ = Nothing++pevalITEBoolBasic :: Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool)+pevalITEBoolBasic cond ifTrue ifFalse+  | cond == ifTrue = Just $ pevalOrTerm cond ifFalse+  | cond == ifFalse = Just $ pevalAndTerm cond ifTrue+pevalITEBoolBasic cond (ConTerm v) ifFalse+  | v = Just $ pevalOrTerm cond ifFalse+  | otherwise = Just $ pevalAndTerm (pevalNotTerm cond) ifFalse+pevalITEBoolBasic cond ifTrue (ConTerm v)+  | v = Just $ pevalOrTerm (pevalNotTerm cond) ifTrue+  | otherwise = Just $ pevalAndTerm cond ifTrue+pevalITEBoolBasic _ _ _ = Nothing++pevalITEBool :: Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool)+pevalITEBool cond ~ifTrue ~ifFalse =+  msum+    [ pevalITEBasic cond ifTrue ifFalse,+      pevalITEBoolBasic cond ifTrue ifFalse,+      pevalITEBoolLeft cond ifTrue ifFalse,+      pevalITEBoolNoLeft cond ifTrue ifFalse+    ]++-- | Basic partial evaluation for ITE terms.+pevalITEBasicTerm :: (SupportedPrim a) => Term Bool -> Term a -> Term a -> Term a+pevalITEBasicTerm cond ~ifTrue ~ifFalse =+  fromMaybe (iteTerm cond ifTrue ifFalse) $+    pevalITEBasic cond ifTrue ifFalse++-- | Default partial evaluation for equality terms.+pevalDefaultEqTerm :: (SupportedNonFuncPrim a) => Term a -> Term a -> Term Bool+pevalDefaultEqTerm l@ConTerm {} r@ConTerm {} = conTerm $ l == r+pevalDefaultEqTerm l@ConTerm {} r = pevalDefaultEqTerm r l+pevalDefaultEqTerm l (BoolConTerm rv) =+  if rv+    then unsafeCoerce l+    else pevalNotTerm (unsafeCoerce l)+pevalDefaultEqTerm (NotTerm lv) r+  | lv == r = falseTerm+pevalDefaultEqTerm l (NotTerm rv)+  | l == rv = falseTerm+pevalDefaultEqTerm (AddNumTerm (ConTerm c) v) (ConTerm c2) =+  pevalDefaultEqTerm v (conTerm $ c2 - c)+pevalDefaultEqTerm l (ITETerm c t f)+  | l == t = pevalOrTerm c (pevalDefaultEqTerm l f)+  | l == f = pevalOrTerm (pevalNotTerm c) (pevalDefaultEqTerm l t)+pevalDefaultEqTerm (ITETerm c t f) r+  | t == r = pevalOrTerm c (pevalDefaultEqTerm f r)+  | f == r = pevalOrTerm (pevalNotTerm c) (pevalDefaultEqTerm t r)+pevalDefaultEqTerm l r+  | l == r = trueTerm+  | otherwise = eqTerm l r+{-# INLINEABLE pevalDefaultEqTerm #-}++instance SBVRep Bool where+  type SBVType Bool = SBV.SBV Bool++instance SupportedPrimConstraint Bool++instance SupportedPrim Bool where+  pformatCon True = "true"+  pformatCon False = "false"+  defaultValue = defaultValueForBool+  pevalITETerm cond ~ifTrue ~ifFalse =+    fromMaybe (iteTerm cond ifTrue ifFalse) $+      pevalITEBool cond ifTrue ifFalse+  pevalEqTerm (EqTerm (DynTerm (l1 :: Term Bool)) l2) (EqTerm r1 r2)+    | l1 == unsafeCoerce r1 = pevalEqTerm l2 (unsafeCoerce r2)+    | l1 == unsafeCoerce r2 = pevalEqTerm l2 (unsafeCoerce r1)+    | l2 == unsafeCoerce r1 = pevalEqTerm (unsafeCoerce l1) r2+    | l2 == unsafeCoerce r2 = pevalEqTerm (unsafeCoerce l1) r1+  pevalEqTerm (EqTerm (DynTerm (l1 :: Term (WordN 1))) l2) (EqTerm r1 r2)+    | l1 == unsafeCoerce r1 = pevalEqTerm l2 (unsafeCoerce r2)+    | l1 == unsafeCoerce r2 = pevalEqTerm l2 (unsafeCoerce r1)+    | l2 == unsafeCoerce r1 = pevalEqTerm (unsafeCoerce l1) r2+    | l2 == unsafeCoerce r2 = pevalEqTerm (unsafeCoerce l1) r1+  pevalEqTerm (EqTerm (DynTerm (l1 :: Term (IntN 1))) l2) (EqTerm r1 r2)+    | l1 == unsafeCoerce r1 = pevalEqTerm l2 (unsafeCoerce r2)+    | l1 == unsafeCoerce r2 = pevalEqTerm l2 (unsafeCoerce r1)+    | l2 == unsafeCoerce r1 = pevalEqTerm (unsafeCoerce l1) r2+    | l2 == unsafeCoerce r2 = pevalEqTerm (unsafeCoerce l1) r1+  pevalEqTerm l r = pevalDefaultEqTerm l r+  pevalDistinctTerm (_ :| []) = conTerm True+  pevalDistinctTerm (a :| [b]) = pevalNotTerm $ pevalEqTerm a b+  pevalDistinctTerm _ = conTerm False+  conSBVTerm n = if n then SBV.sTrue else SBV.sFalse+  symSBVName symbol _ = show symbol+  symSBVTerm = sbvFresh+  withPrim r = r+  parseSMTModelResult _ = parseScalarSMTModelResult id+  castTypedSymbol ::+    forall knd knd'.+    (IsSymbolKind knd') =>+    TypedSymbol knd Bool ->+    Maybe (TypedSymbol knd' Bool)+  castTypedSymbol (TypedSymbol s) =+    case decideSymbolKind @knd' of+      Left HRefl -> Just $ TypedSymbol s+      Right HRefl -> Just $ TypedSymbol s+  funcDummyConstraint _ = SBV.sTrue++instance NonFuncSBVRep Bool where+  type NonFuncSBVBaseType Bool = Bool++instance SupportedNonFuncPrim Bool where+  conNonFuncSBVTerm = conSBVTerm+  symNonFuncSBVTerm = symSBVTerm @Bool+  withNonFuncPrim r = r++data PhantomDict a where+  PhantomDict :: (SupportedPrim a) => PhantomDict a++data PhantomNonFuncDict a where+  PhantomNonFuncDict ::+    (SupportedNonFuncPrim a) => PhantomNonFuncDict a++{-# NOINLINE phantomDictCache #-}+phantomDictCache :: IORef (HM.HashMap SomeTypeRep (PhantomDict Any))+phantomDictCache = unsafePerformIO $ newIORef HM.empty++-- TODO+{-# NOINLINE getPhantomDict #-}+getPhantomDict :: forall a. (SupportedPrim a) => PhantomDict a+getPhantomDict = unsafePerformIO $ do+  cache <- readIORef phantomDictCache+  let !tr = SomeTypeRep $ primTypeRep @a+  case HM.lookup tr cache of+    Just p -> return $ unsafeCoerce p+    Nothing -> do+      let r = PhantomDict :: PhantomDict a+      atomicModifyIORefCAS_ phantomDictCache $ HM.insert tr $ unsafeCoerce r+      return r++{-# NOINLINE phantomNonFuncDictCache #-}+phantomNonFuncDictCache ::+  IORef (HM.HashMap SomeTypeRep (PhantomNonFuncDict Any))+phantomNonFuncDictCache = unsafePerformIO $ newIORef HM.empty++-- TODO+{-# NOINLINE getPhantomNonFuncDict #-}+getPhantomNonFuncDict ::+  forall a. (SupportedNonFuncPrim a) => PhantomNonFuncDict a+getPhantomNonFuncDict = unsafePerformIO $ do+  cache <- readIORef phantomNonFuncDictCache+  let !tr = SomeTypeRep $ primTypeRep @a+  case HM.lookup tr cache of+    Just p -> return $ unsafeCoerce p+    Nothing -> do+      let r = PhantomNonFuncDict :: PhantomNonFuncDict a+      atomicModifyIORefCAS_ phantomNonFuncDictCache $+        HM.insert tr $+          unsafeCoerce r+      return r++defaultValueForInteger :: Integer+defaultValueForInteger = 0++-- Basic Integer+instance SBVRep Integer where+  type SBVType Integer = SBV.SBV Integer++instance SupportedPrimConstraint Integer where+  type PrimConstraint Integer = (Integral (NonFuncSBVBaseType Integer))++pairwiseHasConcreteEqual :: (SupportedNonFuncPrim a) => [Term a] -> Bool+pairwiseHasConcreteEqual [] = False+pairwiseHasConcreteEqual [_] = False+pairwiseHasConcreteEqual (x : xs) =+  go x xs || pairwiseHasConcreteEqual xs+  where+    go _ [] = False+    go x (y : ys) = x == y || go x ys++getAllConcrete :: [Term a] -> Maybe [a]+getAllConcrete [] = return []+getAllConcrete (ConTerm x : xs) = (x :) <$> getAllConcrete xs+getAllConcrete _ = Nothing++checkConcreteDistinct :: (Eq t) => [t] -> Bool+checkConcreteDistinct [] = True+checkConcreteDistinct (x : xs) = check0 x xs && checkConcreteDistinct xs+  where+    check0 _ [] = True+    check0 x (y : ys) = x /= y && check0 x ys++pevalGeneralDistinct ::+  (SupportedNonFuncPrim a) => NonEmpty (Term a) -> Term Bool+pevalGeneralDistinct (_ :| []) = conTerm True+pevalGeneralDistinct (a :| [b]) = pevalNotTerm $ pevalEqTerm a b+pevalGeneralDistinct l | pairwiseHasConcreteEqual $ toList l = conTerm False+pevalGeneralDistinct l =+  case getAllConcrete (toList l) of+    Nothing -> distinctTerm l+    Just xs -> conTerm $ checkConcreteDistinct xs++instance SupportedPrim Integer where+  pformatCon = show+  defaultValue = defaultValueForInteger+  pevalITETerm = pevalITEBasicTerm+  pevalEqTerm = pevalDefaultEqTerm+  pevalDistinctTerm = pevalGeneralDistinct+  conSBVTerm n = fromInteger n+  symSBVName symbol _ = show symbol+  symSBVTerm name = sbvFresh name+  parseSMTModelResult _ = parseScalarSMTModelResult id+  castTypedSymbol ::+    forall knd knd'.+    (IsSymbolKind knd') =>+    TypedSymbol knd Integer ->+    Maybe (TypedSymbol knd' Integer)+  castTypedSymbol s =+    case decideSymbolKind @knd' of+      Left HRefl -> Just $ typedConstantSymbol $ unTypedSymbol s+      Right HRefl -> Just $ typedAnySymbol $ unTypedSymbol s+  funcDummyConstraint _ = SBV.sTrue++instance NonFuncSBVRep Integer where+  type NonFuncSBVBaseType Integer = Integer++instance SupportedNonFuncPrim Integer where+  conNonFuncSBVTerm = conSBVTerm+  symNonFuncSBVTerm = symSBVTerm @Integer+  withNonFuncPrim r = r++pevalITEBVTerm ::+  forall bv n.+  ( KnownNat n,+    1 <= n,+    forall m. (KnownNat m, 1 <= m) => SupportedPrim (bv m),+    forall m. (KnownNat m, 1 <= m) => Show (bv m),+    PEvalBVTerm bv+  ) =>+  Term Bool -> Term (bv n) -> Term (bv n) -> Maybe (Term (bv n))+pevalITEBVTerm+  ( EqTerm+      (DynTerm (l :: Term (bv n)))+      (DynTerm (ConTerm (r :: bv n)))+    )+  (ConTerm t)+  (ConTerm f)+    | natVal (Proxy @n) == 1 && r == 1 && t == 0 && f == 1 = Just $ pevalComplementBitsTerm l+    | natVal (Proxy @n) == 1 && r == 1 && t == 1 && f == 0 = Just l+    | natVal (Proxy @n) == 1 && r == 0 && t == 0 && f == 1 = Just l+    | natVal (Proxy @n) == 1 && r == 0 && t == 1 && f == 0 = Just $ pevalComplementBitsTerm l+pevalITEBVTerm+  (EqTerm (DynTerm (l :: Term (bv 1))) (DynTerm (ConTerm (r :: bv 1))))+  (ConTerm t)+  f+    | n > 1 && (t == 0 || t == -1) && (r == -1 || r == 0) =+        Just $+          (if t == 0 then pevalAndBitsTerm else pevalOrBitsTerm)+            ( unsafePevalBVExtendTerm+                (natRepr @1)+                (natRepr @n)+                True+                (if (r == 0) == (t == 0) then l else pevalComplementBitsTerm l)+            )+            f+    where+      n = natVal (Proxy @n)+pevalITEBVTerm+  (EqTerm (DynTerm (_ :: Term (bv 1))) (DynTerm (ConTerm (_ :: bv 1))))+  (ConTerm _)+  (ConTerm _) = Nothing+pevalITEBVTerm+  (EqTerm (DynTerm (l :: Term (bv 1))) (DynTerm (ConTerm (r :: bv 1))))+  t+  f@(ConTerm _) = pevalITEBVTerm (eqTerm l (conTerm $ complement r)) f t+pevalITEBVTerm+  cond+  (BVConcatTerm (a :: Term (bv a)) (b :: Term (bv b)))+  (BVConcatTerm (DynTerm (c :: Term (bv a))) d) =+    Just $+      pevalBVConcatTerm+        (pevalITETerm cond a c)+        (pevalITETerm cond b (unsafeCoerce d))+pevalITEBVTerm+  cond+  (BVExtendTerm True pl (a :: Term (bv a)))+  (BVExtendTerm True _ (DynTerm (b :: Term (bv a)))) =+    Just $+      pevalBVExtendTerm+        True+        pl+        (pevalITETerm cond a b)+pevalITEBVTerm cond (AndBitsTerm a b) (AndBitsTerm c d)+  | a == c = Just $ andBitsTerm a $ pevalITETerm cond b d+  | a == d = Just $ andBitsTerm a $ pevalITETerm cond b c+  | b == c = Just $ andBitsTerm b $ pevalITETerm cond a d+  | b == d = Just $ andBitsTerm b $ pevalITETerm cond a c+pevalITEBVTerm cond (AndBitsTerm a b) c+  | a == c = Just $ andBitsTerm c $ pevalOrBitsTerm (boolToBVTerm $ pevalNotTerm cond) b+  | b == c = Just $ andBitsTerm c $ pevalOrBitsTerm (boolToBVTerm $ pevalNotTerm cond) a+pevalITEBVTerm cond a (AndBitsTerm b c)+  | a == b = Just $ andBitsTerm a $ pevalOrBitsTerm (boolToBVTerm cond) c+  | a == c = Just $ andBitsTerm a $ pevalOrBitsTerm (boolToBVTerm cond) b+pevalITEBVTerm cond (OrBitsTerm a b) (OrBitsTerm c d)+  | a == c = Just $ orBitsTerm a $ pevalITETerm cond b d+  | a == d = Just $ orBitsTerm a $ pevalITETerm cond b c+  | b == c = Just $ orBitsTerm b $ pevalITETerm cond a d+  | b == d = Just $ orBitsTerm b $ pevalITETerm cond a c+pevalITEBVTerm cond (OrBitsTerm a b) c+  | a == c = Just $ orBitsTerm c $ pevalAndBitsTerm (boolToBVTerm cond) b+  | b == c = Just $ orBitsTerm c $ pevalAndBitsTerm (boolToBVTerm cond) a+pevalITEBVTerm cond a (OrBitsTerm b c)+  | a == b = Just $ orBitsTerm a $ pevalAndBitsTerm (boolToBVTerm $ pevalNotTerm cond) c+  | a == c = Just $ orBitsTerm a $ pevalAndBitsTerm (boolToBVTerm $ pevalNotTerm cond) b+pevalITEBVTerm _ _ _ = Nothing++-- | Convert boolean term to a 1-bit bitvector term.+boolToBVTerm ::+  forall bv n.+  ( PEvalBVTerm bv,+    KnownNat n,+    1 <= n,+    forall m. (KnownNat m, 1 <= m) => SupportedPrim (bv m)+  ) =>+  Term Bool -> Term (bv n)+boolToBVTerm cond =+  let bv =+        case cond of+          NotTerm c -> iteTerm c (conTerm 0) (conTerm 1)+          _ -> iteTerm cond (conTerm 1 :: Term (bv 1)) (conTerm 0) :: Term (bv 1)+   in if natVal (Proxy @n) == 1+        then unsafeCoerce bv+        else bvExtendTerm True (natRepr @n) bv++-- Signed BV+instance (KnownNat w, 1 <= w) => SupportedPrimConstraint (IntN w) where+  type PrimConstraint (IntN w) = (KnownNat w, 1 <= w, BVIsNonZero w)++instance (KnownNat w, 1 <= w) => SBVRep (IntN w) where+  type SBVType (IntN w) = SBV.SBV (SBV.IntN w)++instance (KnownNat w, 1 <= w) => SupportedPrim (IntN w) where+  sbvDistinct = withPrim @(IntN w) $ SBV.distinct . toList+  sbvEq = withPrim @(IntN w) (SBV..==)+  pformatCon = show+  defaultValue = 0+  pevalITETerm cond ifTrue ifFalse =+    fromMaybe (iteTerm cond ifTrue ifFalse) $+      msum+        [ pevalITEBasic cond ifTrue ifFalse,+          pevalITEBVTerm cond ifTrue ifFalse+        ]+  pevalEqTerm = pevalDefaultEqTerm+  pevalDistinctTerm = pevalGeneralDistinct+  conSBVTerm n = bvIsNonZeroFromGEq1 (Proxy @w) $ fromIntegral n+  symSBVName symbol _ = show symbol+  symSBVTerm name = bvIsNonZeroFromGEq1 (Proxy @w) $ sbvFresh name+  withPrim r = bvIsNonZeroFromGEq1 (Proxy @w) r+  {-# INLINE withPrim #-}+  parseSMTModelResult _ cv =+    withPrim @(IntN w) $+      parseScalarSMTModelResult (\(x :: SBV.IntN w) -> fromIntegral x) cv+  castTypedSymbol ::+    forall knd knd'.+    (IsSymbolKind knd') =>+    TypedSymbol knd (IntN w) ->+    Maybe (TypedSymbol knd' (IntN w))+  castTypedSymbol s =+    case decideSymbolKind @knd' of+      Left HRefl -> Just $ typedConstantSymbol $ unTypedSymbol s+      Right HRefl -> Just $ typedAnySymbol $ unTypedSymbol s+  funcDummyConstraint _ = SBV.sTrue++-- | Construct the 'SBV.BVIsNonZero' constraint from the proof that the width is+-- at least 1.+bvIsNonZeroFromGEq1 ::+  forall w r proxy.+  (1 <= w) =>+  proxy w ->+  ((SBV.BVIsNonZero w) => r) ->+  r+bvIsNonZeroFromGEq1 _ r1 = case unsafeAxiom :: w :~: 1 of+  Refl -> r1+{-# INLINE bvIsNonZeroFromGEq1 #-}++instance (KnownNat w, 1 <= w) => NonFuncSBVRep (IntN w) where+  type NonFuncSBVBaseType (IntN w) = SBV.IntN w++instance (KnownNat w, 1 <= w) => SupportedNonFuncPrim (IntN w) where+  conNonFuncSBVTerm = conSBVTerm+  symNonFuncSBVTerm = symSBVTerm @(IntN w)+  withNonFuncPrim r = bvIsNonZeroFromGEq1 (Proxy @w) r++-- Unsigned BV+instance (KnownNat w, 1 <= w) => SupportedPrimConstraint (WordN w) where+  type PrimConstraint (WordN w) = (KnownNat w, 1 <= w, BVIsNonZero w)++instance (KnownNat w, 1 <= w) => SBVRep (WordN w) where+  type SBVType (WordN w) = SBV.SBV (SBV.WordN w)++instance (KnownNat w, 1 <= w) => SupportedPrim (WordN w) where+  sbvDistinct = withPrim @(WordN w) $ SBV.distinct . toList+  sbvEq = withPrim @(WordN w) (SBV..==)+  pformatCon = show+  defaultValue = 0+  pevalITETerm cond ifTrue ifFalse =+    fromMaybe (iteTerm cond ifTrue ifFalse) $+      msum+        [ pevalITEBasic cond ifTrue ifFalse,+          pevalITEBVTerm cond ifTrue ifFalse+        ]+  pevalEqTerm = pevalDefaultEqTerm+  pevalDistinctTerm = pevalGeneralDistinct+  conSBVTerm n = bvIsNonZeroFromGEq1 (Proxy @w) $ fromIntegral n+  symSBVName symbol _ = show symbol+  symSBVTerm name = bvIsNonZeroFromGEq1 (Proxy @w) $ sbvFresh name+  withPrim r = bvIsNonZeroFromGEq1 (Proxy @w) r+  {-# INLINE withPrim #-}+  parseSMTModelResult _ cv =+    withPrim @(WordN w) $+      parseScalarSMTModelResult (\(x :: SBV.WordN w) -> fromIntegral x) cv+  castTypedSymbol ::+    forall knd knd'.+    (IsSymbolKind knd') =>+    TypedSymbol knd (WordN w) ->+    Maybe (TypedSymbol knd' (WordN w))+  castTypedSymbol s =+    case decideSymbolKind @knd' of+      Left HRefl -> Just $ typedConstantSymbol $ unTypedSymbol s+      Right HRefl -> Just $ typedAnySymbol $ unTypedSymbol s+  funcDummyConstraint _ = SBV.sTrue++instance (KnownNat w, 1 <= w) => NonFuncSBVRep (WordN w) where+  type NonFuncSBVBaseType (WordN w) = SBV.WordN w++instance (KnownNat w, 1 <= w) => SupportedNonFuncPrim (WordN w) where+  conNonFuncSBVTerm = conSBVTerm+  symNonFuncSBVTerm = symSBVTerm @(WordN w)+  withNonFuncPrim r = bvIsNonZeroFromGEq1 (Proxy @w) r++-- FP+instance (ValidFP eb sb) => SupportedPrimConstraint (FP eb sb) where+  type PrimConstraint (FP eb sb) = ValidFP eb sb++instance (ValidFP eb sb) => SBVRep (FP eb sb) where+  type SBVType (FP eb sb) = SBV.SBV (SBV.FloatingPoint eb sb)++instance (ValidFP eb sb) => SupportedPrim (FP eb sb) where+  sameCon a b+    | isNaN a = isNaN b+    | fpIsPositiveZero a = fpIsPositiveZero b+    | fpIsNegativeZero a = fpIsNegativeZero b+    | otherwise = a == b+  hashConWithSalt s a+    | isNaN a = hashWithSalt s (2654435761 :: Int)+    | otherwise = hashWithSalt s a+  defaultValue = 0+  pevalITETerm = pevalITEBasicTerm+  pevalEqTerm (ConTerm l) (ConTerm r) = conTerm $ l == r+  pevalEqTerm l@ConTerm {} r = pevalEqTerm r l+  pevalEqTerm l r = eqTerm l r+  pevalDistinctTerm (_ :| []) = conTerm True+  pevalDistinctTerm (a :| [b]) = pevalNotTerm $ pevalEqTerm a b+  pevalDistinctTerm l =+    case getAllConcrete (toList l) of+      Nothing -> distinctTerm l+      Just xs | any isNaN xs -> distinctTerm l+      Just xs -> conTerm $ checkConcreteDistinct xs+  conSBVTerm (FP fp) = SBV.literal fp+  symSBVName symbol _ = show symbol+  symSBVTerm name = sbvFresh name+  parseSMTModelResult _ cv =+    withPrim @(FP eb sb) $+      parseScalarSMTModelResult (\(x :: SBV.FloatingPoint eb sb) -> coerce x) cv+  funcDummyConstraint _ = SBV.sTrue++  -- Workaround for sbv#702.+  sbvIte = withPrim @(FP eb sb) $ \c a b ->+    case (SBV.unliteral a, SBV.unliteral b) of+      (Just a', Just b')+        | isInfinite a' && isInfinite b' ->+            let correspondingZero x = if x > 0 then 0 else -0+             in 1+                  / sbvIte @(FP eb sb)+                    c+                    (conSBVTerm @(FP eb sb) $ correspondingZero a')+                    (conSBVTerm @(FP eb sb) $ correspondingZero b')+      _ -> SBV.ite c a b+  castTypedSymbol ::+    forall knd knd'.+    (IsSymbolKind knd') =>+    TypedSymbol knd (FP eb sb) ->+    Maybe (TypedSymbol knd' (FP eb sb))+  castTypedSymbol s =+    case decideSymbolKind @knd' of+      Left HRefl -> Just $ typedConstantSymbol $ unTypedSymbol s+      Right HRefl -> Just $ typedAnySymbol $ unTypedSymbol s++instance (ValidFP eb sb) => NonFuncSBVRep (FP eb sb) where+  type NonFuncSBVBaseType (FP eb sb) = SBV.FloatingPoint eb sb++instance (ValidFP eb sb) => SupportedNonFuncPrim (FP eb sb) where+  conNonFuncSBVTerm = conSBVTerm+  symNonFuncSBVTerm = symSBVTerm @(FP eb sb)+  withNonFuncPrim r = r++-- FPRoundingMode+instance SupportedPrimConstraint FPRoundingMode++instance SBVRep FPRoundingMode where+  type SBVType FPRoundingMode = SBV.SBV SBV.RoundingMode++instance SupportedPrim FPRoundingMode where+  defaultValue = RNE+  pevalITETerm = pevalITEBasicTerm+  pevalEqTerm (ConTerm l) (ConTerm r) = conTerm $ l == r+  pevalEqTerm l@ConTerm {} r = pevalEqTerm r l+  pevalEqTerm l r = eqTerm l r+  pevalDistinctTerm = pevalGeneralDistinct+  conSBVTerm RNE = SBV.sRNE+  conSBVTerm RNA = SBV.sRNA+  conSBVTerm RTP = SBV.sRTP+  conSBVTerm RTN = SBV.sRTN+  conSBVTerm RTZ = SBV.sRTZ+  symSBVName symbol _ = show symbol+  symSBVTerm name = sbvFresh name+  parseSMTModelResult _ cv =+    withPrim @(FPRoundingMode) $+      parseScalarSMTModelResult+        ( \(x :: SBV.RoundingMode) -> case x of+            SBV.RoundNearestTiesToEven -> RNE+            SBV.RoundNearestTiesToAway -> RNA+            SBV.RoundTowardPositive -> RTP+            SBV.RoundTowardNegative -> RTN+            SBV.RoundTowardZero -> RTZ+        )+        cv+  castTypedSymbol ::+    forall knd knd'.+    (IsSymbolKind knd') =>+    TypedSymbol knd FPRoundingMode ->+    Maybe (TypedSymbol knd' FPRoundingMode)+  castTypedSymbol s =+    case decideSymbolKind @knd' of+      Left HRefl -> Just $ typedConstantSymbol $ unTypedSymbol s+      Right HRefl -> Just $ typedAnySymbol $ unTypedSymbol s+  funcDummyConstraint _ = SBV.sTrue++instance NonFuncSBVRep FPRoundingMode where+  type NonFuncSBVBaseType FPRoundingMode = SBV.RoundingMode++instance SupportedNonFuncPrim FPRoundingMode where+  conNonFuncSBVTerm = conSBVTerm+  symNonFuncSBVTerm = symSBVTerm @FPRoundingMode+  withNonFuncPrim r = r++-- AlgReal++instance SupportedPrimConstraint AlgReal++instance SBVRep AlgReal where+  type SBVType AlgReal = SBV.SBV SBV.AlgReal++instance SupportedPrim AlgReal where+  defaultValue = 0+  pevalITETerm = pevalITEBasicTerm+  pevalEqTerm (ConTerm l) (ConTerm r) = conTerm $ l == r+  pevalEqTerm l@ConTerm {} r = pevalEqTerm r l+  pevalEqTerm l r = eqTerm l r+  pevalDistinctTerm = pevalGeneralDistinct+  conSBVTerm = SBV.literal . toSBVAlgReal+  symSBVName symbol _ = show symbol+  symSBVTerm name = sbvFresh name+  parseSMTModelResult _ cv =+    withPrim @AlgReal $+      parseScalarSMTModelResult fromSBVAlgReal cv+  castTypedSymbol ::+    forall knd knd'.+    (IsSymbolKind knd') =>+    TypedSymbol knd AlgReal ->+    Maybe (TypedSymbol knd' AlgReal)+  castTypedSymbol s =+    case decideSymbolKind @knd' of+      Left HRefl -> Just $ typedConstantSymbol $ unTypedSymbol s+      Right HRefl -> Just $ typedAnySymbol $ unTypedSymbol s+  funcDummyConstraint _ = SBV.sTrue++instance NonFuncSBVRep AlgReal where+  type NonFuncSBVBaseType AlgReal = SBV.AlgReal++instance SupportedNonFuncPrim AlgReal where+  conNonFuncSBVTerm = conSBVTerm+  symNonFuncSBVTerm = symSBVTerm @AlgReal+  withNonFuncPrim r = r++-- Bitwise++bitOpOnConcat ::+  forall bv m.+  ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n),+    PEvalBVTerm bv,+    KnownNat m,+    1 <= m+  ) =>+  ( forall n.+    (KnownNat n, 1 <= n) =>+    Term (bv n) -> Term (bv n) -> Term (bv n)+  ) ->+  Term (bv m) ->+  Term (bv m) ->+  Maybe (Term (bv m))+bitOpOnConcat+  peval+  (BVConcatTerm (l0 :: Term (bv l)) (r0 :: Term (bv r)))+  (BVConcatTerm (DynTerm (l :: Term (bv l))) (DynTerm (r :: Term (bv r)))) =+    let r' = peval r0 r+        l' = peval l0 l+     in Just $ pevalBVConcatTerm l' r'+bitOpOnConcat+  peval+  at@(ConTerm _)+  (BVConcatTerm (l :: Term (bv l)) (r :: Term (bv r))) =+    let nzero = natRepr @0+        nr = natRepr @r+        nl = natRepr @l+        nlpr = natRepr @(l + r)+        ar =+          unsafePevalBVSelectTerm+            nlpr+            nzero+            nr+            (unsafeCoerce at :: Term (bv (l + r)))+        al =+          unsafePevalBVSelectTerm+            nlpr+            nr+            nl+            (unsafeCoerce at :: Term (bv (l + r)))+        r' = peval ar r+        l' = peval al l+     in Just $ pevalBVConcatTerm l' r'+bitOpOnConcat+  peval+  (BVExtendTerm True pl (l :: Term (bv n)))+  (BVExtendTerm True _ (DynTerm (r :: Term (bv n)))) =+    Just $ pevalBVExtendTerm True pl (peval l r)+bitOpOnConcat _ _ _ = Nothing++doPevalAndBitsTerm ::+  forall bv m.+  ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n),+    PEvalBVTerm bv,+    KnownNat m,+    1 <= m+  ) =>+  Term (bv m) ->+  Term (bv m) ->+  Maybe (Term (bv m))+doPevalAndBitsTerm (ConTerm a) (ConTerm b) =+  Just $ conTerm (a .&. b)+doPevalAndBitsTerm (ConTerm a) b+  | a == zeroBits = Just $ conTerm zeroBits+  | a == complement zeroBits = Just b+  | aok || acok =+      case ( mkPositiveNatRepr $ fromIntegral leadingBits,+             mkPositiveNatRepr $ fromIntegral trailingBits+           ) of+        ( SomePositiveNatRepr (pleadingBits :: NatRepr leadingBits),+          SomePositiveNatRepr (ptrailingBitsRepr :: NatRepr trailingBits)+          ) ->+            case ( unsafeAxiom @(leadingBits + trailingBits) @m,+                   unsafeAxiom @(trailingBits + leadingBits) @m,+                   unsafeLeqProof @trailingBits @m+                 ) of+              (Refl, Refl, LeqProof) ->+                if aok+                  then+                    Just $+                      pevalBVConcatTerm (conTerm 0 :: Term (bv leadingBits)) $+                        pevalBVSelectTerm (natRepr @0) ptrailingBitsRepr b+                  else+                    Just $+                      pevalBVConcatTerm+                        (pevalBVSelectTerm ptrailingBitsRepr pleadingBits b)+                        (conTerm 0 :: Term (bv trailingBits))+  where+    leadingBits = if aok then countLeadingZeros a else countLeadingZeros ac+    trailingBits = fromIntegral (natVal @m a) - leadingBits+    ac = complement a+    aok = a .&. (a + 1) == 0+    acok = ac .&. (ac + 1) == 0+doPevalAndBitsTerm a b@(ConTerm _) = doPevalAndBitsTerm b a+doPevalAndBitsTerm a b | a == b = Just a+doPevalAndBitsTerm (ITETerm cond a@(ConTerm av) b@(ConTerm bv)) c+  | av `elem` [0, -1] || bv `elem` [0, -1] =+      Just $ pevalITETerm cond (pevalAndBitsTerm a c) (pevalAndBitsTerm b c)+doPevalAndBitsTerm a (ITETerm cond b@(ConTerm bv) c@(ConTerm cv))+  | bv `elem` [0, -1] || cv `elem` [0, -1] =+      Just $ pevalITETerm cond (pevalAndBitsTerm a b) (pevalAndBitsTerm a c)+doPevalAndBitsTerm (ITETerm cond a@(ConTerm v) b) c+  | v == 0 = Just $ pevalITETerm cond a (pevalAndBitsTerm b c)+doPevalAndBitsTerm (ITETerm cond a b@(ConTerm v)) c+  | v == 0 = Just $ pevalITETerm cond (pevalAndBitsTerm a c) b+doPevalAndBitsTerm a (ITETerm cond b@(ConTerm v) c)+  | v == 0 = Just $ pevalITETerm cond b (pevalAndBitsTerm a c)+doPevalAndBitsTerm a (ITETerm cond b c@(ConTerm v))+  | v == 0 = Just $ pevalITETerm cond (pevalAndBitsTerm a b) c+doPevalAndBitsTerm (BVExtendTerm True pl (ITETerm cond at@(ConTerm a) bt@(ConTerm b))) c+  | a `elem` [0, -1] && b `elem` [0, -1] =+      Just $+        pevalITETerm+          cond+          (pevalAndBitsTerm (pevalBVExtendTerm True pl at) c)+          (pevalAndBitsTerm (pevalBVExtendTerm True pl bt) c)+doPevalAndBitsTerm a (BVExtendTerm True pl (ITETerm cond bt@(ConTerm b) ct@(ConTerm c)))+  | b `elem` [0, -1] && c `elem` [0, -1] =+      Just $+        pevalITETerm+          cond+          (pevalAndBitsTerm a (pevalBVExtendTerm True pl bt))+          (pevalAndBitsTerm a (pevalBVExtendTerm True pl ct))+doPevalAndBitsTerm a b = bitOpOnConcat @bv @m pevalDefaultAndBitsTerm a b++pevalDefaultAndBitsTerm ::+  forall bv m.+  ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n),+    PEvalBVTerm bv,+    KnownNat m,+    1 <= m+  ) =>+  Term (bv m) ->+  Term (bv m) ->+  Term (bv m)+pevalDefaultAndBitsTerm = binaryUnfoldOnce doPevalAndBitsTerm andBitsTerm++doPevalOrBitsTerm ::+  forall bv m.+  ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n),+    PEvalBVTerm bv,+    KnownNat m,+    1 <= m+  ) =>+  Term (bv m) ->+  Term (bv m) ->+  Maybe (Term (bv m))+doPevalOrBitsTerm (ConTerm a) (ConTerm b) = Just $ conTerm (a .|. b)+doPevalOrBitsTerm (ConTerm a) b+  | a == zeroBits = Just b+  | a == complement zeroBits = Just $ conTerm $ complement zeroBits+  | aok || acok =+      case ( mkPositiveNatRepr $ fromIntegral leadingBits,+             mkPositiveNatRepr $ fromIntegral trailingBits+           ) of+        ( SomePositiveNatRepr (pleadingBits :: NatRepr leadingBits),+          SomePositiveNatRepr (ptrailingBitsRepr :: NatRepr trailingBits)+          ) ->+            case ( unsafeAxiom @(leadingBits + trailingBits) @m,+                   unsafeAxiom @(trailingBits + leadingBits) @m,+                   unsafeLeqProof @trailingBits @m+                 ) of+              (Refl, Refl, LeqProof) ->+                if acok+                  then+                    Just $+                      pevalBVConcatTerm (conTerm $ -1 :: Term (bv leadingBits)) $+                        pevalBVSelectTerm (natRepr @0) ptrailingBitsRepr b+                  else+                    Just $+                      pevalBVConcatTerm+                        (pevalBVSelectTerm ptrailingBitsRepr pleadingBits b)+                        (conTerm $ -1 :: Term (bv trailingBits))+  where+    leadingBits = if aok then countLeadingZeros a else countLeadingZeros ac+    trailingBits = fromIntegral (natVal @m a) - leadingBits+    ac = complement a+    aok = a .&. (a + 1) == 0+    acok = ac .&. (ac + 1) == 0+doPevalOrBitsTerm a b@(ConTerm _) = doPevalOrBitsTerm b a+doPevalOrBitsTerm a b | a == b = Just a+doPevalOrBitsTerm (ITETerm cond a@(ConTerm _) b@(ConTerm _)) c =+  Just $ pevalITETerm cond (pevalOrBitsTerm a c) (pevalOrBitsTerm b c)+doPevalOrBitsTerm a (ITETerm cond b@(ConTerm _) c@(ConTerm _)) =+  Just $ pevalITETerm cond (pevalOrBitsTerm a b) (pevalOrBitsTerm a c)+doPevalOrBitsTerm (ITETerm cond a@(ConTerm v) b) c+  | v == -1 = Just $ pevalITETerm cond a (pevalOrBitsTerm b c)+doPevalOrBitsTerm (ITETerm cond a b@(ConTerm v)) c+  | v == -1 = Just $ pevalITETerm cond (pevalOrBitsTerm a c) b+doPevalOrBitsTerm a (ITETerm cond b@(ConTerm v) c)+  | v == -1 = Just $ pevalITETerm cond b (pevalOrBitsTerm a c)+doPevalOrBitsTerm a (ITETerm cond b c@(ConTerm v))+  | v == -1 = Just $ pevalITETerm cond (pevalOrBitsTerm a b) c+doPevalOrBitsTerm (BVExtendTerm True pl (ITETerm cond at@(ConTerm a) bt@(ConTerm b))) c+  | a `elem` [0, -1] && b `elem` [0, -1] =+      Just $+        pevalITETerm+          cond+          (pevalOrBitsTerm (pevalBVExtendTerm True pl at) c)+          (pevalOrBitsTerm (pevalBVExtendTerm True pl bt) c)+doPevalOrBitsTerm a (BVExtendTerm True pl (ITETerm cond bt@(ConTerm b) ct@(ConTerm c)))+  | b `elem` [0, -1] && c `elem` [0, -1] =+      Just $+        pevalITETerm+          cond+          (pevalOrBitsTerm a (pevalBVExtendTerm True pl bt))+          (pevalOrBitsTerm a (pevalBVExtendTerm True pl ct))+doPevalOrBitsTerm a b = bitOpOnConcat @bv @m pevalDefaultOrBitsTerm a b++pevalDefaultOrBitsTerm ::+  forall bv m.+  ( KnownNat m,+    1 <= m,+    forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n),+    PEvalBVTerm bv+  ) =>+  Term (bv m) -> Term (bv m) -> Term (bv m)+pevalDefaultOrBitsTerm = binaryUnfoldOnce doPevalOrBitsTerm orBitsTerm++pevalDefaultXorBitsTerm ::+  forall bv m.+  ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n),+    PEvalBVTerm bv,+    KnownNat m,+    1 <= m+  ) =>+  Term (bv m) -> Term (bv m) -> Term (bv m)+pevalDefaultXorBitsTerm = binaryUnfoldOnce doPevalXorBitsTerm xorBitsTerm+  where+    doPevalXorBitsTerm (ConTerm a) (ConTerm b) =+      Just $ conTerm (a `xor` b)+    doPevalXorBitsTerm (ConTerm a) b+      | a == zeroBits = Just b+      | a == complement zeroBits = Just $ pevalComplementBitsTerm b+    doPevalXorBitsTerm a b@(ConTerm _) = doPevalXorBitsTerm b a+    doPevalXorBitsTerm a b | a == b = Just $ conTerm zeroBits+    doPevalXorBitsTerm (ComplementBitsTerm i) (ComplementBitsTerm j) =+      Just $ pevalXorBitsTerm i j+    doPevalXorBitsTerm (ComplementBitsTerm i) j =+      Just $ pevalComplementBitsTerm $ pevalXorBitsTerm i j+    doPevalXorBitsTerm i (ComplementBitsTerm j) =+      Just $ pevalComplementBitsTerm $ pevalXorBitsTerm i j+    doPevalXorBitsTerm a b = bitOpOnConcat @bv @m pevalDefaultXorBitsTerm a b++pevalDefaultComplementBitsTerm ::+  (Bits a, SupportedPrim a, PEvalBitwiseTerm a) => Term a -> Term a+pevalDefaultComplementBitsTerm =+  unaryUnfoldOnce doPevalComplementBitsTerm complementBitsTerm+  where+    doPevalComplementBitsTerm (ConTerm a) = Just $ conTerm $ complement a+    doPevalComplementBitsTerm (ComplementBitsTerm a) = Just a+    doPevalComplementBitsTerm (BVConcatTerm l r) =+      Just $+        pevalBVConcatTerm+          (pevalComplementBitsTerm l)+          (pevalComplementBitsTerm r)+    doPevalComplementBitsTerm (BVExtendTerm True pr t) =+      Just $ pevalBVExtendTerm True pr $ pevalComplementBitsTerm t+    doPevalComplementBitsTerm _ = Nothing++instance (KnownNat n, 1 <= n) => PEvalBitwiseTerm (WordN n) where+  pevalAndBitsTerm = pevalDefaultAndBitsTerm+  pevalOrBitsTerm = pevalDefaultOrBitsTerm+  pevalXorBitsTerm = pevalDefaultXorBitsTerm+  pevalComplementBitsTerm = pevalDefaultComplementBitsTerm+  withSbvBitwiseTermConstraint r = withPrim @(WordN n) r++instance (KnownNat n, 1 <= n) => PEvalBitwiseTerm (IntN n) where+  pevalAndBitsTerm = pevalDefaultAndBitsTerm+  pevalOrBitsTerm = pevalDefaultOrBitsTerm+  pevalXorBitsTerm = pevalDefaultXorBitsTerm+  pevalComplementBitsTerm = pevalDefaultComplementBitsTerm+  withSbvBitwiseTermConstraint r = withPrim @(IntN n) r++-- BVTerm++pevalDefaultBVSelectTerm ::+  forall (bv2 :: Nat -> Type) bv n ix w p q.+  ( KnownNat n,+    KnownNat ix,+    KnownNat w,+    1 <= n,+    1 <= w,+    ix + w <= n,+    PEvalBVTerm bv,+    forall x. (KnownNat x, 1 <= x) => PEvalBitCastTerm (bv2 x) (bv x),+    PEvalBVTerm bv2,+    Typeable bv,+    SupportedPrim (bv w),+    SupportedPrim (bv2 n)+  ) =>+  p ix ->+  q w ->+  Term (bv n) ->+  Term (bv w)+pevalDefaultBVSelectTerm ix w =+  unaryUnfoldOnce (doPevalDefaultBVSelectTerm @bv2 ix w) (bvSelectTerm ix w)++-- | Unsafe version of `pevalBVSelectTerm`. Use `NatRepr` for the bit-width+-- representations.+unsafePevalBVSelectTerm ::+  forall bv n ix w.+  (PEvalBVTerm bv) =>+  NatRepr n ->+  NatRepr ix ->+  NatRepr w ->+  Term (bv n) ->+  Term (bv w)+unsafePevalBVSelectTerm n ix w term =+  withKnownNat n $+    withKnownNat ix $+      withKnownNat w $+        case ( unsafeLeqProof @1 @n,+               unsafeLeqProof @1 @w,+               unsafeLeqProof @(ix + w) @n+             ) of+          (LeqProof, LeqProof, LeqProof) -> pevalBVSelectTerm ix w term++doPevalDefaultBVSelectTerm ::+  forall (bv2 :: Nat -> Type) bv n ix w p q.+  ( KnownNat n,+    KnownNat ix,+    KnownNat w,+    forall x. (KnownNat x, 1 <= x) => PEvalBitCastTerm (bv2 x) (bv x),+    1 <= n,+    1 <= w,+    ix + w <= n,+    PEvalBVTerm bv,+    PEvalBVTerm bv2,+    Typeable bv,+    SupportedPrim (bv w),+    SupportedPrim (bv2 n)+  ) =>+  p ix ->+  q w ->+  Term (bv n) ->+  Maybe (Term (bv w))+doPevalDefaultBVSelectTerm _ _ rhs+  | isJust (sameNat (Proxy @ix) (Proxy @0))+      && isJust (sameNat (Proxy @w) (Proxy @n)) =+      Just rhs >>= castTerm+doPevalDefaultBVSelectTerm ix w (ConTerm b) =+  Just $ conTerm $ sizedBVSelect ix w b+doPevalDefaultBVSelectTerm ix w (BitCastTerm (DynTerm (b :: Term (bv2 n)))) =+  Just $ pevalBitCastTerm $ pevalBVSelectTerm ix w b+doPevalDefaultBVSelectTerm ix w (AddNumTerm t1 t2)+  | natVal @ix ix == 0 =+      Just $+        AddNumTerm+          (pevalDefaultBVSelectTerm @bv2 @bv ix w t1)+          (pevalDefaultBVSelectTerm @bv2 @bv ix w t2)+doPevalDefaultBVSelectTerm ix w (MulNumTerm t1 t2)+  | natVal @ix ix == 0 =+      Just $+        MulNumTerm+          (pevalDefaultBVSelectTerm @bv2 @bv ix w t1)+          (pevalDefaultBVSelectTerm @bv2 @bv ix w t2)+doPevalDefaultBVSelectTerm ix w (AndBitsTerm t1 t2) =+  Just $+    AndBitsTerm+      (pevalDefaultBVSelectTerm @bv2 @bv ix w t1)+      (pevalDefaultBVSelectTerm @bv2 @bv ix w t2)+doPevalDefaultBVSelectTerm ix w (OrBitsTerm t1 t2) =+  Just $+    OrBitsTerm+      (pevalDefaultBVSelectTerm @bv2 @bv ix w t1)+      (pevalDefaultBVSelectTerm @bv2 @bv ix w t2)+doPevalDefaultBVSelectTerm ix w (XorBitsTerm t1 t2) =+  Just $+    XorBitsTerm+      (pevalDefaultBVSelectTerm @bv2 @bv ix w t1)+      (pevalDefaultBVSelectTerm @bv2 @bv ix w t2)+doPevalDefaultBVSelectTerm+  pix+  pw+  (BVConcatTerm (b1 :: Term (bv n1)) (b2 :: Term (bv n2)))+    | ix + w <= n2 = Just $ unsafePevalBVSelectTerm n2Repr ixRepr wRepr b2+    | ix >= n2 =+        case mkNatRepr (ix - n2) of+          SomeNatRepr ixpn2Repr ->+            Just $ unsafePevalBVSelectTerm n1Repr ixpn2Repr wRepr b1+    | otherwise =+        case (mkNatRepr (w + ix - n2), mkNatRepr (n2 - ix)) of+          (SomeNatRepr wixpn2Repr, SomeNatRepr n2pixRepr) ->+            let b1Part =+                  unsafePevalBVSelectTerm n1Repr (natRepr @0) wixpn2Repr b1+                b2Part = unsafePevalBVSelectTerm n2Repr ixRepr n2pixRepr b2+             in Just $+                  unsafePevalBVConcatTerm+                    wixpn2Repr+                    n2pixRepr+                    wRepr+                    b1Part+                    b2Part+    where+      ixRepr = natRepr @ix+      wRepr = natRepr @w+      n1Repr = natRepr @n1+      n2Repr = natRepr @n2+      ix = natVal @ix pix+      w = natVal @w pw+      n2 = natVal @n2 (Proxy @n2)+doPevalDefaultBVSelectTerm+  _+  _+  (BVSelectTerm (_ :: proxy ix1) _ (b :: Term (bv n1))) =+    Just $+      unsafePevalBVSelectTerm+        (natRepr @n1)+        (addNat (natRepr @ix) (natRepr @ix1))+        (natRepr @w)+        b+doPevalDefaultBVSelectTerm+  pix+  pw+  (BVExtendTerm signed _ (b :: Term (bv n1)))+    | ix + w <= n1 = Just $ unsafePevalBVSelectTerm n1Repr ixRepr wRepr b+    | ix < n1 =+        case mkNatRepr (n1 - ix) of+          SomeNatRepr n1pixRepr ->+            let bPart = unsafePevalBVSelectTerm n1Repr ixRepr n1pixRepr b+             in Just $ unsafePevalBVExtendTerm n1pixRepr wRepr signed bPart+    | otherwise = Nothing+    where+      ixRepr = natRepr @ix+      wRepr = natRepr @w+      n1Repr = natRepr @n1+      ix = natVal @ix pix+      w = natVal @w pw+      n1 = natVal @n1 (Proxy @n1)+doPevalDefaultBVSelectTerm _ _ _ = Nothing++pevalDefaultBVExtendTerm ::+  forall proxy l r bv.+  ( PEvalBVTerm bv,+    KnownNat l,+    KnownNat r,+    1 <= l,+    1 <= r,+    l <= r,+    Typeable bv,+    forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n)+  ) =>+  Bool ->+  proxy r ->+  Term (bv l) ->+  Term (bv r)+pevalDefaultBVExtendTerm signed p =+  unaryUnfoldOnce (doPevalDefaultBVExtendTerm signed p) (bvExtendTerm signed p)++-- | Unsafe version of `pevalBVExtendTerm`. Use `NatRepr` for the bit-width+-- representations.+unsafePevalBVExtendTerm ::+  forall bv l r.+  (PEvalBVTerm bv) =>+  NatRepr l ->+  NatRepr r ->+  Bool ->+  Term (bv l) ->+  Term (bv r)+unsafePevalBVExtendTerm lRepr rRepr signed v =+  case (unsafeLeqProof @1 @l, unsafeLeqProof @1 @r, unsafeLeqProof @l @r) of+    (LeqProof, LeqProof, LeqProof) ->+      withKnownNat lRepr $+        withKnownNat rRepr $+          pevalBVExtendTerm signed (Proxy @r) v++doPevalDefaultBVExtendTerm ::+  forall proxy l r bv.+  ( PEvalBVTerm bv,+    KnownNat l,+    KnownNat r,+    1 <= l,+    1 <= r,+    l <= r,+    Typeable bv,+    forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n)+  ) =>+  Bool ->+  proxy r ->+  Term (bv l) ->+  Maybe (Term (bv r))+doPevalDefaultBVExtendTerm signed p (ConTerm b) =+  Just $ conTerm $ if signed then sizedBVSext p b else sizedBVZext p b+doPevalDefaultBVExtendTerm _ _ b+  | isJust $ sameNat (Proxy @l) (Proxy @r) =+      Just b >>= castTerm+doPevalDefaultBVExtendTerm False pr b =+  case (mkPositiveNatRepr $ r - l) of+    SomePositiveNatRepr (rplRepr :: NatRepr lpr) ->+      Just $+        unsafePevalBVConcatTerm+          rplRepr+          lRepr+          rRepr+          (conTerm $ sizedBVFromIntegral 0)+          b+  where+    lRepr = natRepr @l+    rRepr = natRepr @r+    l = natVal @l (Proxy @l)+    r = natVal @r pr+doPevalDefaultBVExtendTerm True p (BVExtendTerm True _ (b :: Term (bv l1))) =+  case unsafeLeqProof @l1 @r of+    LeqProof -> Just $ pevalBVExtendTerm True p b+doPevalDefaultBVExtendTerm _ _ _ = Nothing++pevalDefaultBVConcatTerm ::+  forall bv a b.+  ( KnownNat a,+    KnownNat b,+    1 <= a,+    1 <= b,+    PEvalBVTerm bv,+    forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n)+  ) =>+  Term (bv a) ->+  Term (bv b) ->+  Term (bv (a + b))+pevalDefaultBVConcatTerm =+  withKnownNat (addNat (natRepr @a) (natRepr @b)) $+    case (unsafeLeqProof @1 @(a + b)) of+      LeqProof ->+        binaryUnfoldOnce doPevalDefaultBVConcatTerm bvConcatTerm++unsafeBVConcatTerm ::+  forall bv n1 n2 r.+  (PEvalBVTerm bv, forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n)) =>+  NatRepr n1 ->+  NatRepr n2 ->+  NatRepr r ->+  Term (bv n1) ->+  Term (bv n2) ->+  Term (bv r)+unsafeBVConcatTerm n1Repr n2Repr rRepr lhs rhs =+  case ( unsafeAxiom :: (n1 + n2) :~: r,+         unsafeLeqProof @1 @r,+         unsafeLeqProof @1 @n1,+         unsafeLeqProof @1 @n2+       ) of+    (Refl, LeqProof, LeqProof, LeqProof) ->+      withKnownNat n1Repr $+        withKnownNat n2Repr $+          withKnownNat rRepr $+            bvConcatTerm lhs rhs++-- | Unsafe version of `pevalBVConcatTerm`. Use `NatRepr` for the bit-width+-- representations.+unsafePevalBVConcatTerm ::+  forall bv n1 n2 r.+  (PEvalBVTerm bv) =>+  NatRepr n1 ->+  NatRepr n2 ->+  NatRepr r ->+  Term (bv n1) ->+  Term (bv n2) ->+  Term (bv r)+unsafePevalBVConcatTerm n1Repr n2Repr rRepr lhs rhs =+  case ( unsafeAxiom :: (n1 + n2) :~: r,+         unsafeLeqProof @1 @r,+         unsafeLeqProof @1 @n1,+         unsafeLeqProof @1 @n2+       ) of+    (Refl, LeqProof, LeqProof, LeqProof) ->+      withKnownNat n1Repr $+        withKnownNat n2Repr $+          withKnownNat rRepr $+            pevalBVConcatTerm lhs rhs++doPevalDefaultBVConcatTerm ::+  forall bv l r.+  ( KnownNat l,+    KnownNat r,+    KnownNat (l + r),+    1 <= l,+    1 <= r,+    1 <= (l + r),+    PEvalBVTerm bv,+    forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n)+  ) =>+  Term (bv l) ->+  Term (bv r) ->+  Maybe (Term (bv (l + r)))+-- 1. [c1 c2] -> c1c2+doPevalDefaultBVConcatTerm (ConTerm v) (ConTerm v') =+  withKnownNat (addNat (natRepr @l) (natRepr @r)) $+    Just $+      conTerm $+        sizedBVConcat v v'+-- 2. [c1 (c2 ?)] -> (c1c2 ?)+doPevalDefaultBVConcatTerm+  (ConTerm vl)+  (BVConcatTerm (ConTerm (vrl :: bv rl)) (rr :: Term (bv rr))) =+    case unsafeLeqProof @1 @(l + rl) of+      LeqProof ->+        Just $+          withKnownNat lRlRepr $+            unsafeBVConcatTerm+              lRlRepr+              (natRepr @rr)+              (addNat (natRepr @l) (natRepr @r))+              (conTerm $ sizedBVConcat vl vrl)+              rr+    where+      lRlRepr = addNat (natRepr @l) (natRepr @rl)+-- 3. [c1 (s c2)] -> (c1 (s c2))+doPevalDefaultBVConcatTerm (ConTerm {}) (BVConcatTerm _ ConTerm {}) = Nothing+-- 4. [(c s) ?) -> (c [s ?])+doPevalDefaultBVConcatTerm+  (BVConcatTerm (ll@ConTerm {} :: Term (bv ll)) (lr :: Term (bv lr)))+  r =+    Just $ unsafeBVConcatTerm llRepr lrRRepr lRRepr ll rhs+    where+      llRepr = natRepr @ll+      lrRepr = natRepr @lr+      lRepr = natRepr @l+      rRepr = natRepr @r+      lrRRepr = addNat lrRepr rRepr+      lRRepr = addNat lRepr rRepr+      rhs :: Term (bv (lr + r))+      rhs = unsafePevalBVConcatTerm lrRepr rRepr lrRRepr lr r+-- 5. [? (c1 (s2 c2))] -> (([? c1] s2) c2)+doPevalDefaultBVConcatTerm+  l+  ( BVConcatTerm+      (rl@ConTerm {} :: Term (bv rl))+      (BVConcatTerm (rrl :: Term (bv rrl)) (rrr@ConTerm {} :: Term (bv rrr)))+    ) =+    Just $ unsafeBVConcatTerm lRlRrlRepr rrrRepr lRRepr lRlRrl rrr+    where+      lRepr = natRepr @l+      rlRepr = natRepr @rl+      rrlRepr = natRepr @rrl+      rrrRepr = natRepr @rrr+      lRlRepr = addNat lRepr rlRepr+      rRepr = natRepr @r+      lRRepr = addNat lRepr rRepr+      lRl = unsafePevalBVConcatTerm lRepr rlRepr lRlRepr l rl+      lRlRrlRepr = addNat lRlRepr rrlRepr+      lRlRrl = unsafeBVConcatTerm lRlRepr rrlRepr lRlRrlRepr lRl rrl+-- 6. [(s1 c1) c2] -> (s1 c1c2)+doPevalDefaultBVConcatTerm+  (BVConcatTerm (ll :: Term (bv ll)) ((ConTerm vlr) :: Term (bv lr)))+  (ConTerm vr) =+    Just $ unsafeBVConcatTerm llRepr lrRRepr lRRepr ll rhs+    where+      llRepr = natRepr @ll+      lrRepr = natRepr @lr+      lRepr = natRepr @l+      rRepr = natRepr @r+      lrRRepr = addNat lrRepr rRepr+      lRRepr = addNat lRepr rRepr+      rhs :: Term (bv (lr + r))+      rhs = case unsafeLeqProof @1 @(lr + r) of+        LeqProof ->+          withKnownNat lrRRepr $ conTerm $ sizedBVConcat vlr vr+-- 7. [(s1 c1) (c2 s2)] -> (s1 (c1c2 s2))+doPevalDefaultBVConcatTerm+  (BVConcatTerm (ll :: Term (bv ll)) ((ConTerm vlr) :: Term (bv lr)))+  (BVConcatTerm ((ConTerm vrl) :: Term (bv rl)) (rr :: Term (bv rr))) =+    Just $ unsafeBVConcatTerm llRepr lrRlRrRepr lRRepr ll lrRlRR+    where+      lRepr = natRepr @l+      rRepr = natRepr @r+      llRepr = natRepr @ll+      lrRepr = natRepr @lr+      rlRepr = natRepr @rl+      rrRepr = natRepr @rr+      lRRepr = addNat lRepr rRepr+      lrRlRepr :: NatRepr (lr + rl)+      lrRlRepr = addNat lrRepr rlRepr+      lrRlRrRepr :: NatRepr ((lr + rl) + rr)+      lrRlRrRepr = addNat lrRlRepr rrRepr+      lrRl :: Term (bv (lr + rl))+      lrRl = case unsafeLeqProof @1 @(lr + rl) of+        LeqProof -> withKnownNat lrRlRepr $ conTerm $ sizedBVConcat vlr vrl+      lrRlRR :: Term (bv ((lr + rl) + rr))+      lrRlRR = unsafeBVConcatTerm lrRlRepr rrRepr lrRlRrRepr lrRl rr+-- 8. [?notc (s2 c)] -> ((s1 s2) c)+doPevalDefaultBVConcatTerm+  l+  (BVConcatTerm (rl :: Term (bv rl)) (rr@ConTerm {} :: Term (bv rr))) =+    Just $+      unsafeBVConcatTerm+        lRlRepr+        (natRepr @rr)+        (addNat (natRepr @l) (natRepr @r))+        lhs+        rr+    where+      lRepr = natRepr @l+      rlRepr = natRepr @rl+      lRlRepr = addNat lRepr rlRepr+      lhs :: Term (bv (l + rl))+      lhs = unsafeBVConcatTerm lRepr rlRepr lRlRepr l rl+doPevalDefaultBVConcatTerm+  (BVSelectTerm ix0 (_ :: p w0) (bv0 :: Term (bv n)))+  (BVSelectTerm (ix1 :: p ix1) (w1 :: p w1) (DynTerm (bv1 :: Term (bv n))))+    | ix1v + w1v == ix0v && bv0 == bv1 =+        Just $ unsafePevalBVSelectTerm nRepr ix1Repr (addNat w0Repr w1Repr) bv0+    where+      nRepr = natRepr @n+      w1v = natVal w1+      ix0v = natVal ix0+      ix1v = natVal ix1+      ix1Repr = natRepr @ix1+      w0Repr = natRepr @w0+      w1Repr = natRepr @w1+doPevalDefaultBVConcatTerm _ _ = Nothing++instance PEvalBVTerm WordN where+  pevalBVSelectTerm = pevalDefaultBVSelectTerm @IntN+  pevalBVConcatTerm = pevalDefaultBVConcatTerm+  pevalBVExtendTerm = pevalDefaultBVExtendTerm+  sbvBVConcatTerm pl pr l r =+    bvIsNonZeroFromGEq1 pl $+      bvIsNonZeroFromGEq1 pr $+        l SBV.# r+  sbvBVSelectTerm (pix :: p0 ix) (pw :: p1 w) (pn :: p2 n) bv =+    bvIsNonZeroFromGEq1 (Proxy @n) $+      bvIsNonZeroFromGEq1 (Proxy @w) $+        sbvDefaultBVSelectTerm pix pw pn bv+  sbvBVExtendTerm (_ :: p0 l) (_ :: p1 r) signed bv =+    withKnownProof+      (unsafeKnownProof @(r - l) (natVal (Proxy @r) - natVal (Proxy @l)))+      $ case (unsafeLeqProof @(l + 1) @r, unsafeLeqProof @1 @(r - l)) of+        (LeqProof, LeqProof) ->+          bvIsNonZeroFromGEq1 (Proxy @r) $+            bvIsNonZeroFromGEq1 (Proxy @l) $+              bvIsNonZeroFromGEq1 (Proxy @(r - l)) $+                if signed then SBV.signExtend bv else SBV.zeroExtend bv++instance PEvalBVTerm IntN where+  pevalBVSelectTerm = pevalDefaultBVSelectTerm @WordN+  pevalBVConcatTerm = pevalDefaultBVConcatTerm+  pevalBVExtendTerm = pevalDefaultBVExtendTerm+  sbvBVConcatTerm (pl :: p l) (pr :: q r) l r =+    bvIsNonZeroFromGEq1 pl $+      bvIsNonZeroFromGEq1 pr $+        withKnownNat (addNat (natRepr @l) (natRepr @r)) $+          case unsafeLeqProof @1 @(l + r) of+            LeqProof ->+              bvIsNonZeroFromGEq1 (Proxy @(l + r)) $+                sbvBitCast @(WordN (l + r)) @(IntN (l + r)) $+                  (sbvBitCast @(IntN l) @(WordN l) l)+                    SBV.# (sbvBitCast @(IntN r) @(WordN r) r)+  sbvBVSelectTerm (pix :: p0 ix) (pw :: p1 w) (pn :: p2 n) bv =+    bvIsNonZeroFromGEq1 (Proxy @n) $+      bvIsNonZeroFromGEq1 (Proxy @w) $+        sbvDefaultBVSelectTerm pix pw pn bv+  sbvBVExtendTerm (_ :: p0 l) (_ :: p1 r) signed bv =+    withKnownProof+      (unsafeKnownProof @(r - l) (natVal (Proxy @r) - natVal (Proxy @l)))+      $ case (unsafeLeqProof @(l + 1) @r, unsafeLeqProof @1 @(r - l)) of+        (LeqProof, LeqProof) ->+          bvIsNonZeroFromGEq1 (Proxy @r) $+            bvIsNonZeroFromGEq1 (Proxy @l) $+              bvIsNonZeroFromGEq1 (Proxy @(r - l)) $+                if signed+                  then SBV.signExtend bv+                  else+                    SBV.sFromIntegral+                      ( SBV.zeroExtend+                          (SBV.sFromIntegral bv :: SBV.SBV (SBV.WordN l)) ::+                          SBV.SBV (SBV.WordN r)+                      )++sbvDefaultBVSelectTerm ::+  ( KnownNat ix,+    KnownNat w,+    KnownNat n,+    1 <= n,+    1 <= w,+    (ix + w) <= n,+    SBV.SymVal (bv n)+  ) =>+  p1 ix ->+  p2 w ->+  p3 n ->+  SBV.SBV (bv n) ->+  SBV.SBV (bv w)+sbvDefaultBVSelectTerm (_ :: p0 ix) (_ :: p1 w) (_ :: p2 n) bv =+  withKnownProof+    ( unsafeKnownProof @(w + ix - 1)+        (natVal (Proxy @w) + natVal (Proxy @ix) - 1)+    )+    $ case ( unsafeAxiom @(w + ix - 1 - ix + 1) @w,+             unsafeLeqProof @(((w + ix) - 1) + 1) @n,+             unsafeLeqProof @ix @(w + ix - 1)+           ) of+      (Refl, LeqProof, LeqProof) ->+        bvIsNonZeroFromGEq1 (Proxy @n) $+          bvIsNonZeroFromGEq1 (Proxy @w) $+            SBV.bvExtract (Proxy @(w + ix - 1)) (Proxy @ix) bv++doPevalBitCastSameType ::+  forall x b. (SupportedPrim b) => Term x -> Maybe (Term b)+doPevalBitCastSameType (BitCastTerm (DynTerm (b :: Term b))) = Just b+doPevalBitCastSameType (BitCastTerm x) = doPevalBitCastSameType x+doPevalBitCastSameType _ = Nothing++-- | Partially evaluate a bitcast term. If no reduction is performed, return+-- Nothing.+doPevalBitCast :: (PEvalBitCastTerm a b, SupportedPrim b) => Term a -> Maybe (Term b)+doPevalBitCast (ConTerm v) = Just $ conTerm $ bitCast v+doPevalBitCast t = doPevalBitCastSameType t++instance (KnownNat n, 1 <= n) => PEvalBitCastTerm (WordN n) (IntN n) where+  pevalBitCastTerm = unaryUnfoldOnce doPevalBitCastBV bitCastTerm+    where+      doPevalBitCastBV :: Term (WordN n) -> Maybe (Term (IntN n))+      doPevalBitCastBV+        (BVConcatTerm (l :: Term (WordN l)) (r :: Term (WordN r))) =+          Just $+            pevalBVConcatTerm+              (pevalBitCastTerm @(WordN l) @(IntN l) l)+              (pevalBitCastTerm @(WordN r) @(IntN r) r)+      doPevalBitCastBV (BVExtendTerm signed pr (b :: Term (WordN l))) =+        Just $+          pevalBVExtendTerm signed pr $+            pevalBitCastTerm @(WordN l) @(IntN l) b+      doPevalBitCastBV v = doPevalBitCast v+  sbvBitCast = bvIsNonZeroFromGEq1 (Proxy @n) SBV.sFromIntegral++instance (KnownNat n, 1 <= n) => PEvalBitCastTerm (IntN n) (WordN n) where+  pevalBitCastTerm = unaryUnfoldOnce doPevalBitCastBV bitCastTerm+    where+      doPevalBitCastBV :: Term (IntN n) -> Maybe (Term (WordN n))+      doPevalBitCastBV+        (BVConcatTerm (l :: Term (IntN l)) (r :: Term (IntN r))) =+          Just $+            pevalBVConcatTerm+              (pevalBitCastTerm @(IntN l) @(WordN l) l)+              (pevalBitCastTerm @(IntN r) @(WordN r) r)+      doPevalBitCastBV (BVExtendTerm signed pr (b :: Term (IntN l))) =+        Just $+          pevalBVExtendTerm signed pr $+            pevalBitCastTerm @(IntN l) @(WordN l) b+      doPevalBitCastBV v = doPevalBitCast v+  sbvBitCast = bvIsNonZeroFromGEq1 (Proxy @n) SBV.sFromIntegral++-- Num++-- | Default partial evaluation of addition of numerical terms.+pevalDefaultAddNumTerm :: (PEvalNumTerm a, Eq a) => Term a -> Term a -> Term a+pevalDefaultAddNumTerm l@SupportedTerm r =+  binaryUnfoldOnce+    doPevalDefaultAddNumTerm+    (\a b -> normalizeAddNum $ addNumTerm a b)+    l+    r++doPevalDefaultAddNumTerm ::+  (PEvalNumTerm a, Eq a) => Term a -> Term a -> Maybe (Term a)+doPevalDefaultAddNumTerm (ConTerm a) (ConTerm b) = Just $ conTerm $ a + b+doPevalDefaultAddNumTerm l@(ConTerm a) b = case (a, b) of+  (0, k) -> Just k+  (l1, AddNumTerm (ConTerm j) k) ->+    Just $ pevalAddNumTerm (conTerm $ l1 + j) k+  _ -> doPevalDefaultAddNumTermNoCon l b+doPevalDefaultAddNumTerm a r@(ConTerm {}) = doPevalDefaultAddNumTerm r a+doPevalDefaultAddNumTerm l r = doPevalDefaultAddNumTermNoCon l r++doPevalDefaultAddNumTermNoCon ::+  (PEvalNumTerm a) => Term a -> Term a -> Maybe (Term a)+doPevalDefaultAddNumTermNoCon (AddNumTerm i@ConTerm {} j) k =+  Just $ pevalAddNumTerm i $ pevalAddNumTerm j k+doPevalDefaultAddNumTermNoCon i (AddNumTerm j@ConTerm {} k) =+  Just $ pevalAddNumTerm j $ pevalAddNumTerm i k+doPevalDefaultAddNumTermNoCon (NegNumTerm i) (NegNumTerm j) =+  Just $ pevalNegNumTerm $ pevalAddNumTerm i j+doPevalDefaultAddNumTermNoCon+  (MulNumTerm (ConTerm i) j)+  (MulNumTerm (ConTerm k) l)+    | j == l = Just $ pevalMulNumTerm (conTerm $ i + k) j+doPevalDefaultAddNumTermNoCon+  (MulNumTerm i@ConTerm {} j)+  (MulNumTerm k@(ConTerm {}) l)+    | i == k = Just $ pevalMulNumTerm i (pevalAddNumTerm j l)+doPevalDefaultAddNumTermNoCon _ _ = Nothing++normalizeAddNum :: (PEvalNumTerm a) => Term a -> Term a+normalizeAddNum (AddNumTerm l r@(ConTerm {})) = addNumTerm r l+normalizeAddNum v = v++-- | Default partial evaluation of negation of numerical terms.+pevalDefaultNegNumTerm :: (PEvalNumTerm a, Eq a) => Term a -> Term a+pevalDefaultNegNumTerm l@SupportedTerm =+  unaryUnfoldOnce doPevalDefaultNegNumTerm negNumTerm l++doPevalDefaultNegNumTerm :: (PEvalNumTerm a) => Term a -> Maybe (Term a)+doPevalDefaultNegNumTerm (ConTerm a) = Just $ conTerm $ -a+doPevalDefaultNegNumTerm (NegNumTerm v) = Just v+doPevalDefaultNegNumTerm (AddNumTerm (ConTerm l) r) =+  Just $ pevalSubNumTerm (conTerm $ -l) r+doPevalDefaultNegNumTerm (AddNumTerm (NegNumTerm l) r) =+  Just $ pevalAddNumTerm l (pevalNegNumTerm r)+doPevalDefaultNegNumTerm (AddNumTerm l (NegNumTerm r)) =+  Just $ pevalAddNumTerm (pevalNegNumTerm l) r+doPevalDefaultNegNumTerm (MulNumTerm (ConTerm l) r) =+  Just $ pevalMulNumTerm (conTerm $ -l) r+doPevalDefaultNegNumTerm (MulNumTerm (NegNumTerm {}) _) =+  error "Should not happen"+doPevalDefaultNegNumTerm (MulNumTerm _ (NegNumTerm {})) =+  error "Should not happen"+doPevalDefaultNegNumTerm (AddNumTerm _ ConTerm {}) = error "Should not happen"+doPevalDefaultNegNumTerm _ = Nothing++-- Mul++-- | Default partial evaluation of multiplication of numerical terms.+pevalDefaultMulNumTerm :: (PEvalNumTerm a, Eq a) => Term a -> Term a -> Term a+pevalDefaultMulNumTerm l@SupportedTerm r =+  binaryUnfoldOnce+    doPevalDefaultMulNumTerm+    (\a b -> normalizeMulNum $ mulNumTerm a b)+    l+    r++normalizeMulNum :: (PEvalNumTerm a) => Term a -> Term a+normalizeMulNum (MulNumTerm l r@(ConTerm {})) = mulNumTerm r l+normalizeMulNum v = v++doPevalDefaultMulNumTerm ::+  (PEvalNumTerm a, Eq a) => Term a -> Term a -> Maybe (Term a)+doPevalDefaultMulNumTerm (ConTerm a) (ConTerm b) =+  Just $ conTerm $ a * b+doPevalDefaultMulNumTerm l@(ConTerm a) b = case (a, b) of+  (0, _) -> Just $ conTerm 0+  (1, k) -> Just k+  (-1, k) -> Just $ pevalNegNumTerm k+  (l1, MulNumTerm (ConTerm j) k) ->+    Just $ pevalMulNumTerm (conTerm $ l1 * j) k+  (l1, AddNumTerm (ConTerm j) k) ->+    Just $ pevalAddNumTerm (conTerm $ l1 * j) (pevalMulNumTerm (conTerm l1) k)+  (l1, NegNumTerm j) -> Just (pevalMulNumTerm (conTerm $ -l1) j)+  (_, MulNumTerm _ ConTerm {}) -> error "Should not happen"+  (_, AddNumTerm _ ConTerm {}) -> error "Should not happen"+  _ -> doPevalDefaultMulNumTermNoCon l b+doPevalDefaultMulNumTerm a r@(ConTerm {}) = doPevalDefaultMulNumTerm r a+doPevalDefaultMulNumTerm l r = doPevalDefaultMulNumTermNoCon l r++doPevalDefaultMulNumTermNoCon ::+  (PEvalNumTerm a) => Term a -> Term a -> Maybe (Term a)+doPevalDefaultMulNumTermNoCon (MulNumTerm i@ConTerm {} j) k =+  Just $ pevalMulNumTerm i $ pevalMulNumTerm j k+doPevalDefaultMulNumTermNoCon i (MulNumTerm j@ConTerm {} k) =+  Just $ pevalMulNumTerm j $ pevalMulNumTerm i k+doPevalDefaultMulNumTermNoCon (NegNumTerm i) j =+  Just $ pevalNegNumTerm $ pevalMulNumTerm i j+doPevalDefaultMulNumTermNoCon i (NegNumTerm j) =+  Just $ pevalNegNumTerm $ pevalMulNumTerm i j+doPevalDefaultMulNumTermNoCon i j@ConTerm {} = Just $ pevalMulNumTerm j i+doPevalDefaultMulNumTermNoCon (MulNumTerm _ ConTerm {}) _ =+  error "Should not happen"+doPevalDefaultMulNumTermNoCon _ (MulNumTerm _ ConTerm {}) =+  error "Should not happen"+doPevalDefaultMulNumTermNoCon _ _ = Nothing++-- Abs++-- | Default partial evaluation of absolute value of finite-bit numerical terms.+pevalBitsAbsNumTerm :: (PEvalNumTerm a, Bits a) => Term a -> Term a+pevalBitsAbsNumTerm l@SupportedTerm =+  unaryUnfoldOnce doPevalBitsAbsNumTerm absNumTerm l++doPevalGeneralAbsNumTerm :: (PEvalNumTerm a) => Term a -> Maybe (Term a)+doPevalGeneralAbsNumTerm (ConTerm a) = Just $ conTerm $ abs a+doPevalGeneralAbsNumTerm (NegNumTerm v) = Just $ pevalAbsNumTerm v+doPevalGeneralAbsNumTerm t@(AbsNumTerm {}) = Just t+doPevalGeneralAbsNumTerm _ = Nothing++doPevalBitsAbsNumTerm ::+  forall a. (PEvalNumTerm a, Bits a) => Term a -> Maybe (Term a)+doPevalBitsAbsNumTerm t =+  msum+    [ if isSigned (undefined :: a) then Nothing else Just t,+      doPevalGeneralAbsNumTerm t+    ]++-- | Partial evaluation of absolute value of numerical terms that does not+-- overflow.+doPevalNoOverflowAbsNumTerm :: (PEvalNumTerm a) => Term a -> Maybe (Term a)+doPevalNoOverflowAbsNumTerm t =+  msum+    [ doPevalGeneralAbsNumTerm t,+      case t of+        MulNumTerm l r ->+          Just $ pevalMulNumTerm (pevalAbsNumTerm l) $ pevalAbsNumTerm r+        _ -> Nothing+    ]++-- Signum++-- | Default partial evaluation of signum of numerical terms.+pevalGeneralSignumNumTerm :: (PEvalNumTerm a) => Term a -> Term a+pevalGeneralSignumNumTerm l@SupportedTerm =+  unaryUnfoldOnce doPevalGeneralSignumNumTerm signumNumTerm l++doPevalGeneralSignumNumTerm :: (PEvalNumTerm a) => Term a -> Maybe (Term a)+doPevalGeneralSignumNumTerm (ConTerm a) = Just $ conTerm $ signum a+doPevalGeneralSignumNumTerm _ = Nothing++-- | Partial evaluation of signum of numerical terms that does not overflow.+doPevalNoOverflowSignumNumTerm :: (PEvalNumTerm a) => Term a -> Maybe (Term a)+doPevalNoOverflowSignumNumTerm t =+  msum+    [ doPevalGeneralSignumNumTerm t,+      case t of+        NegNumTerm v -> Just $ pevalNegNumTerm $ pevalSignumNumTerm v+        MulNumTerm l r ->+          Just $+            pevalMulNumTerm (pevalSignumNumTerm l) $+              pevalSignumNumTerm r+        _ -> Nothing+    ]++instance (KnownNat n, 1 <= n) => PEvalNumTerm (WordN n) where+  pevalAddNumTerm = pevalDefaultAddNumTerm+  pevalNegNumTerm = pevalDefaultNegNumTerm+  pevalMulNumTerm = pevalDefaultMulNumTerm+  pevalAbsNumTerm = pevalBitsAbsNumTerm+  pevalSignumNumTerm = pevalGeneralSignumNumTerm+  withSbvNumTermConstraint r = withPrim @(WordN n) r++instance (KnownNat n, 1 <= n) => PEvalNumTerm (IntN n) where+  pevalAddNumTerm = pevalDefaultAddNumTerm+  pevalNegNumTerm = pevalDefaultNegNumTerm+  pevalMulNumTerm = pevalDefaultMulNumTerm+  pevalAbsNumTerm = pevalBitsAbsNumTerm+  pevalSignumNumTerm = pevalGeneralSignumNumTerm+  withSbvNumTermConstraint r = withPrim @(IntN n) r++-- Partial evaluation++-- | A partial function from a to b.+type PartialFun a b = a -> Maybe b++-- | A partial rule for unary operations.+type PartialRuleUnary a b = PartialFun (Term a) (Term b)++-- | A total rule for unary operations.+type TotalRuleUnary a b = Term a -> Term b++-- | A partial rule for binary operations.+type PartialRuleBinary a b c = Term a -> PartialFun (Term b) (Term c)++-- | A total rule for binary operations.+type TotalRuleBinary a b c = Term a -> Term b -> Term c++-- | Totalize a partial function with a fallback function.+totalize :: PartialFun a b -> (a -> b) -> a -> b+totalize partial fallback a =+  case partial a of+    Just b -> b+    Nothing -> fallback a++-- | Totalize a binary partial function with a fallback function.+totalize2 :: (a -> PartialFun b c) -> (a -> b -> c) -> a -> b -> c+totalize2 partial fallback a b =+  case partial a b of+    Just c -> c+    Nothing -> fallback a b++-- | A strategy for partially evaluating unary operations.+class UnaryPartialStrategy tag a b | tag a -> b where+  extractor :: tag -> Term a -> Maybe a+  constantHandler :: tag -> a -> Maybe (Term b)+  nonConstantHandler :: tag -> Term a -> Maybe (Term b)++-- | Partially evaluate a unary operation.+unaryPartial :: forall tag a b. (UnaryPartialStrategy tag a b) => tag -> PartialRuleUnary a b+unaryPartial tag a = case extractor tag a of+  Nothing -> nonConstantHandler tag a+  Just a' -> constantHandler tag a'++-- | A strategy for partially evaluating commutative binary operations.+class BinaryCommPartialStrategy tag a c | tag a -> c where+  singleConstantHandler :: tag -> a -> Term a -> Maybe (Term c)++-- | A strategy for partially evaluating operations.+class BinaryPartialStrategy tag a b c | tag a b -> c where+  extractora :: tag -> Term a -> Maybe a+  extractorb :: tag -> Term b -> Maybe b+  allConstantHandler :: tag -> a -> b -> Maybe (Term c)+  leftConstantHandler :: tag -> a -> Term b -> Maybe (Term c)+  default leftConstantHandler :: (a ~ b, BinaryCommPartialStrategy tag a c) => tag -> a -> Term b -> Maybe (Term c)+  leftConstantHandler = singleConstantHandler @tag @a+  rightConstantHandler :: tag -> Term a -> b -> Maybe (Term c)+  default rightConstantHandler :: (a ~ b, BinaryCommPartialStrategy tag a c) => tag -> Term a -> b -> Maybe (Term c)+  rightConstantHandler tag = flip $ singleConstantHandler @tag @a tag+  nonBinaryConstantHandler :: tag -> Term a -> Term b -> Maybe (Term c)++-- | Partially evaluate a binary operation.+binaryPartial :: forall tag a b c. (BinaryPartialStrategy tag a b c) => tag -> PartialRuleBinary a b c+binaryPartial tag a b = case (extractora @tag @a @b @c tag a, extractorb @tag @a @b @c tag b) of+  (Nothing, Nothing) -> nonBinaryConstantHandler @tag @a @b @c tag a b+  (Just a', Nothing) ->+    leftConstantHandler @tag @a @b @c tag a' b+      `catchError` \_ -> nonBinaryConstantHandler @tag @a @b @c tag a b+  (Nothing, Just b') ->+    rightConstantHandler @tag @a @b @c tag a b'+      `catchError` \_ -> nonBinaryConstantHandler @tag @a @b @c tag a b+  (Just a', Just b') ->+    allConstantHandler @tag @a @b @c tag a' b'++unaryPartialUnfoldOnce ::+  forall a b.+  (SupportedPrim b) =>+  PartialRuleUnary a b ->+  TotalRuleUnary a b ->+  PartialRuleUnary a b+unaryPartialUnfoldOnce partial fallback = ret+  where+    oneLevel :: TotalRuleUnary a b -> PartialRuleUnary a b+    oneLevel fallback' x = case (x, partial x) of+      (ITETerm cond vt vf, pr) ->+        let pt = partial vt+            pf = partial vf+         in case (pt, pf) of+              (Nothing, Nothing) -> pr+              (mt, mf) ->+                pevalITETerm cond+                  <$> catchError mt (\_ -> Just $ totalize (oneLevel fallback') fallback' vt)+                  <*> catchError mf (\_ -> Just $ totalize (oneLevel fallback') fallback vf)+      (_, pr) -> pr+    ret :: PartialRuleUnary a b+    ret = oneLevel (totalize @(Term a) @(Term b) partial fallback)++-- | Unfold a unary operation once.+unaryUnfoldOnce ::+  forall a b.+  (SupportedPrim b) =>+  PartialRuleUnary a b ->+  TotalRuleUnary a b ->+  TotalRuleUnary a b+unaryUnfoldOnce partial fallback = totalize (unaryPartialUnfoldOnce partial fallback) fallback++binaryPartialUnfoldOnce ::+  forall a b c.+  (SupportedPrim c) =>+  PartialRuleBinary a b c ->+  TotalRuleBinary a b c ->+  PartialRuleBinary a b c+binaryPartialUnfoldOnce partial fallback = ret+  where+    oneLevel :: PartialRuleBinary x y c -> TotalRuleBinary x y c -> PartialRuleBinary x y c+    oneLevel partial' fallback' x y =+      catchError+        (partial' x y)+        ( \_ ->+            case (x, y) of+              (ITETerm _ ITETerm {} _, ITETerm {}) -> Nothing+              (ITETerm _ _ ITETerm {}, ITETerm {}) -> Nothing+              (ITETerm {}, ITETerm _ ITETerm {} _) -> Nothing+              (ITETerm {}, ITETerm _ _ ITETerm {}) -> Nothing+              (ITETerm cond vt vf, _) ->+                left cond vt vf y partial' fallback'+              (_, ITETerm cond vt vf) ->+                left cond vt vf x (flip partial') (flip fallback')+              _ -> Nothing+        )+    left ::+      Term Bool ->+      Term x ->+      Term x ->+      Term y ->+      PartialRuleBinary x y c ->+      TotalRuleBinary x y c ->+      Maybe (Term c)+    left cond vt vf y partial' fallback' =+      let pt = partial' vt y+          pf = partial' vf y+       in case (pt, pf) of+            (Nothing, Nothing) -> Nothing+            (mt, mf) ->+              pevalITETerm cond+                <$> catchError mt (\_ -> Just $ totalize2 (oneLevel partial' fallback') fallback' vt y)+                <*> catchError mf (\_ -> Just $ totalize2 (oneLevel partial' fallback') fallback' vf y)+    ret :: PartialRuleBinary a b c+    ret = oneLevel partial (totalize2 @(Term a) @(Term b) @(Term c) partial fallback)++-- | Unfold a binary operation once.+binaryUnfoldOnce ::+  forall a b c.+  (SupportedPrim c) =>+  PartialRuleBinary a b c ->+  TotalRuleBinary a b c ->+  TotalRuleBinary a b c+binaryUnfoldOnce partial fallback = totalize2 (binaryPartialUnfoldOnce partial fallback) fallback++-- | Unfold a unary operation once.+generalUnaryUnfolded ::+  forall a b.+  (Typeable a, SupportedPrim b) =>+  (a -> b) ->+  (Term a -> Term b) ->+  Term a ->+  Term b+generalUnaryUnfolded compute =+  unaryUnfoldOnce+    ( \case+        ConTerm lv -> Just $ conTerm $ compute lv+        _ -> Nothing+    )++-- | Unfold a binary operation once.+generalBinaryUnfolded ::+  forall a b c.+  (Typeable a, Typeable b, SupportedPrim c) =>+  (a -> b -> c) ->+  (Term a -> Term b -> Term c) ->+  Term a ->+  Term b ->+  Term c+generalBinaryUnfolded compute =+  binaryUnfoldOnce+    ( \l r -> case (l, r) of+        (ConTerm lv, ConTerm rv) -> Just $ conTerm $ compute lv rv+        _ -> Nothing+    )
+ src/Grisette/Internal/SymPrim/Prim/Internal/Unfold.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- |+-- Module      :   Grisette.Internal.SymPrim.Prim.PartialEval.Unfold+-- 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.SymPrim.Prim.Internal.Unfold+  ( unaryUnfoldOnce,+    binaryUnfoldOnce,+    generalUnaryUnfolded,+    generalBinaryUnfolded,+  )+where++import Control.Monad.Except (MonadError (catchError))+import Data.Typeable (Typeable)+import Grisette.Internal.SymPrim.Prim.Internal.PartialEval+  ( PartialRuleBinary,+    PartialRuleUnary,+    TotalRuleBinary,+    TotalRuleUnary,+    totalize,+    totalize2,+  )+import Grisette.Internal.SymPrim.Prim.Internal.Term+  ( SupportedPrim (pevalITETerm),+    Term,+    conTerm,+    pattern ConTerm,+    pattern ITETerm,+  )++unaryPartialUnfoldOnce ::+  forall a b.+  (SupportedPrim b) =>+  PartialRuleUnary a b ->+  TotalRuleUnary a b ->+  PartialRuleUnary a b+unaryPartialUnfoldOnce partial fallback = ret+  where+    oneLevel :: TotalRuleUnary a b -> PartialRuleUnary a b+    oneLevel fallback' x = case (x, partial x) of+      (ITETerm cond vt vf, pr) ->+        let pt = partial vt+            pf = partial vf+         in case (pt, pf) of+              (Nothing, Nothing) -> pr+              (mt, mf) ->+                pevalITETerm cond+                  <$> catchError mt (\_ -> Just $ totalize (oneLevel fallback') fallback' vt)+                  <*> catchError mf (\_ -> Just $ totalize (oneLevel fallback') fallback vf)+      (_, pr) -> pr+    ret :: PartialRuleUnary a b+    ret = oneLevel (totalize @(Term a) @(Term b) partial fallback)++-- | Unfold a unary operation once.+unaryUnfoldOnce ::+  forall a b.+  (SupportedPrim b) =>+  PartialRuleUnary a b ->+  TotalRuleUnary a b ->+  TotalRuleUnary a b+unaryUnfoldOnce partial fallback = totalize (unaryPartialUnfoldOnce partial fallback) fallback++binaryPartialUnfoldOnce ::+  forall a b c.+  (SupportedPrim c) =>+  PartialRuleBinary a b c ->+  TotalRuleBinary a b c ->+  PartialRuleBinary a b c+binaryPartialUnfoldOnce partial fallback = ret+  where+    oneLevel :: PartialRuleBinary x y c -> TotalRuleBinary x y c -> PartialRuleBinary x y c+    oneLevel partial' fallback' x y =+      catchError+        (partial' x y)+        ( \_ ->+            case (x, y) of+              (ITETerm _ ITETerm {} _, ITETerm {}) -> Nothing+              (ITETerm _ _ ITETerm {}, ITETerm {}) -> Nothing+              (ITETerm {}, ITETerm _ ITETerm {} _) -> Nothing+              (ITETerm {}, ITETerm _ _ ITETerm {}) -> Nothing+              (ITETerm cond vt vf, _) ->+                left cond vt vf y partial' fallback'+              (_, ITETerm cond vt vf) ->+                left cond vt vf x (flip partial') (flip fallback')+              _ -> Nothing+        )+    left ::+      Term Bool ->+      Term x ->+      Term x ->+      Term y ->+      PartialRuleBinary x y c ->+      TotalRuleBinary x y c ->+      Maybe (Term c)+    left cond vt vf y partial' fallback' =+      let pt = partial' vt y+          pf = partial' vf y+       in case (pt, pf) of+            (Nothing, Nothing) -> Nothing+            (mt, mf) ->+              pevalITETerm cond+                <$> catchError mt (\_ -> Just $ totalize2 (oneLevel partial' fallback') fallback' vt y)+                <*> catchError mf (\_ -> Just $ totalize2 (oneLevel partial' fallback') fallback' vf y)+    ret :: PartialRuleBinary a b c+    ret = oneLevel partial (totalize2 @(Term a) @(Term b) @(Term c) partial fallback)++-- | Unfold a binary operation once.+binaryUnfoldOnce ::+  forall a b c.+  (SupportedPrim c) =>+  PartialRuleBinary a b c ->+  TotalRuleBinary a b c ->+  TotalRuleBinary a b c+binaryUnfoldOnce partial fallback = totalize2 (binaryPartialUnfoldOnce partial fallback) fallback++-- | Unfold a unary operation once.+generalUnaryUnfolded ::+  forall a b.+  (Typeable a, SupportedPrim b) =>+  (a -> b) ->+  (Term a -> Term b) ->+  Term a ->+  Term b+generalUnaryUnfolded compute =+  unaryUnfoldOnce+    ( \case+        ConTerm lv -> Just $ conTerm $ compute lv+        _ -> Nothing+    )++-- | Unfold a binary operation once.+generalBinaryUnfolded ::+  forall a b c.+  (Typeable a, Typeable b, SupportedPrim c) =>+  (a -> b -> c) ->+  (Term a -> Term b -> Term c) ->+  Term a ->+  Term b ->+  Term c+generalBinaryUnfolded compute =+  binaryUnfoldOnce+    ( \l r -> case (l, r) of+        (ConTerm lv, ConTerm rv) -> Just $ conTerm $ compute lv rv+        _ -> Nothing+    )
+ src/Grisette/Internal/SymPrim/Prim/Internal/Utils.hs view
@@ -0,0 +1,223 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE UnliftedFFITypes #-}+{-# LANGUAGE ViewPatterns #-}++-- |+-- Module      :   Grisette.Internal.SymPrim.Prim.Internal.Utils+-- 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.SymPrim.Prim.Internal.Utils+  ( pattern Dyn,+    cmpHetero,+    eqHetero,+    cmpHeteroRep,+    eqHeteroRep,+    eqTypeRepBool,+    WeakThreadId,+    weakThreadId,+    WeakThreadIdRef,+    myWeakThreadId,+    weakThreadRefAlive,+    mkWeakThreadIdRefWithFinalizer,+    addStableNameFinalizer,+    addThreadIdFinalizer,+    mkWeakStableNameRefWithFinalizer,+    SomeStableName (..),+    mkWeakSomeStableNameRefWithFinalizer,+    mkWeakSomeStableNameRef,+  )+where++#if MIN_VERSION_base(4,19,0)+import GHC.Conc.Sync+  ( ThreadId(ThreadId),+    ThreadStatus (ThreadDied, ThreadFinished),+    fromThreadId,+    myThreadId,+    threadStatus,+  )+import GHC.Exts (mkWeak#, mkWeakNoFinalizer#)+#else+import GHC.Conc+  ( ThreadId (ThreadId),+    ThreadStatus (ThreadDied, ThreadFinished),+    myThreadId,+    threadStatus,+  )+import GHC.Exts (Addr#, ThreadId#, unsafeCoerce#, mkWeak#, mkWeakNoFinalizer#)+#if __GLASGOW_HASKELL__ >= 904+#elif __GLASGOW_HASKELL__ >= 900+import Foreign.C.Types (CLong (CLong))+#else+import Foreign.C.Types (CInt (CInt))+#endif+#endif+import Data.Typeable (cast)+import Data.Word (Word64)+import GHC.IO (IO (IO))+import GHC.StableName (StableName (StableName), eqStableName)+import GHC.Weak (Weak (Weak))+import System.Mem.Weak (deRefWeak)+import Type.Reflection+  ( TypeRep,+    Typeable,+    eqTypeRep,+    typeRep,+    type (:~~:) (HRefl),+  )++-- | Pattern synonym for dynamic type casting.+pattern Dyn :: (Typeable a, Typeable b) => a -> b+pattern Dyn x <- (cast -> Just x)++-- | Compare two values of different types, resolve the type equality using the+-- type representation.+cmpHeteroRep :: forall a b. TypeRep a -> TypeRep b -> (a -> a -> Bool) -> a -> b -> Bool+cmpHeteroRep ta tb f a b = case eqTypeRep ta tb of+  Just HRefl -> f a b+  _ -> False+{-# INLINE cmpHeteroRep #-}++-- | Compare two values of different types.+cmpHetero :: forall a b. (Typeable a, Typeable b) => (a -> a -> Bool) -> a -> b -> Bool+cmpHetero = cmpHeteroRep (typeRep @a) (typeRep @b)+{-# INLINE cmpHetero #-}++-- | Compare two values of different types for equality.+eqHetero :: forall a b. (Typeable a, Typeable b, Eq a) => a -> b -> Bool+eqHetero = cmpHetero (==)+{-# INLINE eqHetero #-}++-- | Compare two values of different types for equality, resolve the type+-- equality using the type representation.+eqHeteroRep :: forall a b. (Eq a) => TypeRep a -> TypeRep b -> a -> b -> Bool+eqHeteroRep ta tb = cmpHeteroRep ta tb (==)+{-# INLINE eqHeteroRep #-}++-- | Compare two type representations for equality.+eqTypeRepBool :: forall ka kb (a :: ka) (b :: kb). TypeRep a -> TypeRep b -> Bool+eqTypeRepBool a b = case eqTypeRep a b of+  Just HRefl -> True+  _ -> False+{-# INLINE eqTypeRepBool #-}++-- | A weak identifier to a thread id that doesn't prevent its garbage+-- collection.+type WeakThreadId = Word64++-- | A weak reference to a thread id that doesn't prevent its garbage+-- collection.+type WeakThreadIdRef = Weak ThreadId++{-# INLINE weakThreadId #-}++-- | Get an id of a thread that doesn't prevent its garbage collection.+weakThreadId :: ThreadId -> Word64+#if MIN_VERSION_base(4,19,0)+weakThreadId = fromThreadId+#else+#if __GLASGOW_HASKELL__ >= 904+weakThreadId (ThreadId t#) = rts_getThreadId (threadIdToAddr# t#)+#else+weakThreadId (ThreadId t#) = fromIntegral $ rts_getThreadId (threadIdToAddr# t#)+#endif++foreign import ccall unsafe "rts_getThreadId"+#if __GLASGOW_HASKELL__ >= 904+  -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/6163+  rts_getThreadId :: Addr# -> Word64+#elif __GLASGOW_HASKELL__ >= 900+  -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/1254+  rts_getThreadId :: Addr# -> CLong+#else+  rts_getThreadId :: Addr# -> CInt+#endif++-- Note: FFI imports take Addr# instead of ThreadId# because of+-- https://gitlab.haskell.org/ghc/ghc/-/issues/8281, which would prevent loading+-- effectful-core into GHCi.+--+-- Previous workaround was to use an internal library with just this module, but+-- this is not viable because of bugs in stack (sigh).+--+-- The coercion is fine because GHC represents ThreadId# as a pointer.+{-# INLINE threadIdToAddr# #-}+threadIdToAddr# :: ThreadId# -> Addr#+threadIdToAddr# = unsafeCoerce#+#endif++-- | Get a weak identifier to the current thread id.+myWeakThreadId :: IO WeakThreadId+myWeakThreadId = weakThreadId <$> myThreadId+{-# INLINE myWeakThreadId #-}++-- | Check if a weak reference to a thread id is still alive.+weakThreadRefAlive :: WeakThreadIdRef -> IO Bool+weakThreadRefAlive wtid = do+  tid <- deRefWeak wtid+  case tid of+    Nothing -> return False+    Just tid -> do+      st <- threadStatus tid+      return $ st `notElem` [ThreadFinished, ThreadDied]+{-# INLINE weakThreadRefAlive #-}++-- | Create a weak reference to a thread id with a finalizer.+mkWeakThreadIdRefWithFinalizer :: ThreadId -> IO () -> IO (Weak ThreadId)+mkWeakThreadIdRefWithFinalizer t@(ThreadId t#) (IO finalizer) = IO $ \s ->+  case mkWeak# t# t finalizer s of+    (# s1, w #) -> (# s1, Weak w #)++-- | Add a finalizer to a thread id.+addThreadIdFinalizer :: ThreadId -> IO () -> IO ()+addThreadIdFinalizer t@(ThreadId t#) (IO finalizer) = IO $ \s ->+  case mkWeak# t# t finalizer s of+    (# s1, _ #) -> (# s1, () #)++-- | Create a weak reference to a stable name with a finalizer.+mkWeakStableNameRefWithFinalizer ::+  StableName a -> IO () -> IO (Weak (StableName a))+mkWeakStableNameRefWithFinalizer t@(StableName t#) (IO finalizer) = IO $ \s ->+  case mkWeak# t# t finalizer s of+    (# s1, w #) -> (# s1, Weak w #)++-- | Add a finalizer to a stable name.+addStableNameFinalizer :: StableName a -> IO () -> IO ()+addStableNameFinalizer t@(StableName t#) (IO finalizer) = IO $ \s ->+  case mkWeak# t# t finalizer s of+    (# s1, _ #) -> (# s1, () #)++-- | A type-erased stable name.+data SomeStableName where+  SomeStableName :: StableName a -> SomeStableName++instance Eq SomeStableName where+  SomeStableName l == SomeStableName r = eqStableName l r++-- | Create a weak reference to a stable name.+mkWeakSomeStableNameRef :: SomeStableName -> IO (Weak SomeStableName)+mkWeakSomeStableNameRef t@(SomeStableName (StableName t#)) = IO $ \s ->+  case mkWeakNoFinalizer# t# t s of+    (# s1, w #) -> (# s1, Weak w #)++-- | Create a weak reference to a stable name with a finalizer.+mkWeakSomeStableNameRefWithFinalizer ::+  SomeStableName -> IO () -> IO (Weak SomeStableName)+mkWeakSomeStableNameRefWithFinalizer+  t@(SomeStableName (StableName t#))+  (IO finalizer) = IO $ \s ->+    case mkWeak# t# t finalizer s of+      (# s1, w #) -> (# s1, Weak w #)
+ src/Grisette/Internal/SymPrim/Prim/Model.hs view
@@ -0,0 +1,518 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++-- |+-- Module      :   Grisette.Internal.SymPrim.Prim.Model+-- 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.SymPrim.Prim.Model+  ( SymbolSet (..),+    ConstantSymbolSet,+    AnySymbolSet,+    Model (..),+    ModelValuePair (..),+    equation,+    evalTerm,+  )+where++import Control.DeepSeq (NFData)+import qualified Data.Binary as Binary+import Data.Bytes.Serial (Serial (deserialize, serialize))+import qualified Data.HashMap.Strict as M+import qualified Data.HashSet as S+import Data.Hashable (Hashable)+import Data.List (sort, sortOn)+import Data.Proxy (Proxy (Proxy))+import qualified Data.Serialize as Cereal+import GHC.Generics (Generic)+import Grisette.Internal.Core.Data.Class.ModelOps+  ( ModelOps+      ( emptyModel,+        exceptFor,+        exceptFor',+        extendTo,+        insertValue,+        isEmptyModel,+        modelContains,+        restrictTo,+        valueOf+      ),+    ModelRep (buildModel),+    SymbolSetOps+      ( containsSymbol,+        differenceSet,+        emptySet,+        insertSymbol,+        intersectionSet,+        isEmptySet,+        unionSet+      ),+    SymbolSetRep (buildSymbolSet),+  )+import Grisette.Internal.SymPrim.GeneralFun (generalSubstSomeTerm)+import Grisette.Internal.SymPrim.Prim.Internal.Term+  ( SomeTypedAnySymbol,+    SomeTypedConstantSymbol,+    SupportedPrim,+    SymbolKind (AnyKind, ConstantKind),+    Term,+    TypedAnySymbol,+  )+import Grisette.Internal.SymPrim.Prim.Term+  ( IsSymbolKind,+    ModelValue,+    SomeTypedSymbol (SomeTypedSymbol),+    SupportedPrim (defaultValue),+    TypedSymbol,+    conTerm,+    defaultValueDynamic,+    pevalEqTerm,+    showUntyped,+    someTypedSymbol,+    symTerm,+    toModelValue,+    unsafeFromModelValue,+    pattern SupportedTypedSymbol,+  )+import Language.Haskell.TH.Syntax (Lift)++-- $setup+-- >>> import Grisette.Core+-- >>> import Grisette.SymPrim++-- | Set of symbols.+--+-- Check 'Grisette.Core.SymbolSetOps' for operations, and+-- 'Grisette.Core.SymbolSetRep' for manual constructions.+newtype SymbolSet knd = SymbolSet+  { unSymbolSet :: S.HashSet (SomeTypedSymbol knd)+  }+  deriving (Eq, Generic)+  deriving newtype (Hashable)+  deriving anyclass (Serial)++instance (IsSymbolKind knd) => Cereal.Serialize (SymbolSet knd) where+  put = serialize+  get = deserialize++instance (IsSymbolKind knd) => Binary.Binary (SymbolSet knd) where+  put = serialize+  get = deserialize++-- | Set of constant symbols. Excluding unintepreted functions.+type ConstantSymbolSet = SymbolSet 'ConstantKind++-- | Set of any symbols.+type AnySymbolSet = SymbolSet 'AnyKind++instance Semigroup (SymbolSet knd) where+  SymbolSet s1 <> SymbolSet s2 = SymbolSet $ S.union s1 s2++instance Monoid (SymbolSet knd) where+  mempty = emptySet++instance Show (SymbolSet knd) where+  showsPrec prec (SymbolSet s) = showParen (prec >= 10) $ \x ->+    "SymbolSet {"+      ++ go0 (sort $ show <$> S.toList s)+      ++ "}"+      ++ x+    where+      go0 [] = ""+      go0 [x] = x+      go0 (x : xs) = x ++ ", " ++ go0 xs++-- | Model returned by the solver.+--+-- Check 'Grisette.Core.ModelOps' for operations, and 'Grisette.Core.ModelRep'+-- for manual constructions.+newtype Model = Model+  { unModel :: M.HashMap SomeTypedAnySymbol ModelValue+  }+  deriving stock (Eq, Generic, Lift)+  deriving newtype (Hashable, NFData)+  deriving anyclass (Serial)++instance Cereal.Serialize Model where+  put = serialize+  get = deserialize++instance Binary.Binary Model where+  put = serialize+  get = deserialize++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 {"+      ++ go0 (sortOn (\(x, _) -> show x) $ M.toList m)+      ++ "}"+      ++ x+    where+      go0 [] = ""+      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 :: TypedAnySymbol a -> Model -> Maybe (Term Bool)+equation tsym@SupportedTypedSymbol m =+  case valueOf tsym m of+    Just v -> Just $ pevalEqTerm (symTerm tsym) (conTerm v)+    Nothing -> Nothing++instance SymbolSetOps (SymbolSet knd) (TypedSymbol knd) where+  emptySet = SymbolSet S.empty+  isEmptySet (SymbolSet s) = S.null s+  containsSymbol s =+    S.member (someTypedSymbol s) . unSymbolSet+  insertSymbol s = SymbolSet . S.insert (someTypedSymbol s) . unSymbolSet+  intersectionSet (SymbolSet s1) (SymbolSet s2) = SymbolSet $ S.intersection s1 s2+  unionSet (SymbolSet s1) (SymbolSet s2) = SymbolSet $ S.union s1 s2+  differenceSet (SymbolSet s1) (SymbolSet s2) = SymbolSet $ S.difference s1 s2++instance+  SymbolSetRep+    (SomeTypedSymbol knd)+    (SymbolSet knd)+    (TypedSymbol knd)+  where+  buildSymbolSet sym = SymbolSet $ S.singleton sym++instance+  SymbolSetRep+    [SomeTypedSymbol knd]+    (SymbolSet knd)+    (TypedSymbol knd)+  where+  buildSymbolSet = SymbolSet . S.fromList++instance+  SymbolSetRep+    [TypedSymbol knd t]+    (SymbolSet knd)+    (TypedSymbol knd)+  where+  buildSymbolSet sym = buildSymbolSet $ someTypedSymbol <$> sym++instance+  SymbolSetRep+    (TypedSymbol knd t)+    (SymbolSet knd)+    (TypedSymbol knd)+  where+  buildSymbolSet sym = insertSymbol sym emptySet++instance+  SymbolSetRep+    ( TypedSymbol knd a,+      TypedSymbol knd b+    )+    (SymbolSet knd)+    (TypedSymbol knd)+  where+  buildSymbolSet (sym1, sym2) =+    insertSymbol sym2+      . insertSymbol sym1+      $ emptySet++instance+  SymbolSetRep+    ( TypedSymbol knd a,+      TypedSymbol knd b,+      TypedSymbol knd c+    )+    (SymbolSet knd)+    (TypedSymbol knd)+  where+  buildSymbolSet (sym1, sym2, sym3) =+    insertSymbol sym3+      . insertSymbol sym2+      . insertSymbol sym1+      $ emptySet++instance+  SymbolSetRep+    ( TypedSymbol knd a,+      TypedSymbol knd b,+      TypedSymbol knd c,+      TypedSymbol knd d+    )+    (SymbolSet knd)+    (TypedSymbol knd)+  where+  buildSymbolSet (sym1, sym2, sym3, sym4) =+    insertSymbol sym4+      . insertSymbol sym3+      . insertSymbol sym2+      . insertSymbol sym1+      $ emptySet++instance+  SymbolSetRep+    ( TypedSymbol knd a,+      TypedSymbol knd b,+      TypedSymbol knd c,+      TypedSymbol knd d,+      TypedSymbol knd e+    )+    (SymbolSet knd)+    (TypedSymbol knd)+  where+  buildSymbolSet (sym1, sym2, sym3, sym4, sym5) =+    insertSymbol sym5+      . insertSymbol sym4+      . insertSymbol sym3+      . insertSymbol sym2+      . insertSymbol sym1+      $ emptySet++instance+  SymbolSetRep+    ( TypedSymbol knd a,+      TypedSymbol knd b,+      TypedSymbol knd c,+      TypedSymbol knd d,+      TypedSymbol knd e,+      TypedSymbol knd f+    )+    (SymbolSet knd)+    (TypedSymbol knd)+  where+  buildSymbolSet (sym1, sym2, sym3, sym4, sym5, sym6) =+    insertSymbol sym6+      . insertSymbol sym5+      . insertSymbol sym4+      . insertSymbol sym3+      . insertSymbol sym2+      . insertSymbol sym1+      $ emptySet++instance+  SymbolSetRep+    ( TypedSymbol knd a,+      TypedSymbol knd b,+      TypedSymbol knd c,+      TypedSymbol knd d,+      TypedSymbol knd e,+      TypedSymbol knd f,+      TypedSymbol knd g+    )+    (SymbolSet knd)+    (TypedSymbol knd)+  where+  buildSymbolSet (sym1, sym2, sym3, sym4, sym5, sym6, sym7) =+    insertSymbol sym7+      . insertSymbol sym6+      . insertSymbol sym5+      . insertSymbol sym4+      . insertSymbol sym3+      . insertSymbol sym2+      . insertSymbol sym1+      $ emptySet++instance+  SymbolSetRep+    ( TypedSymbol knd a,+      TypedSymbol knd b,+      TypedSymbol knd c,+      TypedSymbol knd d,+      TypedSymbol knd e,+      TypedSymbol knd f,+      TypedSymbol knd g,+      TypedSymbol knd h+    )+    (SymbolSet knd)+    (TypedSymbol knd)+  where+  buildSymbolSet (sym1, sym2, sym3, sym4, sym5, sym6, sym7, sym8) =+    insertSymbol sym8+      . insertSymbol sym7+      . insertSymbol sym6+      . insertSymbol sym5+      . insertSymbol sym4+      . insertSymbol sym3+      . insertSymbol sym2+      . insertSymbol sym1+      $ emptySet++instance ModelOps Model AnySymbolSet TypedAnySymbol where+  emptyModel = Model M.empty+  isEmptyModel (Model m) = M.null m+  valueOf :: forall t. TypedAnySymbol t -> Model -> Maybe t+  valueOf sym@SupportedTypedSymbol (Model m) =+    (unsafeFromModelValue @t) <$> M.lookup (someTypedSymbol sym) m+  modelContains sym (Model m) = M.member (someTypedSymbol sym) m+  exceptFor (SymbolSet s) (Model m) = Model $ S.foldl' (flip M.delete) m s+  exceptFor' s (Model m) = Model $ M.delete (someTypedSymbol s) m+  restrictTo (SymbolSet s) (Model m) =+    Model $+      S.foldl'+        ( \acc sym -> case M.lookup sym m of+            Just v -> M.insert sym v acc+            Nothing -> acc+        )+        M.empty+        s+  extendTo (SymbolSet s) (Model m) =+    Model $+      S.foldl'+        ( \acc+           sym@(SomeTypedSymbol (SupportedTypedSymbol :: TypedAnySymbol t)) ->+              case M.lookup sym acc of+                Just _ -> acc+                Nothing -> M.insert sym (defaultValueDynamic (Proxy @t)) acc+        )+        m+        s+  insertValue sym@SupportedTypedSymbol (v :: t) (Model m) =+    Model $ M.insert (someTypedSymbol sym) (toModelValue v) m++-- | Evaluate a term in the given model.+evalTerm ::+  (SupportedPrim a) =>+  Bool ->+  Model ->+  S.HashSet SomeTypedConstantSymbol ->+  Term a ->+  Term a+evalTerm fillDefault (Model ma) =+  generalSubstSomeTerm+    ( \(sym@SupportedTypedSymbol :: TypedSymbol 'AnyKind a) ->+        case (M.lookup (someTypedSymbol sym) ma) of+          Nothing ->+            if fillDefault+              then conTerm (defaultValue @a)+              else symTerm sym+          Just dy ->+            conTerm (unsafeFromModelValue @a dy)+    )++-- |+-- A type used for building a model by hand.+--+-- >>> buildModel ("x" ::= (1 :: Integer), "y" ::= True) :: Model+-- Model {x -> 1 :: Integer, y -> true :: Bool}+data ModelValuePair t = (TypedAnySymbol t) ::= t deriving (Show)++instance ModelRep (ModelValuePair t) Model where+  buildModel (sym ::= val) = insertValue sym val emptyModel++instance (ModelRep a Model, ModelRep b Model) => ModelRep (a, b) Model where+  buildModel (a, b) = buildModel a <> buildModel b++instance+  ( ModelRep a Model,+    ModelRep b Model,+    ModelRep c Model+  ) =>+  ModelRep (a, b, c) Model+  where+  buildModel (a, b, c) = buildModel a <> buildModel b <> buildModel c++instance+  ( ModelRep a Model,+    ModelRep b Model,+    ModelRep c Model,+    ModelRep d Model+  ) =>+  ModelRep (a, b, c, d) Model+  where+  buildModel (a, b, c, d) =+    buildModel a <> buildModel b <> buildModel c <> buildModel d++instance+  ( ModelRep a Model,+    ModelRep b Model,+    ModelRep c Model,+    ModelRep d Model,+    ModelRep e Model+  ) =>+  ModelRep (a, b, c, d, e) Model+  where+  buildModel (a, b, c, d, e) =+    buildModel a <> buildModel b <> buildModel c <> buildModel d <> buildModel e++instance+  ( ModelRep a Model,+    ModelRep b Model,+    ModelRep c Model,+    ModelRep d Model,+    ModelRep e Model,+    ModelRep f Model+  ) =>+  ModelRep (a, b, c, d, e, f) Model+  where+  buildModel (a, b, c, d, e, f) =+    buildModel a+      <> buildModel b+      <> buildModel c+      <> buildModel d+      <> buildModel e+      <> buildModel f++instance+  ( ModelRep a Model,+    ModelRep b Model,+    ModelRep c Model,+    ModelRep d Model,+    ModelRep e Model,+    ModelRep f Model,+    ModelRep g Model+  ) =>+  ModelRep (a, b, c, d, e, f, g) Model+  where+  buildModel (a, b, c, d, e, f, g) =+    buildModel a+      <> buildModel b+      <> buildModel c+      <> buildModel d+      <> buildModel e+      <> buildModel f+      <> buildModel g++instance+  ( ModelRep a Model,+    ModelRep b Model,+    ModelRep c Model,+    ModelRep d Model,+    ModelRep e Model,+    ModelRep f Model,+    ModelRep g Model,+    ModelRep h Model+  ) =>+  ModelRep (a, b, c, d, e, f, g, h) Model+  where+  buildModel (a, b, c, d, e, f, g, h) =+    buildModel a+      <> buildModel b+      <> buildModel c+      <> buildModel d+      <> buildModel e+      <> buildModel f+      <> buildModel g+      <> buildModel h
+ src/Grisette/Internal/SymPrim/Prim/Pattern.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}++-- |+-- Module      :   Grisette.Internal.SymPrim.Prim.Pattern+-- 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.Prim.Pattern+  ( pattern SubTerms,+  )+where++import Data.Foldable (Foldable (toList))+import Grisette.Internal.SymPrim.Prim.Internal.Term+  ( Term,+    pattern AbsNumTerm,+    pattern AddNumTerm,+    pattern AndBitsTerm,+    pattern AndTerm,+    pattern ApplyTerm,+    pattern BVConcatTerm,+    pattern BVExtendTerm,+    pattern BVSelectTerm,+    pattern BitCastOrTerm,+    pattern BitCastTerm,+    pattern ComplementBitsTerm,+    pattern ConTerm,+    pattern DistinctTerm,+    pattern DivIntegralTerm,+    pattern EqTerm,+    pattern ExistsTerm,+    pattern FPBinaryTerm,+    pattern FPFMATerm,+    pattern FPRoundingBinaryTerm,+    pattern FPRoundingUnaryTerm,+    pattern FPTraitTerm,+    pattern FPUnaryTerm,+    pattern FdivTerm,+    pattern FloatingUnaryTerm,+    pattern ForallTerm,+    pattern FromFPOrTerm,+    pattern FromIntegralTerm,+    pattern ITETerm,+    pattern LeOrdTerm,+    pattern LtOrdTerm,+    pattern ModIntegralTerm,+    pattern MulNumTerm,+    pattern NegNumTerm,+    pattern NotTerm,+    pattern OrBitsTerm,+    pattern OrTerm,+    pattern PowerTerm,+    pattern QuotIntegralTerm,+    pattern RecipTerm,+    pattern RemIntegralTerm,+    pattern RotateLeftTerm,+    pattern RotateRightTerm,+    pattern ShiftLeftTerm,+    pattern ShiftRightTerm,+    pattern SignumNumTerm,+    pattern SymTerm,+    pattern ToFPTerm,+    pattern XorBitsTerm,+  )+import Grisette.Internal.SymPrim.Prim.SomeTerm (SomeTerm (SomeTerm))++subTermsViewPattern :: Term a -> Maybe [SomeTerm]+subTermsViewPattern (ConTerm _) = return []+subTermsViewPattern (SymTerm _) = return []+subTermsViewPattern (ForallTerm _ t) = return [SomeTerm t]+subTermsViewPattern (ExistsTerm _ t) = return [SomeTerm t]+subTermsViewPattern (NotTerm t) = return [SomeTerm t]+subTermsViewPattern (OrTerm t1 t2) = return [SomeTerm t1, SomeTerm t2]+subTermsViewPattern (AndTerm t1 t2) = return [SomeTerm t1, SomeTerm t2]+subTermsViewPattern (EqTerm t1 t2) = return [SomeTerm t1, SomeTerm t2]+subTermsViewPattern (DistinctTerm t) = return (SomeTerm <$> toList t)+subTermsViewPattern (ITETerm t1 t2 t3) =+  return [SomeTerm t1, SomeTerm t2, SomeTerm t3]+subTermsViewPattern (AddNumTerm t1 t2) = return [SomeTerm t1, SomeTerm t2]+subTermsViewPattern (NegNumTerm t) = return [SomeTerm t]+subTermsViewPattern (MulNumTerm t1 t2) = return [SomeTerm t1, SomeTerm t2]+subTermsViewPattern (AbsNumTerm t) = return [SomeTerm t]+subTermsViewPattern (SignumNumTerm t) = return [SomeTerm t]+subTermsViewPattern (LtOrdTerm t1 t2) = return [SomeTerm t1, SomeTerm t2]+subTermsViewPattern (LeOrdTerm t1 t2) = return [SomeTerm t1, SomeTerm t2]+subTermsViewPattern (AndBitsTerm t1 t2) = return [SomeTerm t1, SomeTerm t2]+subTermsViewPattern (OrBitsTerm t1 t2) = return [SomeTerm t1, SomeTerm t2]+subTermsViewPattern (XorBitsTerm t1 t2) = return [SomeTerm t1, SomeTerm t2]+subTermsViewPattern (ComplementBitsTerm t) = return [SomeTerm t]+subTermsViewPattern (ShiftLeftTerm t1 t2) = return [SomeTerm t1, SomeTerm t2]+subTermsViewPattern (ShiftRightTerm t1 t2) = return [SomeTerm t1, SomeTerm t2]+subTermsViewPattern (RotateLeftTerm t1 t2) = return [SomeTerm t1, SomeTerm t2]+subTermsViewPattern (RotateRightTerm t1 t2) = return [SomeTerm t1, SomeTerm t2]+subTermsViewPattern (BitCastTerm t1) = return [SomeTerm t1]+subTermsViewPattern (BitCastOrTerm t1 t2) = return [SomeTerm t1, SomeTerm t2]+subTermsViewPattern (BVConcatTerm t1 t2) = return [SomeTerm t1, SomeTerm t2]+subTermsViewPattern (BVSelectTerm _ _ t1) = return [SomeTerm t1]+subTermsViewPattern (BVExtendTerm _ _ t1) = return [SomeTerm t1]+subTermsViewPattern (ApplyTerm t1 t2) = return [SomeTerm t1, SomeTerm t2]+subTermsViewPattern (DivIntegralTerm t1 t2) = return [SomeTerm t1, SomeTerm t2]+subTermsViewPattern (ModIntegralTerm t1 t2) = return [SomeTerm t1, SomeTerm t2]+subTermsViewPattern (QuotIntegralTerm t1 t2) = return [SomeTerm t1, SomeTerm t2]+subTermsViewPattern (RemIntegralTerm t1 t2) = return [SomeTerm t1, SomeTerm t2]+subTermsViewPattern (FPTraitTerm _ t1) = return [SomeTerm t1]+subTermsViewPattern (FdivTerm t1 t2) = return [SomeTerm t1, SomeTerm t2]+subTermsViewPattern (RecipTerm t) = return [SomeTerm t]+subTermsViewPattern (FloatingUnaryTerm _ t) = return [SomeTerm t]+subTermsViewPattern (PowerTerm t1 t2) = return [SomeTerm t1, SomeTerm t2]+subTermsViewPattern (FPUnaryTerm _ t) = return [SomeTerm t]+subTermsViewPattern (FPBinaryTerm _ t1 t2) = return [SomeTerm t1, SomeTerm t2]+subTermsViewPattern (FPRoundingUnaryTerm _ rd t) = return [SomeTerm rd, SomeTerm t]+subTermsViewPattern (FPRoundingBinaryTerm _ rd t1 t2) = return [SomeTerm rd, SomeTerm t1, SomeTerm t2]+subTermsViewPattern (FPFMATerm rd t1 t2 t3) =+  return [SomeTerm rd, SomeTerm t1, SomeTerm t2, SomeTerm t3]+subTermsViewPattern (FromIntegralTerm t) = return [SomeTerm t]+subTermsViewPattern (FromFPOrTerm t1 rd t2) = return [SomeTerm t1, SomeTerm rd, SomeTerm t2]+subTermsViewPattern (ToFPTerm rd t1 _ _) = return [SomeTerm rd, SomeTerm t1]++-- | Extract all the subterms of a term.+pattern SubTerms :: [SomeTerm] -> Term a+pattern SubTerms ts <- (subTermsViewPattern -> Just ts)++#if MIN_VERSION_base(4, 16, 4)+{-# COMPLETE SubTerms #-}+{-# INLINE SubTerms #-}+#endif
+ src/Grisette/Internal/SymPrim/Prim/SomeTerm.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- |+-- Module      :   Grisette.Internal.SymPrim.Prim.SomeTerm+-- 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.SymPrim.Prim.SomeTerm+  ( SomeTerm (..),+    someTerm,+    someTermId,+  )+where++import Data.Hashable (Hashable (hashWithSalt))+import Data.Typeable (eqT, type (:~:) (Refl))+import Grisette.Internal.SymPrim.Prim.Internal.Caches (Id)+import Grisette.Internal.SymPrim.Prim.Internal.Term+  ( SupportedPrim (primTypeRep),+    Term,+    termId,+    pattern SupportedTerm,+  )++-- | Existential wrapper for symbolic Grisette terms.+data SomeTerm where+  SomeTerm :: forall a. (SupportedPrim a) => Term a -> SomeTerm++instance Eq SomeTerm where+  (SomeTerm (t1 :: Term a)) == (SomeTerm (t2 :: Term b)) =+    case eqT @a @b of+      Just Refl -> t1 == t2+      Nothing -> False++instance Hashable SomeTerm where+  hashWithSalt s (SomeTerm t) = hashWithSalt s t++instance Show SomeTerm where+  show (SomeTerm (t :: Term a)) =+    "<<" ++ show t ++ " :: " ++ show (primTypeRep @a) ++ ">>"++-- | Wrap a symbolic term into t'SomeTerm'.+someTerm :: Term a -> SomeTerm+someTerm v@SupportedTerm = SomeTerm v+{-# INLINE someTerm #-}++-- | Get the unique identifier of a symbolic term.+someTermId :: SomeTerm -> Id+someTermId (SomeTerm t) = termId t+{-# INLINE someTermId #-}
+ src/Grisette/Internal/SymPrim/Prim/Term.hs view
@@ -0,0 +1,33 @@+{-# OPTIONS_GHC -Wno-missing-import-lists #-}++-- |+-- Module      :   Grisette.Internal.SymPrim.Prim.Term+-- 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.Prim.Term+  ( module Grisette.Internal.SymPrim.Prim.Internal.Term,+    module Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalShiftTerm,+    module Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalRotateTerm,+    module Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalOrdTerm,+    module Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalDivModIntegralTerm,+    module Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalIEEEFPConvertibleTerm,+  )+where++import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalBitCastTerm ()+import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalDivModIntegralTerm+import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalFP ()+import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalFloatingTerm ()+import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalFractionalTerm ()+import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalFromIntegralTerm ()+import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalIEEEFPConvertibleTerm+import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalNumTerm ()+import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalOrdTerm+import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalRotateTerm+import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalShiftTerm+import Grisette.Internal.SymPrim.Prim.Internal.Serialize ()+import Grisette.Internal.SymPrim.Prim.Internal.Term
+ src/Grisette/Internal/SymPrim/Prim/TermUtils.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- |+-- Module      :   Grisette.Internal.SymPrim.Prim.TermUtils+-- 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.SymPrim.Prim.TermUtils+  ( extractTerm,+    castTerm,+    someTermsSize,+    someTermSize,+    termSize,+    termsSize,+  )+where++import Control.Monad.State+  ( State,+    execState,+    gets,+    modify',+  )+import Data.Data (cast)+import Data.Foldable (traverse_)+import qualified Data.HashSet as HS+import Grisette.Internal.Core.Data.MemoUtils (htmemo)+import Grisette.Internal.SymPrim.GeneralFun (type (-->) (GeneralFun))+import Grisette.Internal.SymPrim.Prim.Internal.Term+  ( IsSymbolKind (SymbolKindConstraint),+    SomeTypedConstantSymbol,+    SomeTypedSymbol (SomeTypedSymbol),+    SupportedPrim (castTypedSymbol, primTypeRep),+    Term,+    TypedAnySymbol,+    someTypedSymbol,+    pattern ConTerm,+    pattern ExistsTerm,+    pattern ForallTerm,+    pattern SupportedTerm,+    pattern SymTerm,+  )+import Grisette.Internal.SymPrim.Prim.Pattern (pattern SubTerms)+import Grisette.Internal.SymPrim.Prim.SomeTerm+  ( SomeTerm (SomeTerm),+    someTerm,+  )+import Type.Reflection+  ( TypeRep,+    Typeable,+    eqTypeRep,+    typeRep,+    pattern App,+    type (:~~:) (HRefl),+  )++{-# NOINLINE extractSymSomeTerm #-}+extractSymSomeTerm ::+  forall knd.+  (IsSymbolKind knd) =>+  HS.HashSet (SomeTypedConstantSymbol) ->+  SomeTerm ->+  Maybe (HS.HashSet (SomeTypedSymbol knd))+extractSymSomeTerm initialBounded = go initialMemo initialBounded+  where+    gotyped ::+      ( SomeTerm ->+        Maybe (HS.HashSet (SomeTypedSymbol knd))+      ) ->+      Term a ->+      Maybe (HS.HashSet (SomeTypedSymbol knd))+    gotyped memo a = memo (someTerm a)+    initialMemo ::+      SomeTerm ->+      Maybe (HS.HashSet (SomeTypedSymbol knd))+    initialMemo = htmemo (go initialMemo initialBounded)+    {-# NOINLINE initialMemo #-}++    go ::+      ( SomeTerm ->+        Maybe (HS.HashSet (SomeTypedSymbol knd))+      ) ->+      HS.HashSet (SomeTypedConstantSymbol) ->+      SomeTerm ->+      Maybe (HS.HashSet (SomeTypedSymbol knd))+    go _ bs (SomeTerm (SymTerm (sym :: TypedAnySymbol a))) =+      case (castTypedSymbol sym, castTypedSymbol sym) of+        (Just sym', _) | HS.member (someTypedSymbol sym') bs -> return HS.empty+        (_, Just sym') ->+          return $ HS.singleton $ SomeTypedSymbol sym'+        _ -> Nothing+    go _ bs (SomeTerm (ConTerm cv :: Term v)) =+      case (primTypeRep :: TypeRep v) of+        App (App gf _) _ ->+          case eqTypeRep (typeRep @(-->)) gf of+            Just HRefl -> case cv of+              GeneralFun sym (tm :: Term r) ->+                let newBounded = HS.union (HS.singleton (someTypedSymbol sym)) bs+                    newmemo = htmemo (go newmemo newBounded)+                    {-# NOINLINE newmemo #-}+                 in gotyped newmemo tm+            Nothing -> return HS.empty+        _ -> return HS.empty+    go _ bs (SomeTerm (ForallTerm sym arg)) =+      let newBounded = HS.insert (someTypedSymbol sym) bs+          newmemo = htmemo (go newmemo newBounded)+          {-# NOINLINE newmemo #-}+       in gotyped newmemo arg+    go _ bs (SomeTerm (ExistsTerm sym arg)) =+      let newBounded = HS.insert (someTypedSymbol sym) bs+          newmemo = htmemo (go newmemo newBounded)+          {-# NOINLINE newmemo #-}+       in gotyped newmemo arg+    go memo _ (SomeTerm (SubTerms ts)) = combineAllSets $ map memo ts+    combineSet (Just a) (Just b) = Just $ HS.union a b+    combineSet _ _ = Nothing+    combineAllSets = foldl1 combineSet++-- | Extract all the symbols in a term.+extractTerm ::+  (IsSymbolKind knd, SymbolKindConstraint knd a, SupportedPrim a) =>+  HS.HashSet (SomeTypedConstantSymbol) ->+  Term a ->+  Maybe (HS.HashSet (SomeTypedSymbol knd))+extractTerm initialBoundedSymbols t =+  extractSymSomeTerm initialBoundedSymbols (SomeTerm t)+{-# NOINLINE extractTerm #-}++-- | Cast a term to another type.+castTerm :: forall a b. (Typeable b) => Term a -> Maybe (Term b)+castTerm t@SupportedTerm = cast t+{-# INLINE castTerm #-}++-- | Compute the size of a list of terms. Do not count the same term twice.+someTermsSize :: [SomeTerm] -> Int+someTermsSize terms = HS.size $ execState (traverse goSome terms) HS.empty+  where+    exists t = gets (HS.member (someTerm t))+    add t = modify' (HS.insert (someTerm t))+    goSome :: SomeTerm -> State (HS.HashSet SomeTerm) ()+    goSome (SomeTerm b) = go b+    go :: forall b. Term b -> State (HS.HashSet SomeTerm) ()+    go t@ConTerm {} = add t+    go t@SymTerm {} = add t+    go t@(SubTerms ts) = do+      b <- exists t+      if b+        then return ()+        else do+          add t+          traverse_ goSome ts+{-# 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 $ someTerm <$> terms+{-# INLINEABLE termsSize #-}++-- | Compute the size of a term.+termSize :: Term a -> Int+termSize term = termsSize [term]+{-# INLINE termSize #-}
+ src/Grisette/Internal/SymPrim/Quantifier.hs view
@@ -0,0 +1,198 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Module      :   Grisette.Internal.SymPrim.Quantifier+-- 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.Quantifier+  ( forallSet,+    forallSym,+    existsSet,+    existsSym,+    forallFresh,+    existsFresh,+  )+where++import Data.Bifunctor (Bifunctor (first))+import qualified Data.HashSet as HS+import Data.List (sort)+import GHC.Stack (HasCallStack)+import Grisette.Internal.Core.Control.Monad.Union (Union)+import Grisette.Internal.Core.Data.Class.ExtractSym+  ( ExtractSym (extractSymMaybe),+  )+import Grisette.Internal.Core.Data.Class.GenSym+  ( Fresh,+    FreshT (FreshT),+    GenSym (fresh),+    MonadFresh,+    liftFresh,+  )+import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable)+import Grisette.Internal.Core.Data.Class.TryMerge (TryMerge, mrgSingle)+import Grisette.Internal.Core.Data.Class.UnionView (liftUnion, simpleMerge)+import Grisette.Internal.SymPrim.Prim.Internal.Term+  ( SomeTypedSymbol (SomeTypedSymbol),+    existsTerm,+    forallTerm,+  )+import Grisette.Internal.SymPrim.Prim.Model+  ( ConstantSymbolSet,+    SymbolSet (SymbolSet),+  )+import Grisette.Internal.SymPrim.SymBool (SymBool (SymBool))++-- $setup+-- >>> import Grisette.Core+-- >>> import Grisette.SymPrim+-- >>> import Grisette.Backend+-- >>> import Grisette.Lib.Base++-- | Forall quantifier over a set of constant symbols. Quantifier over functions+-- is not supported.+--+-- >>> let xsym = "x" :: TypedConstantSymbol Integer+-- >>> let ysym = "y" :: TypedConstantSymbol Integer+-- >>> let x = "x" :: SymInteger+-- >>> let y = "y" :: SymInteger+-- >>> forallSet (buildSymbolSet [xsym, ysym]) (x .== y)+-- (forall x :: Integer (forall y :: Integer (= x y)))+--+-- Only available with SBV 10.1.0 or later.+forallSet :: ConstantSymbolSet -> SymBool -> SymBool+forallSet (SymbolSet set) b =+  foldr+    ( \(SomeTypedSymbol s) (SymBool b') ->+        SymBool $ forallTerm s b'+    )+    b+    (sort $ HS.toList set)++-- | Forall quantifier over all symbolic constants in a value. Quantifier over+-- functions is not supported.+--+-- >>> let a = ["x", "y"] :: [SymInteger]+-- >>> forallSym a $ sum a .== 0+-- (forall x :: Integer (forall y :: Integer (= (+ x y) 0)))+--+-- Only available with sbv 10.1.0 or later.+forallSym :: (HasCallStack, ExtractSym a) => a -> SymBool -> SymBool+forallSym s b =+  case extractSymMaybe s of+    Just s' -> forallSet s' b+    Nothing ->+      error+        "Cannot use forall here. Only non-function symbols can be quantified."++-- | Exists quantifier over a set of constant symbols. Quantifier over functions+-- is not supported.+--+-- >>> let xsym = "x" :: TypedConstantSymbol Integer+-- >>> let ysym = "y" :: TypedConstantSymbol Integer+-- >>> let x = "x" :: SymInteger+-- >>> let y = "y" :: SymInteger+-- >>> existsSet (buildSymbolSet [xsym, ysym]) (x .== y)+-- (exists x :: Integer (exists y :: Integer (= x y)))+--+-- Only available with SBV 10.1.0 or later.+existsSet :: ConstantSymbolSet -> SymBool -> SymBool+existsSet (SymbolSet set) b =+  foldr+    ( \(SomeTypedSymbol s) (SymBool b') ->+        SymBool $ existsTerm s b'+    )+    b+    (sort $ HS.toList set)++-- | Exists quantifier over all symbolic constants in a value. Quantifier over+-- functions is not supported.+--+-- >>> let a = ["x", "y"] :: [SymInteger]+-- >>> existsSym a $ sum a .== 0+-- (exists x :: Integer (exists y :: Integer (= (+ x y) 0)))+--+-- Only available with sbv 10.1.0 or later.+existsSym :: (HasCallStack, ExtractSym a) => a -> SymBool -> SymBool+existsSym s b =+  case extractSymMaybe s of+    Just s' -> existsSet s' b+    Nothing ->+      error+        "Cannot use exists here. Only non-function symbols can be quantified."++freshTUnionToFreshUnion ::+  forall a.+  (Mergeable a) =>+  FreshT Union a ->+  Fresh (Union a)+freshTUnionToFreshUnion (FreshT v) =+  FreshT $ \ident index ->+    return $ simpleMerge $ first mrgSingle <$> v ident index++-- | Forall quantifier over symbolic constants in a freshly generated value.+-- Quantifier over functions is not supported.+--+-- >>> :{+-- x :: Fresh SymBool+-- x = forallFresh () $ \(a :: SymBool) ->+--       existsFresh () $ \(b :: SymBool) ->+--         mrgReturn $ a .== b+-- :}+--+-- >>> runFresh x "x"+-- (forall x@0 :: Bool (exists x@1 :: Bool (= x@0 x@1)))+--+-- Only available with sbv 10.1.0 or later.+forallFresh ::+  ( HasCallStack,+    ExtractSym v,+    MonadFresh m,+    GenSym spec v,+    TryMerge m+  ) =>+  spec ->+  (v -> FreshT Union SymBool) ->+  m SymBool+forallFresh spec f = do+  u <- fresh spec+  p <- liftFresh . fmap simpleMerge . freshTUnionToFreshUnion $ do+    liftUnion u >>= f+  mrgSingle $ forallSym u p++-- | Exists quantifier over symbolic constants in a freshly generated value.+-- Quantifier over functions is not supported.+--+-- >>> :{+-- x :: Fresh SymBool+-- x = forallFresh () $ \(a :: SymBool) ->+--       existsFresh () $ \(b :: SymBool) ->+--         mrgReturn $ a .== b+-- :}+--+-- >>> runFresh x "x"+-- (forall x@0 :: Bool (exists x@1 :: Bool (= x@0 x@1)))+--+-- Only available with sbv 10.1.0 or later.+existsFresh ::+  ( HasCallStack,+    ExtractSym v,+    MonadFresh m,+    GenSym spec v,+    TryMerge m+  ) =>+  spec ->+  (v -> FreshT Union SymBool) ->+  m SymBool+existsFresh spec f = do+  u <- fresh spec+  p <- liftFresh . fmap simpleMerge . freshTUnionToFreshUnion $ do+    liftUnion u >>= f+  mrgSingle $ existsSym u p
+ src/Grisette/Internal/SymPrim/SomeBV.hs view
@@ -0,0 +1,1738 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}++-- |+-- Module      :   Grisette.Internal.SymPrim.SomeBV+-- 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.SomeBV+  ( SomeBV (..),+    SomeBVKey,+    SomeBVException (..),++    -- * Constructing and pattern matching on SomeBV+    unsafeSomeBV,+    conBV,+    conBVView,+    pattern ConBV,+    symBV,+    ssymBV,+    isymBV,+    arbitraryBV,++    -- * Synonyms+    pattern SomeIntN,+    type SomeIntN,+    pattern SomeWordN,+    type SomeWordN,+    pattern SomeSymIntN,+    type SomeSymIntN,+    pattern SomeSymIntNKey,+    type SomeSymIntNKey,+    pattern SomeSymWordN,+    type SomeSymWordN,+    pattern SomeSymWordNKey,+    type SomeSymWordNKey,++    -- * Helpers for manipulating SomeBV+    unarySomeBV,+    unarySomeBVR1,+    binSomeBV,+    binSomeBVR1,+    binSomeBVR2,+    binSomeBVSafe,+    binSomeBVSafeR1,+    binSomeBVSafeR2,+  )+where++import Control.DeepSeq (NFData (rnf))+import Control.Exception (Exception, throw)+import Control.Monad (when)+import Control.Monad.Except (ExceptT, MonadError (throwError), runExceptT)+import Data.Bifunctor (Bifunctor (bimap))+import qualified Data.Binary as Binary+import Data.Bits+  ( Bits+      ( bit,+        bitSize,+        bitSizeMaybe,+        clearBit,+        complement,+        complementBit,+        isSigned,+        popCount,+        rotate,+        rotateL,+        rotateR,+        setBit,+        shift,+        shiftL,+        shiftR,+        testBit,+        unsafeShiftL,+        unsafeShiftR,+        xor,+        zeroBits,+        (.&.),+        (.|.)+      ),+    FiniteBits (countLeadingZeros, countTrailingZeros, finiteBitSize),+  )+import Data.Bytes.Get (MonadGet (getWord8))+import Data.Bytes.Put (MonadPut (putWord8))+import Data.Bytes.Serial (Serial (deserialize, serialize))+import Data.Data (Proxy (Proxy))+import Data.Hashable (Hashable (hashWithSalt))+import Data.Maybe (catMaybes, fromJust, isJust)+import qualified Data.Serialize as Cereal+import qualified Data.Text as T+import Data.Type.Equality (type (:~:) (Refl))+import GHC.Exception (Exception (displayException))+import GHC.Generics (Generic)+import GHC.Natural (Natural)+import GHC.TypeNats+  ( KnownNat,+    Nat,+    natVal,+    sameNat,+    type (+),+    type (<=),+  )+import Generics.Deriving (Default (Default))+import Grisette.Internal.Core.Control.Monad.Union (Union)+import Grisette.Internal.Core.Data.Class.AsKey+  ( AsKey (AsKey),+    KeyEq (keyEq),+    KeyHashable (keyHashWithSalt),+    shouldUseAsKeyError,+  )+import Grisette.Internal.Core.Data.Class.BitVector+  ( BV (bv, bvConcat, bvExt, bvSelect, bvSext, bvZext),+    SizedBV+      ( sizedBVConcat,+        sizedBVExt,+        sizedBVFromIntegral,+        sizedBVSelect,+        sizedBVSext,+        sizedBVZext+      ),+  )+import Grisette.Internal.Core.Data.Class.EvalSym+  ( EvalSym (evalSym),+  )+import Grisette.Internal.Core.Data.Class.ExtractSym+  ( ExtractSym (extractSymMaybe),+  )+import Grisette.Internal.Core.Data.Class.GenSym+  ( GenSym (fresh),+    GenSymSimple (simpleFresh),+  )+import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp (symIte))+import Grisette.Internal.Core.Data.Class.Mergeable+  ( Mergeable (rootStrategy),+    MergingStrategy (SimpleStrategy, SortedStrategy),+    wrapStrategy,+  )+import Grisette.Internal.Core.Data.Class.PPrint+  ( PPrint (pformat),+  )+import Grisette.Internal.Core.Data.Class.SafeDiv+  ( DivOr (divModOr, divOr, modOr, quotOr, quotRemOr, remOr),+    SafeDiv (safeDiv, safeDivMod, safeMod, safeQuot, safeQuotRem, safeRem),+  )+import Grisette.Internal.Core.Data.Class.SafeLinearArith+  ( SafeLinearArith (safeAdd, safeNeg, safeSub),+  )+import Grisette.Internal.Core.Data.Class.SafeSymRotate+  ( SafeSymRotate (safeSymRotateL, safeSymRotateR),+  )+import Grisette.Internal.Core.Data.Class.SafeSymShift+  ( SafeSymShift+      ( safeSymShiftL,+        safeSymShiftR,+        safeSymStrictShiftL,+        safeSymStrictShiftR+      ),+  )+import Grisette.Internal.Core.Data.Class.SignConversion+  ( SignConversion (toSigned, toUnsigned),+  )+import Grisette.Internal.Core.Data.Class.SimpleMergeable (mrgIf)+import Grisette.Internal.Core.Data.Class.Solvable+  ( Solvable (con, conView, isym, ssym, sym),+  )+import Grisette.Internal.Core.Data.Class.SubstSym+  ( SubstSym (substSym),+  )+import Grisette.Internal.Core.Data.Class.SymEq+  ( SymEq (symDistinct, (./=), (.==)),+  )+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, mrgSingle, tryMerge)+import Grisette.Internal.Core.Data.Class.UnionView (simpleMerge)+import Grisette.Internal.Core.Data.Symbol (Identifier, Symbol)+import Grisette.Internal.SymPrim.AllSyms (AllSyms (allSyms, allSymsS))+import Grisette.Internal.SymPrim.BV+  ( IntN,+    WordN,+  )+import Grisette.Internal.SymPrim.SymBV+  ( SymIntN,+    SymWordN,+  )+import Grisette.Internal.Utils.Parameterized+  ( KnownProof (KnownProof),+    LeqProof (LeqProof),+    NatRepr,+    SomePositiveNatRepr (SomePositiveNatRepr),+    knownAdd,+    leqAddPos,+    mkPositiveNatRepr,+    unsafeKnownProof,+    unsafeLeqProof,+  )+import Grisette.Lib.Data.Functor (mrgFmap)+import Language.Haskell.TH.Syntax (Lift (liftTyped))+import Test.QuickCheck (Arbitrary (arbitrary), Gen)+import Unsafe.Coerce (unsafeCoerce)++-- | An exception that would be thrown when operations are performed on+-- incompatible bit widths.+data SomeBVException = BitwidthMismatch | UndeterminedBitwidth T.Text+  deriving (Eq, Ord, Generic)+  deriving anyclass (Hashable, NFData)+  deriving+    ( Mergeable,+      ExtractSym,+      PPrint,+      SubstSym,+      EvalSym,+      SymEq,+      SymOrd,+      ToCon SomeBVException,+      ToSym SomeBVException+    )+    via (Default (SomeBVException))++instance Show SomeBVException where+  show BitwidthMismatch = "Bit width does not match"+  show (UndeterminedBitwidth msg) =+    "Cannot determine bit-width for literals: " <> T.unpack msg++instance Exception SomeBVException where+  displayException = show++class MaySomeBV bv where+  assignLitBitWidth :: (KnownNat n, 1 <= n) => SomeBVLit -> bv n++instance MaySomeBV IntN where+  assignLitBitWidth = \case+    SomeBVIntLit i -> fromInteger i+    SomeBVCondLit _ -> error "Should not happen"++instance MaySomeBV WordN where+  assignLitBitWidth = \case+    SomeBVIntLit i -> fromInteger i+    SomeBVCondLit _ -> error "Should not happen"++instance MaySomeBV SymIntN where+  assignLitBitWidth = \case+    SomeBVIntLit i -> fromInteger i+    SomeBVCondLit u -> simpleMerge $ do+      i <- u+      mrgSingle $ fromInteger i++instance MaySomeBV SymWordN where+  assignLitBitWidth = \case+    SomeBVIntLit i -> fromInteger i+    SomeBVCondLit u -> simpleMerge $ do+      i <- u+      mrgSingle $ fromInteger i++assignBitWidthList ::+  forall bv.+  (forall n. (KnownNat n, 1 <= n) => Num (bv n), MaySomeBV bv) =>+  T.Text ->+  [SomeBV bv] ->+  Either SomeBVException [SomeBV bv]+assignBitWidthList msg bvs = case allNonMaybeBitWidth of+  [] -> Left $ UndeterminedBitwidth msg+  (x : xs) ->+    if all (== x) xs+      then case allHasBitWidth of+        (SomeBV (i :: bv i) : _) -> Right $ fmap (assignSingleBitWidth i) bvs+        _ -> error "Should not happen"+      else Left BitwidthMismatch+  where+    maybeBitWidth :: SomeBV bv -> Maybe Int+    maybeBitWidth (SomeBV (_ :: bv n)) = Just $ fromIntegral $ natVal (Proxy @n)+    maybeBitWidth (SomeBVLit _) = Nothing+    allMaybeBitWidth = map maybeBitWidth bvs+    allNonMaybeBitWidth = catMaybes allMaybeBitWidth+    allHasBitWidth = filter (isJust . maybeBitWidth) bvs+    assignSingleBitWidth ::+      forall i. (KnownNat i, 1 <= i) => bv i -> SomeBV bv -> SomeBV bv+    assignSingleBitWidth _ s@(SomeBV _) = s+    assignSingleBitWidth _ (SomeBVLit i) = SomeBV (assignLitBitWidth i :: bv i)++class AssignBitWidth a where+  assignBitWidth :: T.Text -> a -> Either SomeBVException a++instance+  (forall n. (KnownNat n, 1 <= n) => Num (bv n), MaySomeBV bv) =>+  AssignBitWidth (SomeBV bv, SomeBV bv)+  where+  assignBitWidth msg (a, b) = do+    l <- assignBitWidthList msg [a, b]+    case l of+      [a', b'] -> Right (a', b')+      _ -> error "Should not happen"++instance+  (forall n. (KnownNat n, 1 <= n) => Num (bv n), MaySomeBV bv) =>+  AssignBitWidth (SomeBV bv, SomeBV bv, SomeBV bv)+  where+  assignBitWidth msg (a, b, c) = do+    l <- assignBitWidthList msg [a, b, c]+    case l of+      [a', b', c'] -> Right (a', b', c')+      _ -> error "Should not happen"++instance+  (forall n. (KnownNat n, 1 <= n) => Num (bv n), MaySomeBV bv) =>+  AssignBitWidth (SomeBV bv, SomeBV bv, SomeBV bv, SomeBV bv)+  where+  assignBitWidth msg (a, b, c, d) = do+    l <- assignBitWidthList msg [a, b, c, d]+    case l of+      [a', b', c', d'] -> Right (a', b', c', d')+      _ -> error "Should not happen"++-- $setup+-- >>> import Grisette.Core+-- >>> import Grisette.SymPrim++-- | Non-indexed bitvectors.+--+-- The creation of t'SomeBV' can be done with the `bv` function with a positive+-- bit width and a value:+--+-- >>> bv 4 0xf :: SomeBV IntN+-- 0xf+--+-- Operations on two t'SomeBV' values require the bitwidths to be the same. So+-- you should check for the bit width (via `finiteBitSize`) before performing+-- operations:+--+-- >>> bv 4 0x3 + bv 4 0x3 :: SomeBV IntN+-- 0x6+-- >>> bv 4 0x3 + bv 8 0x3 :: SomeBV IntN+-- *** Exception: Bit width does not match+-- ...+--+-- One exception is that the equality testing (both concrete and symbolic via+-- '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)+-- False+--+-- __Note__: t'SomeBV' can be constructed out of integer literals without the+-- bit width provided. Further binary operations will usually require at least+-- one operand has the bit-width, and will use that as the bit-width for the+-- result.+--+-- For example:+--+-- 3 :: SomeBV IntN+-- bvlit(3)+-- >>> bv 4 0x1 + 3 :: SomeBV IntN+-- 0x4+-- >>> 3 * bv 4 0x1  :: SomeBV IntN+-- 0x3+-- >>> 3 * 3 :: SomeBV IntN+-- *** Exception: Cannot determine bit-width for literals: (*)+-- ...+--+-- Some operations allows the literals to be used without the bit-width, such as+-- '(+)', '(-)', 'negate', 'toUnsigned', 'toSigned', '.&.', '.|.', 'xor',+-- 'complement', 'setBit', 'clearBit', 'complementBit', 'shiftL', and+-- 'unsafeShiftL'.+--+-- >>> 3 + 3 :: SomeBV IntN+-- bvlit(6)+data SomeBV bv where+  SomeBV :: (KnownNat n, 1 <= n) => bv n -> SomeBV bv+  SomeBVLit :: SomeBVLit -> SomeBV bv++-- | @t'SomeBV' bv@ type with identity equality.+type SomeBVKey bv = AsKey (SomeBV bv)++data SomeBVLit where+  SomeBVIntLit :: Integer -> SomeBVLit+  SomeBVCondLit :: Union Integer -> SomeBVLit+  deriving (Eq, Generic, Lift)+  deriving anyclass (NFData)+  deriving (Mergeable, ExtractSym, AllSyms) via (Default SomeBVLit)++instance Hashable SomeBVLit where+  hashWithSalt s (SomeBVIntLit i) = s `hashWithSalt` (0 :: Int) `hashWithSalt` i+  hashWithSalt _ (SomeBVCondLit _) =+    shouldUseAsKeyError "SomeBVLit (with SomeBVCondLit)" "hashWithSalt"++instance KeyEq SomeBVLit where+  keyEq (SomeBVIntLit l) (SomeBVIntLit r) = l == r+  keyEq (SomeBVCondLit l) (SomeBVCondLit r) = keyEq l r+  keyEq _ _ = False++instance KeyHashable SomeBVLit where+  keyHashWithSalt s (SomeBVIntLit i) = s `hashWithSalt` (0 :: Int) `hashWithSalt` i+  keyHashWithSalt s (SomeBVCondLit u) = s `hashWithSalt` (1 :: Int) `keyHashWithSalt` u++instance PPrint SomeBVLit where+  pformat (SomeBVIntLit i) = pformat i+  pformat (SomeBVCondLit u) = pformat u++toUnionInteger :: SomeBVLit -> Union Integer+toUnionInteger (SomeBVIntLit i) = mrgSingle i+toUnionInteger (SomeBVCondLit u) = u++instance Num SomeBVLit where+  SomeBVIntLit a + SomeBVIntLit b = SomeBVIntLit $ a + b+  l + r = SomeBVCondLit $ toUnionInteger l + toUnionInteger r+  SomeBVIntLit a - SomeBVIntLit b = SomeBVIntLit $ a - b+  l - r = SomeBVCondLit $ toUnionInteger l - toUnionInteger r+  SomeBVIntLit a * SomeBVIntLit b = SomeBVIntLit $ a * b+  l * r = SomeBVCondLit $ toUnionInteger l * toUnionInteger r+  negate (SomeBVIntLit a) = SomeBVIntLit $ negate a+  negate l = SomeBVCondLit $ negate $ toUnionInteger l+  abs (SomeBVIntLit a) = SomeBVIntLit $ abs a+  abs l = SomeBVCondLit $ abs $ toUnionInteger l+  signum (SomeBVIntLit a) = SomeBVIntLit $ signum a+  signum l = SomeBVCondLit $ signum $ toUnionInteger l+  fromInteger = SomeBVIntLit++instance Bits SomeBVLit where+  SomeBVIntLit l .&. SomeBVIntLit r = SomeBVIntLit $ l .&. r+  l .&. r = SomeBVCondLit $ do+    l <- toUnionInteger l+    r <- toUnionInteger r+    mrgSingle $ l .&. r+  SomeBVIntLit l .|. SomeBVIntLit r = SomeBVIntLit $ l .|. r+  l .|. r = SomeBVCondLit $ do+    l <- toUnionInteger l+    r <- toUnionInteger r+    mrgSingle $ l .|. r+  SomeBVIntLit l `xor` SomeBVIntLit r = SomeBVIntLit $ l `xor` r+  l `xor` r = SomeBVCondLit $ do+    l <- toUnionInteger l+    r <- toUnionInteger r+    mrgSingle $ l `xor` r+  complement (SomeBVIntLit l) = SomeBVIntLit $ complement l+  complement l = SomeBVCondLit $ do+    l <- toUnionInteger l+    mrgSingle $ complement l+  setBit (SomeBVIntLit l) i = SomeBVIntLit $ setBit l i+  setBit l i = SomeBVCondLit $ do+    l <- toUnionInteger l+    mrgSingle $ setBit l i+  clearBit (SomeBVIntLit l) i = SomeBVIntLit $ clearBit l i+  clearBit l i = SomeBVCondLit $ do+    l <- toUnionInteger l+    mrgSingle $ clearBit l i+  complementBit (SomeBVIntLit l) i = SomeBVIntLit $ complementBit l i+  complementBit l i = SomeBVCondLit $ do+    l <- toUnionInteger l+    mrgSingle $ complementBit l i+  shiftL (SomeBVIntLit a) i = SomeBVIntLit $ shiftL a i+  shiftL l i = SomeBVCondLit $ do+    l <- toUnionInteger l+    mrgSingle $ shiftL l i+  unsafeShiftL (SomeBVIntLit a) i = SomeBVIntLit $ unsafeShiftL a i+  unsafeShiftL l i = SomeBVCondLit $ do+    l <- toUnionInteger l+    mrgSingle $ unsafeShiftL l i+  shift = throw $ UndeterminedBitwidth "shift"+  rotate = throw $ UndeterminedBitwidth "rotate"+  bitSize = throw $ UndeterminedBitwidth "bitSize"+  bitSizeMaybe = throw $ UndeterminedBitwidth "bitSizeMaybe"+  isSigned = error "isSigned is not defined for SomeBVLit"+  testBit = throw $ UndeterminedBitwidth "testBit"+  bit = throw $ UndeterminedBitwidth "bit"+  popCount = throw $ UndeterminedBitwidth "popCount"++instance Show SomeBVLit where+  show (SomeBVIntLit i) = show i+  show (SomeBVCondLit u) = show u++instance Serial SomeBVLit where+  serialize (SomeBVIntLit i) = putWord8 0 >> serialize i+  serialize (SomeBVCondLit u) =+    putWord8 1 >> serialize u+  deserialize = do+    tag <- getWord8+    case tag of+      0 -> SomeBVIntLit <$> deserialize+      1 -> SomeBVCondLit <$> deserialize+      _ -> fail "Invalid tag"++instance Cereal.Serialize SomeBVLit where+  put = serialize+  get = deserialize++instance Binary.Binary SomeBVLit where+  put = serialize+  get = deserialize++instance+  (forall n. (KnownNat n, 1 <= n) => Serial (bv n)) =>+  Serial (SomeBV bv)+  where+  serialize (SomeBV (bv :: bv n)) =+    putWord8 0 >> serialize (natVal (Proxy @n)) >> serialize bv+  serialize (SomeBVLit i) = putWord8 1 >> serialize i+  deserialize = do+    tag <- getWord8+    case tag of+      0 -> do+        n :: Natural <- deserialize+        when (n == 0) $ fail "Invalid bit width"+        case mkPositiveNatRepr n of+          SomePositiveNatRepr (_ :: NatRepr x) -> do+            x <- deserialize @(bv x)+            return $ SomeBV x+      1 -> SomeBVLit <$> deserialize+      _ -> fail "Invalid tag"++instance+  (forall n. (KnownNat n, 1 <= n) => Serial (bv n)) =>+  Cereal.Serialize (SomeBV bv)+  where+  put = serialize+  get = deserialize++instance+  (forall n. (KnownNat n, 1 <= n) => Serial (bv n)) =>+  Binary.Binary (SomeBV bv)+  where+  put = serialize+  get = deserialize++instance+  ( forall n. (KnownNat n, 1 <= n) => Hashable (bv n),+    forall n. (KnownNat n, 1 <= n) => Num (bv n),+    MaySomeBV bv+  ) =>+  Hashable (SomeBV bv)+  where+  hashWithSalt s (SomeBV (bv :: bv n)) =+    s `hashWithSalt` (natVal (Proxy @n)) `hashWithSalt` bv+  hashWithSalt s (SomeBVLit i) = s `hashWithSalt` i+  {-# INLINE hashWithSalt #-}++instance+  ( forall n. (KnownNat n, 1 <= n) => KeyHashable (bv n),+    forall n. (KnownNat n, 1 <= n) => Num (bv n),+    MaySomeBV bv+  ) =>+  KeyHashable (SomeBV bv)+  where+  keyHashWithSalt s (SomeBV (bv :: bv n)) =+    s `hashWithSalt` (natVal (Proxy @n)) `keyHashWithSalt` bv+  keyHashWithSalt s (SomeBVLit i) = s `keyHashWithSalt` i+  {-# INLINE keyHashWithSalt #-}++instance+  (forall n. (KnownNat n, 1 <= n) => Lift (bv n)) =>+  Lift (SomeBV bv)+  where+  liftTyped (SomeBV bv) = [||SomeBV bv||]+  liftTyped (SomeBVLit i) = [||SomeBVLit i||]+  {-# INLINE liftTyped #-}++instance+  (forall n. (KnownNat n, 1 <= n) => Show (bv n)) =>+  Show (SomeBV bv)+  where+  show (SomeBV bv) = show bv+  show (SomeBVLit i) = "bvlit(" <> show i <> ")"+  {-# INLINE show #-}++-- , MaySomeBV bv++instance+  (forall n. (KnownNat n, 1 <= n) => NFData (bv n)) =>+  NFData (SomeBV bv)+  where+  rnf (SomeBV bv) = rnf bv+  rnf (SomeBVLit i) = rnf i+  {-# INLINE rnf #-}++instance+  ( forall n. (KnownNat n, 1 <= n) => KeyEq (bv n),+    forall n. (KnownNat n, 1 <= n) => Num (bv n),+    MaySomeBV bv+  ) =>+  KeyEq (SomeBV bv)+  where+  keyEq (SomeBV (l :: bv l)) (SomeBV (r :: bv r)) =+    case sameNat (Proxy @l) (Proxy @r) of+      Just Refl -> keyEq l r+      Nothing -> False+  keyEq (SomeBV (l :: bv l)) (SomeBVLit r) = keyEq l (assignLitBitWidth r)+  keyEq l r@SomeBV {} = keyEq r l+  keyEq _ _ = throw $ UndeterminedBitwidth "keyEq"+  {-# INLINE keyEq #-}++instance+  ( forall n. (KnownNat n, 1 <= n) => Eq (bv n),+    forall n. (KnownNat n, 1 <= n) => Num (bv n),+    MaySomeBV bv+  ) =>+  Eq (SomeBV bv)+  where+  SomeBV (l :: bv l) == SomeBV (r :: bv r) =+    case sameNat (Proxy @l) (Proxy @r) of+      Just Refl -> l == r+      Nothing -> False+  SomeBV (l :: bv l) == SomeBVLit r = l == assignLitBitWidth r+  l == r@SomeBV {} = r == l+  _ == _ = throw $ UndeterminedBitwidth "=="+  {-# INLINE (==) #-}+  SomeBV (l :: bv l) /= SomeBV (r :: bv r) =+    case sameNat (Proxy @l) (Proxy @r) of+      Just Refl -> l /= r+      Nothing -> True+  SomeBV (l :: bv l) /= SomeBVLit r = l /= assignLitBitWidth r+  l /= r@SomeBV {} = r /= l+  _ /= _ = throw $ UndeterminedBitwidth "/="+  {-# INLINE (/=) #-}++instance+  ( forall n. (KnownNat n, 1 <= n) => Ord (bv n),+    forall n. (KnownNat n, 1 <= n) => Num (bv n),+    MaySomeBV bv+  ) =>+  Ord (SomeBV bv)+  where+  (<) = binSomeBV (<) (const $ const $ throw $ UndeterminedBitwidth "<")+  {-# INLINE (<) #-}+  (<=) = binSomeBV (<=) (const $ const $ throw $ UndeterminedBitwidth "(<=)")+  {-# INLINE (<=) #-}+  (>) = binSomeBV (>) (const $ const $ throw $ UndeterminedBitwidth ">")+  {-# INLINE (>) #-}+  (>=) = binSomeBV (>=) (const $ const $ throw $ UndeterminedBitwidth "(>=)")+  {-# INLINE (>=) #-}+  max = binSomeBVR1 max (const $ const $ throw $ UndeterminedBitwidth "max")+  {-# INLINE max #-}+  min = binSomeBVR1 min (const $ const $ throw $ UndeterminedBitwidth "min")+  {-# INLINE min #-}+  compare =+    binSomeBV compare (const $ const $ throw $ UndeterminedBitwidth "compare")+  {-# INLINE compare #-}++instance (forall n. (KnownNat n, 1 <= n) => Num (bv n), MaySomeBV bv) => Num (SomeBV bv) where+  (+) = binSomeBVR1 (+) (+)+  {-# INLINE (+) #-}+  (-) = binSomeBVR1 (-) (-)+  {-# INLINE (-) #-}+  (*) = binSomeBVR1 (*) (const $ const $ throw $ UndeterminedBitwidth "(*)")+  {-# INLINE (*) #-}+  negate = unarySomeBVR1 negate negate+  {-# INLINE negate #-}+  abs = unarySomeBVR1 abs (const $ throw $ UndeterminedBitwidth "abs")+  {-# INLINE abs #-}+  signum = unarySomeBVR1 signum (const $ throw $ UndeterminedBitwidth "signum")+  {-# INLINE signum #-}+  fromInteger = SomeBVLit . SomeBVIntLit+  {-# INLINE fromInteger #-}++instance+  ( forall n. (KnownNat n, 1 <= n) => Bits (bv n),+    forall n. (KnownNat n, 1 <= n) => Num (bv n),+    MaySomeBV bv+  ) =>+  Bits (SomeBV bv)+  where+  (.&.) = binSomeBVR1 (.&.) (.&.)+  (.|.) = binSomeBVR1 (.|.) (.|.)+  xor = binSomeBVR1 xor xor+  complement = unarySomeBVR1 complement complement+  shift s i =+    unarySomeBVR1 (`shift` i) (const $ throw $ UndeterminedBitwidth "shift") s+  rotate s i =+    unarySomeBVR1 (`rotate` i) (const $ throw $ UndeterminedBitwidth "rotate") s+  zeroBits =+    error $+      "zeroBits is not defined for SomeBV as no bitwidth is known, use "+        <> "(bv <bitwidth> 0) or (SomeBV (zeroBits :: bv <bitwidth>)) instead"+  bit =+    error $+      "bit is not defined for SomeBV as no bitwidth is known, use "+        <> "(SomeBV (bit <bit> :: bv <bitwidth>)) instead"+  setBit s i = unarySomeBVR1 (`setBit` i) (`setBit` i) s+  clearBit s i = unarySomeBVR1 (`clearBit` i) (`clearBit` i) s+  complementBit s i = unarySomeBVR1 (`complementBit` i) (`complementBit` i) s+  testBit s i =+    unarySomeBV (`testBit` i) (const $ throw $ UndeterminedBitwidth "testBit") s+  bitSizeMaybe =+    unarySomeBV+      bitSizeMaybe+      (const $ throw $ UndeterminedBitwidth "bitSizeMaybe")+  bitSize =+    fromJust+      . unarySomeBV+        bitSizeMaybe+        (const $ throw $ UndeterminedBitwidth "bitSize")+  isSigned _ = isSigned (undefined :: bv 1)+  shiftL s i = unarySomeBVR1 (`shiftL` i) (`shiftL` i) s+  unsafeShiftL s i = unarySomeBVR1 (`unsafeShiftL` i) (`unsafeShiftL` i) s+  shiftR s i =+    unarySomeBVR1 (`shiftR` i) (const $ throw $ UndeterminedBitwidth "shiftR") s+  unsafeShiftR s i =+    unarySomeBVR1+      (`unsafeShiftR` i)+      (const $ throw $ UndeterminedBitwidth "unsafeShiftR")+      s+  rotateL s i =+    unarySomeBVR1+      (`rotateL` i)+      (const $ throw $ UndeterminedBitwidth "rotateL")+      s+  rotateR s i =+    unarySomeBVR1+      (`rotateR` i)+      (const $ throw $ UndeterminedBitwidth "rotateR")+      s+  popCount =+    unarySomeBV popCount (const $ throw $ UndeterminedBitwidth "popCount")++instance+  ( forall n. (KnownNat n, 1 <= n) => FiniteBits (bv n),+    forall n. (KnownNat n, 1 <= n) => Num (bv n),+    MaySomeBV bv+  ) =>+  FiniteBits (SomeBV bv)+  where+  finiteBitSize =+    unarySomeBV+      finiteBitSize+      (const $ throw $ UndeterminedBitwidth "finiteBitSize")+  {-# INLINE finiteBitSize #-}+  countLeadingZeros =+    unarySomeBV+      countLeadingZeros+      (const $ throw $ UndeterminedBitwidth "countLeadingZeros")+  {-# INLINE countLeadingZeros #-}+  countTrailingZeros =+    unarySomeBV+      countTrailingZeros+      (const $ throw $ UndeterminedBitwidth "countTrailingZeros")+  {-# INLINE countTrailingZeros #-}++instance+  (forall n. (KnownNat n, 1 <= n) => Enum (bv n)) =>+  Enum (SomeBV bv)+  where+  toEnum =+    error $+      "toEnum is not defined for SomeBV, use "+        <> "(SomeBV (toEnum <value> :: bv <bitwidth>)) instead"+  {-# INLINE toEnum #-}+  fromEnum =+    unarySomeBV fromEnum (const $ throw $ UndeterminedBitwidth "fromEnum")+  {-# INLINE fromEnum #-}++instance+  (forall n. (KnownNat n, 1 <= n) => Real (bv n), MaySomeBV bv) =>+  Real (SomeBV bv)+  where+  toRational =+    unarySomeBV toRational (const $ throw $ UndeterminedBitwidth "toRational")+  {-# INLINE toRational #-}++instance+  (forall n. (KnownNat n, 1 <= n) => Integral (bv n), MaySomeBV bv) =>+  Integral (SomeBV bv)+  where+  toInteger =+    unarySomeBV+      toInteger+      (const $ throw $ UndeterminedBitwidth "toInteger")+  {-# INLINE toInteger #-}+  quot = binSomeBVR1 quot (const $ throw $ UndeterminedBitwidth "quot")+  {-# INLINE quot #-}+  rem = binSomeBVR1 rem (const $ throw $ UndeterminedBitwidth "rem")+  {-# INLINE rem #-}+  div = binSomeBVR1 div (const $ throw $ UndeterminedBitwidth "div")+  {-# INLINE div #-}+  mod = binSomeBVR1 mod (const $ throw $ UndeterminedBitwidth "mod")+  {-# INLINE mod #-}+  quotRem = binSomeBVR2 quotRem (const $ throw $ UndeterminedBitwidth "quotRem")+  {-# INLINE quotRem #-}+  divMod = binSomeBVR2 divMod (const $ throw $ UndeterminedBitwidth "divMod")+  {-# INLINE divMod #-}++instance (SizedBV bv) => BV (SomeBV bv) where+  bvConcat (SomeBV (a :: bv l)) (SomeBV (b :: bv r)) =+    case ( leqAddPos (Proxy @l) (Proxy @r),+           knownAdd @l @r KnownProof KnownProof+         ) of+      (LeqProof, KnownProof) ->+        SomeBV $ sizedBVConcat a b+  bvConcat _ _ = throw $ UndeterminedBitwidth "bvConcat"+  {-# INLINE bvConcat #-}+  bvZext l (SomeBV (a :: bv n))+    | l < n = error "bvZext: trying to zero extend a value to a smaller size"+    | otherwise = res (Proxy @n)+    where+      n = fromIntegral $ natVal (Proxy @n)+      res :: forall (l :: Nat). Proxy l -> SomeBV bv+      res p =+        case ( unsafeKnownProof @l (fromIntegral l),+               unsafeLeqProof @1 @l,+               unsafeLeqProof @n @l+             ) of+          (KnownProof, LeqProof, LeqProof) -> SomeBV $ sizedBVZext p a+  bvZext _ _ = throw $ UndeterminedBitwidth "bvZext"+  {-# INLINE bvZext #-}+  bvSext l (SomeBV (a :: bv n))+    | l < n = error "bvSext: trying to zero extend a value to a smaller size"+    | otherwise = res (Proxy @n)+    where+      n = fromIntegral $ natVal (Proxy @n)+      res :: forall (l :: Nat). Proxy l -> SomeBV bv+      res p =+        case ( unsafeKnownProof @l (fromIntegral l),+               unsafeLeqProof @1 @l,+               unsafeLeqProof @n @l+             ) of+          (KnownProof, LeqProof, LeqProof) -> SomeBV $ sizedBVSext p a+  bvSext _ _ = throw $ UndeterminedBitwidth "bvSext"+  {-# INLINE bvSext #-}+  bvExt l (SomeBV (a :: bv n))+    | l < n = error "bvExt: trying to zero extend a value to a smaller size"+    | otherwise = res (Proxy @n)+    where+      n = fromIntegral $ natVal (Proxy @n)+      res :: forall (l :: Nat). Proxy l -> SomeBV bv+      res p =+        case ( unsafeKnownProof @l (fromIntegral l),+               unsafeLeqProof @1 @l,+               unsafeLeqProof @n @l+             ) of+          (KnownProof, LeqProof, LeqProof) -> SomeBV $ sizedBVExt p a+  bvExt _ _ = throw $ UndeterminedBitwidth "bvExt"+  {-# INLINE bvExt #-}+  bvSelect ix w (SomeBV (a :: bv n))+    | ix + w > n =+        error $+          "bvSelect: trying to select a bitvector outside the bounds, "+            <> "ix = "+            <> show ix+            <> ", w = "+            <> show w+            <> ", n = "+            <> show n+    | w == 0 = error "bvSelect: trying to select a bitvector of size 0"+    | otherwise = res (Proxy @n) (Proxy @n)+    where+      n = fromIntegral $ natVal (Proxy @n)+      res :: forall (w :: Nat) (ix :: Nat). Proxy w -> Proxy ix -> SomeBV bv+      res _ _ =+        case ( unsafeKnownProof @ix (fromIntegral ix),+               unsafeKnownProof @w (fromIntegral w),+               unsafeLeqProof @1 @w,+               unsafeLeqProof @(ix + w) @n+             ) of+          (KnownProof, KnownProof, LeqProof, LeqProof) ->+            SomeBV $ sizedBVSelect (Proxy @ix) (Proxy @w) a+  bvSelect _ _ _ = throw $ UndeterminedBitwidth "bvSelect"+  bv n i = unsafeSomeBV n $ \_ -> sizedBVFromIntegral i+  {-# INLINE bv #-}++instance+  (forall n. (KnownNat n, 1 <= n) => EvalSym (bv n)) =>+  EvalSym (SomeBV bv)+  where+  evalSym fillDefault model = unarySomeBVR1 (evalSym fillDefault model) id+  {-# INLINE evalSym #-}++instance+  (forall n. (KnownNat n, 1 <= n) => ExtractSym (bv n)) =>+  ExtractSym (SomeBV bv)+  where+  extractSymMaybe = unarySomeBV extractSymMaybe extractSymMaybe+  {-# INLINE extractSymMaybe #-}++instance+  (forall n. (KnownNat n, 1 <= n) => PPrint (bv n)) =>+  PPrint (SomeBV bv)+  where+  pformat (SomeBV bv) = pformat bv+  pformat (SomeBVLit i) = "bvlit(" <> pformat i <> ")"+  {-# INLINE pformat #-}++data CompileTimeNat where+  CompileTimeNat :: (KnownNat n, 1 <= n) => Proxy n -> CompileTimeNat++instance Show CompileTimeNat where+  show (CompileTimeNat (Proxy :: Proxy n)) = show (natVal (Proxy @n))+  {-# INLINE show #-}++instance Eq CompileTimeNat where+  CompileTimeNat (Proxy :: Proxy n) == CompileTimeNat (Proxy :: Proxy m) =+    case sameNat (Proxy @n) (Proxy @m) of+      Just Refl -> True+      Nothing -> False+  {-# INLINE (==) #-}++instance Ord CompileTimeNat where+  compare+    (CompileTimeNat (Proxy :: Proxy n))+    (CompileTimeNat (Proxy :: Proxy m)) =+      compare (natVal (Proxy @n)) (natVal (Proxy @m))+  {-# INLINE compare #-}++instance+  (forall n. (KnownNat n, 1 <= n) => Mergeable (bv n)) =>+  Mergeable (SomeBV bv)+  where+  rootStrategy =+    SortedStrategy @(Maybe CompileTimeNat)+      ( \case+          (SomeBVLit _) -> Nothing+          (SomeBV (_ :: bv n)) -> Just (CompileTimeNat (Proxy @n))+      )+      ( \case+          Nothing -> SimpleStrategy $+            \c (SomeBVLit l) (SomeBVLit r) ->+              SomeBVLit $+                SomeBVCondLit $+                  mrgIf c (toUnionInteger l) (toUnionInteger r)+          Just (CompileTimeNat (_ :: proxy n)) ->+            wrapStrategy+              (rootStrategy @(bv n))+              SomeBV+              (\(SomeBV x) -> unsafeCoerce x)+      )++-- | The 'symDistinct' instance for t'SomeBV' will have the following behavior:+--+-- * If the list is empty or has only one element, it will return 'True'.+-- * If none of the elements have a bit-width, it will throw+--   'UndeterminedBitwidth' exception.+-- * If the elements have different bit-widths, it will throw a+--   'BitwidthMismatch' exception.+-- * If there are at least one element have a bit-width, and all elements with+--   known bit-width have the same bit-width, it will generate a single symbolic+--   formula using @distinct@.+instance+  ( forall n. (KnownNat n, 1 <= n) => SymEq (bv n),+    forall n. (KnownNat n, 1 <= n) => Num (bv n),+    MaySomeBV bv+  ) =>+  SymEq (SomeBV bv)+  where+  SomeBV (l :: bv l) .== SomeBV (r :: bv r) =+    case sameNat (Proxy @l) (Proxy @r) of+      Just Refl -> l .== r+      Nothing -> con False+  SomeBV (l :: bv l) .== SomeBVLit r = l .== assignLitBitWidth r+  SomeBVLit l .== SomeBV (r :: bv r) = assignLitBitWidth l .== r+  SomeBVLit _ .== SomeBVLit _ = throw $ UndeterminedBitwidth ".=="+  {-# INLINE (.==) #-}+  SomeBV (l :: bv l) ./= SomeBV (r :: bv r) =+    case sameNat (Proxy @l) (Proxy @r) of+      Just Refl -> l ./= r+      Nothing -> con True+  SomeBV (l :: bv l) ./= SomeBVLit r = l ./= assignLitBitWidth r+  SomeBVLit l ./= SomeBV (r :: bv r) = assignLitBitWidth l ./= r+  SomeBVLit _ ./= SomeBVLit _ = throw $ UndeterminedBitwidth "./="+  symDistinct l = case l of+    [] -> con True+    [_] -> con True+    _ -> case assignBitWidthList "symDistinct" l of+      Right (SomeBV (a :: bv a) : l) -> symDistinct $ a : go l+        where+          go :: [SomeBV bv] -> [bv a]+          go [] = []+          go (SomeBV (x :: bv x) : xs) = case sameNat (Proxy @x) (Proxy @a) of+            Just Refl -> x : go xs+            Nothing -> error "Should not happen"+          go (SomeBVLit _ : _) = error "Should not happen"+      Right _ -> error "Should not happen"+      Left UndeterminedBitwidth {} -> throw $ UndeterminedBitwidth "symDistinct"+      Left BitwidthMismatch -> throw BitwidthMismatch+  {-# INLINE (./=) #-}++instance+  ( forall n. (KnownNat n, 1 <= n) => SymOrd (bv n),+    forall n. (KnownNat n, 1 <= n) => Num (bv n),+    MaySomeBV bv+  ) =>+  SymOrd (SomeBV bv)+  where+  (.<) = binSomeBV (.<) (const $ const $ throw $ UndeterminedBitwidth "(.<)")+  {-# INLINE (.<) #-}+  (.<=) = binSomeBV (.<=) (const $ const $ throw $ UndeterminedBitwidth "(.<=)")+  {-# INLINE (.<=) #-}+  (.>) = binSomeBV (.>) (const $ const $ throw $ UndeterminedBitwidth "(.>)")+  {-# INLINE (.>) #-}+  (.>=) = binSomeBV (.>=) (const $ const $ throw $ UndeterminedBitwidth "(.>=)")+  {-# INLINE (.>=) #-}+  symCompare =+    binSomeBV+      symCompare+      (const $ const $ throw $ UndeterminedBitwidth "symCompare")+  {-# INLINE symCompare #-}++instance+  (forall n. (KnownNat n, 1 <= n) => SubstSym (bv n)) =>+  SubstSym (SomeBV bv)+  where+  substSym c s = unarySomeBVR1 (substSym c s) id+  {-# INLINE substSym #-}++instance+  ( KnownNat n,+    1 <= n,+    forall m. (KnownNat m, 1 <= m) => GenSym () (bv m),+    Mergeable (SomeBV bv)+  ) =>+  GenSym (Proxy n) (SomeBV bv)+  where+  fresh _ =+    (\(i :: Union (bv n)) -> mrgFmap SomeBV i) <$> fresh ()+  {-# INLINE fresh #-}++instance+  ( KnownNat n,+    1 <= n,+    forall m. (KnownNat m, 1 <= m) => GenSymSimple () (bv m),+    Mergeable (SomeBV bv)+  ) =>+  GenSymSimple (Proxy n) (SomeBV bv)+  where+  simpleFresh _ = (\(i :: bv n) -> SomeBV i) <$> simpleFresh ()+  {-# INLINE simpleFresh #-}++instance+  ( forall m. (KnownNat m, 1 <= m) => GenSym () (bv m),+    Mergeable (SomeBV bv)+  ) =>+  GenSym (SomeBV bv) (SomeBV bv)+  where+  fresh (SomeBV (_ :: bv x)) = fresh (Proxy @x)+  fresh (SomeBVLit _) = throw $ UndeterminedBitwidth "fresh"+  {-# INLINE fresh #-}++instance+  ( forall m. (KnownNat m, 1 <= m) => GenSymSimple () (bv m),+    Mergeable (SomeBV bv)+  ) =>+  GenSymSimple (SomeBV bv) (SomeBV bv)+  where+  simpleFresh (SomeBV (_ :: bv x)) = simpleFresh (Proxy @x)+  simpleFresh (SomeBVLit _) = throw $ UndeterminedBitwidth "simpleFresh"+  {-# INLINE simpleFresh #-}++instance+  ( forall n. (KnownNat n, 1 <= n) => GenSym () (bv n),+    Mergeable (SomeBV bv)+  ) =>+  GenSym Int (SomeBV bv)+  where+  fresh n+    | n <= 0 = error "fresh: cannot generate a bitvector of non-positive size"+    | otherwise = case mkPositiveNatRepr (fromIntegral n) of+        SomePositiveNatRepr (_ :: NatRepr x) -> fresh (Proxy @x)+  {-# INLINE fresh #-}++instance+  ( forall n. (KnownNat n, 1 <= n) => GenSymSimple () (bv n),+    Mergeable (SomeBV bv)+  ) =>+  GenSymSimple Int (SomeBV bv)+  where+  simpleFresh n+    | n <= 0 = error "fresh: cannot generate a bitvector of non-positive size"+    | otherwise = case mkPositiveNatRepr (fromIntegral n) of+        SomePositiveNatRepr (_ :: NatRepr x) -> simpleFresh (Proxy @x)+  {-# INLINE simpleFresh #-}++instance+  ( forall n. (KnownNat n, 1 <= n) => SignConversion (ubv n) (sbv n),+    -- Add this to help the type checker resolve the functional dependency+    SignConversion (ubv 1) (sbv 1)+  ) =>+  SignConversion (SomeBV ubv) (SomeBV sbv)+  where+  toSigned (SomeBV (n :: ubv n)) = SomeBV (toSigned n :: sbv n)+  toSigned (SomeBVLit i) = SomeBVLit i+  {-# INLINE toSigned #-}+  toUnsigned (SomeBV (n :: sbv n)) = SomeBV (toUnsigned n :: ubv n)+  toUnsigned (SomeBVLit i) = SomeBVLit i+  {-# INLINE toUnsigned #-}++instance+  (forall n. (KnownNat n, 1 <= n) => ToCon (sbv n) (cbv n)) =>+  ToCon (SomeBV sbv) (SomeBV cbv)+  where+  toCon (SomeBV (n :: sbv n)) = SomeBV <$> (toCon n :: Maybe (cbv n))+  toCon (SomeBVLit i) = Just $ SomeBVLit i+  {-# INLINE toCon #-}++instance+  (forall n. (KnownNat n, 1 <= n) => ToSym (cbv n) (sbv n)) =>+  ToSym (SomeBV cbv) (SomeBV sbv)+  where+  toSym (SomeBV (n :: cbv n)) = SomeBV (toSym n :: sbv n)+  toSym (SomeBVLit i) = SomeBVLit i+  {-# INLINE toSym #-}++divRemOrBase0 ::+  ( forall n.+    (KnownNat n, 1 <= n) =>+    (bv n, bv n) ->+    bv n ->+    bv n ->+    (bv n, bv n)+  ) ->+  (SomeBV bv, SomeBV bv) ->+  SomeBV bv ->+  SomeBV bv ->+  (SomeBV bv, SomeBV bv)+divRemOrBase0+  f+  (SomeBV (dd :: bv dd), SomeBV (dm :: bv dm))+  (SomeBV (a :: bv a))+  (SomeBV (b :: bv b)) =+    case ( sameNat (Proxy @a) (Proxy @b),+           sameNat (Proxy @a) (Proxy @dd),+           sameNat (Proxy @a) (Proxy @dm)+         ) of+      (Just Refl, Just Refl, Just Refl) -> bimap SomeBV SomeBV $ f (dd, dm) a b+      _ -> error "Should not happen"+divRemOrBase0 _ _ _ _ = error "Should not happen"+{-# INLINE divRemOrBase0 #-}++divRemOrBase ::+  (forall n. (KnownNat n, 1 <= n) => Num (bv n), MaySomeBV bv) =>+  ( forall n.+    (KnownNat n, 1 <= n) =>+    (bv n, bv n) ->+    bv n ->+    bv n ->+    (bv n, bv n)+  ) ->+  (SomeBV bv, SomeBV bv) ->+  SomeBV bv ->+  SomeBV bv ->+  (SomeBV bv, SomeBV bv)+divRemOrBase f (a, b) c d =+  case assignBitWidth "divRemOrBase" (a, b, c, d) of+    Right (a', b', c', d') -> divRemOrBase0 f (a', b') c' d'+    Left e -> throw e++instance+  ( forall n. (KnownNat n, 1 <= n) => DivOr (bv n),+    forall n. (KnownNat n, 1 <= n) => Num (bv n),+    MaySomeBV bv+  ) =>+  DivOr (SomeBV bv)+  where+  divOr = ternSomeBVR1 divOr+  {-# INLINE divOr #-}+  modOr = ternSomeBVR1 modOr+  {-# INLINE modOr #-}+  quotOr = ternSomeBVR1 quotOr+  {-# INLINE quotOr #-}+  remOr = ternSomeBVR1 remOr+  {-# INLINE remOr #-}+  divModOr = divRemOrBase divModOr+  {-# INLINE divModOr #-}+  quotRemOr = divRemOrBase quotRemOr+  {-# INLINE quotRemOr #-}++instance+  ( forall n.+    (KnownNat n, 1 <= n) =>+    SafeDiv e (bv n) (ExceptT e m),+    MonadError (Either SomeBVException e) m,+    TryMerge m,+    Mergeable e,+    forall n. (KnownNat n, 1 <= n) => Num (bv n),+    MaySomeBV bv+  ) =>+  SafeDiv (Either SomeBVException e) (SomeBV bv) m+  where+  safeDiv =+    binSomeBVSafeR1+      (safeDiv @e)+      (const $ const $ throwError $ Left $ UndeterminedBitwidth "safeDiv")+  {-# INLINE safeDiv #-}+  safeMod =+    binSomeBVSafeR1+      (safeMod @e)+      (const $ const $ throwError $ Left $ UndeterminedBitwidth "safeMod")+  {-# INLINE safeMod #-}+  safeQuot =+    binSomeBVSafeR1+      (safeQuot @e)+      (const $ const $ throwError $ Left $ UndeterminedBitwidth "safeQuot")+  {-# INLINE safeQuot #-}+  safeRem =+    binSomeBVSafeR1+      (safeRem @e)+      (const $ const $ throwError $ Left $ UndeterminedBitwidth "safeRem")+  {-# INLINE safeRem #-}+  safeDivMod =+    binSomeBVSafeR2+      (safeDivMod @e)+      (const $ const $ throwError $ Left $ UndeterminedBitwidth "safeDivMod")+  {-# INLINE safeDivMod #-}+  safeQuotRem =+    binSomeBVSafeR2+      (safeQuotRem @e)+      (const $ const $ throwError $ Left $ UndeterminedBitwidth "safeQuotRem")+  {-# INLINE safeQuotRem #-}++instance+  ( forall n.+    (KnownNat n, 1 <= n) =>+    SafeLinearArith e (bv n) (ExceptT e m),+    MonadError (Either SomeBVException e) m,+    TryMerge m,+    Mergeable e,+    forall n. (KnownNat n, 1 <= n) => Num (bv n),+    MaySomeBV bv+  ) =>+  SafeLinearArith (Either SomeBVException e) (SomeBV bv) m+  where+  safeAdd =+    binSomeBVSafeR1+      (safeAdd @e)+      (const $ const $ throwError $ Left $ UndeterminedBitwidth "safeAdd")+  {-# INLINE safeAdd #-}+  safeSub =+    binSomeBVSafeR1+      (safeSub @e)+      (const $ const $ throwError $ Left $ UndeterminedBitwidth "safeSub")+  {-# INLINE safeSub #-}+  safeNeg =+    unarySomeBV+      ( \v ->+          mrgFmap SomeBV $+            runExceptT (safeNeg @e v) >>= either (throwError . Right) pure+      )+      (const $ throwError $ Left $ UndeterminedBitwidth "safeNeg")+  {-# INLINE safeNeg #-}++instance+  ( forall n. (KnownNat n, 1 <= n) => SymShift (bv n),+    forall n. (KnownNat n, 1 <= n) => Num (bv n),+    MaySomeBV bv+  ) =>+  SymShift (SomeBV bv)+  where+  symShift =+    binSomeBVR1+      symShift+      (const $ const $ throw $ UndeterminedBitwidth "safeShift")+  {-# INLINE symShift #-}+  symShiftNegated =+    binSomeBVR1+      symShiftNegated+      (const $ const $ throw $ UndeterminedBitwidth "safeShiftNegated")+  {-# INLINE symShiftNegated #-}++instance+  ( forall n. (KnownNat n, 1 <= n) => SymRotate (bv n),+    forall n. (KnownNat n, 1 <= n) => Num (bv n),+    MaySomeBV bv+  ) =>+  SymRotate (SomeBV bv)+  where+  symRotate =+    binSomeBVR1+      symRotate+      (const $ const $ throw $ UndeterminedBitwidth "safeRotate")+  {-# INLINE symRotate #-}+  symRotateNegated =+    binSomeBVR1+      symRotateNegated+      (const $ const $ throw $ UndeterminedBitwidth "safeRotateNegated")+  {-# INLINE symRotateNegated #-}++instance+  ( forall n.+    (KnownNat n, 1 <= n) =>+    SafeSymShift e (bv n) (ExceptT e m),+    MonadError (Either SomeBVException e) m,+    TryMerge m,+    Mergeable e,+    forall n. (KnownNat n, 1 <= n) => Num (bv n),+    MaySomeBV bv+  ) =>+  SafeSymShift (Either SomeBVException e) (SomeBV bv) m+  where+  safeSymShiftL =+    binSomeBVSafeR1+      (safeSymShiftL @e)+      (const $ const $ throwError $ Left $ UndeterminedBitwidth "safeSymShiftL")+  {-# INLINE safeSymShiftL #-}+  safeSymShiftR =+    binSomeBVSafeR1+      (safeSymShiftR @e)+      (const $ const $ throwError $ Left $ UndeterminedBitwidth "safeSymShiftR")+  {-# INLINE safeSymShiftR #-}+  safeSymStrictShiftL =+    binSomeBVSafeR1+      (safeSymStrictShiftL @e)+      (const $ const $ throwError $ Left $ UndeterminedBitwidth "safeSymStrictShiftL")+  {-# INLINE safeSymStrictShiftL #-}+  safeSymStrictShiftR =+    binSomeBVSafeR1+      (safeSymStrictShiftR @e)+      (const $ const $ throwError $ Left $ UndeterminedBitwidth "safeSymStrictShiftR")+  {-# INLINE safeSymStrictShiftR #-}++instance+  ( forall n.+    (KnownNat n, 1 <= n) =>+    SafeSymRotate e (bv n) (ExceptT e m),+    MonadError (Either SomeBVException e) m,+    TryMerge m,+    Mergeable e,+    forall n. (KnownNat n, 1 <= n) => Num (bv n),+    MaySomeBV bv+  ) =>+  SafeSymRotate (Either SomeBVException e) (SomeBV bv) m+  where+  safeSymRotateL =+    binSomeBVSafeR1+      (safeSymRotateL @e)+      (const $ const $ throwError $ Left $ UndeterminedBitwidth "safeSymRotateL")+  {-# INLINE safeSymRotateL #-}+  safeSymRotateR =+    binSomeBVSafeR1+      (safeSymRotateR @e)+      (const $ const $ throwError $ Left $ UndeterminedBitwidth "safeSymRotateR")+  {-# INLINE safeSymRotateR #-}++instance+  ( forall n. (KnownNat n, 1 <= n) => ITEOp (bv n),+    forall n. (KnownNat n, 1 <= n) => Num (bv n),+    MaySomeBV bv+  ) =>+  ITEOp (SomeBV bv)+  where+  symIte cond =+    binSomeBVR1+      (symIte cond)+      (\l r -> SomeBVCondLit $ mrgIf cond (toUnionInteger l) (toUnionInteger r))++instance+  ( forall n. (KnownNat n, 1 <= n) => AllSyms (bv n),+    MaySomeBV bv+  ) =>+  AllSyms (SomeBV bv)+  where+  allSyms = unarySomeBV allSyms allSyms+  {-# INLINE allSyms #-}+  allSymsS = unarySomeBV allSymsS allSymsS+  {-# INLINE allSymsS #-}++-- Synonyms++-- | Type synonym for t'SomeBV' for concrete signed bitvectors.+type SomeIntN = SomeBV IntN++-- | Pattern synonym for t'SomeBV' for concrete signed bitvectors.+pattern SomeIntN :: () => (KnownNat n, 1 <= n) => IntN n -> SomeIntN+pattern SomeIntN a = SomeBV a++-- | Type synonym for t'SomeBV' for concrete unsigned bitvectors.+type SomeWordN = SomeBV WordN++-- | Pattern synonym for t'SomeBV' for concrete unsigned bitvectors.+pattern SomeWordN :: () => (KnownNat n, 1 <= n) => WordN n -> SomeWordN+pattern SomeWordN a = SomeBV a++-- | Type synonym for t'SomeBV' for symbolic signed bitvectors.+type SomeSymIntN = SomeBV SymIntN++-- | 'SomeSymIntN' with identity equality.+type SomeSymIntNKey = SomeBVKey SymIntN++-- | Pattern synonym for t'SomeBV' for symbolic signed bitvectors.+pattern SomeSymIntN :: () => (KnownNat n, 1 <= n) => SymIntN n -> SomeSymIntN+pattern SomeSymIntN a = SomeBV a++pattern SomeSymIntNKey :: () => (KnownNat n, 1 <= n) => SymIntN n -> SomeSymIntNKey+pattern SomeSymIntNKey a = AsKey (SomeBV a)++-- | Type synonym for t'SomeBV' for symbolic unsigned bitvectors.+type SomeSymWordN = SomeBV SymWordN++-- | 'SomeSymWordN' with identity equality.+type SomeSymWordNKey = SomeBVKey SymWordN++-- | Pattern synonym for t'SomeBV' for symbolic unsigned bitvectors.+pattern SomeSymWordN :: () => (KnownNat n, 1 <= n) => SymWordN n -> SomeSymWordN+pattern SomeSymWordN a = SomeBV a++pattern SomeSymWordNKey :: () => (KnownNat n, 1 <= n) => SymWordN n -> SomeSymWordNKey+pattern SomeSymWordNKey a = AsKey (SomeBV a)++-- Construction++-- | Construct a t'SomeBV' with a given run-time bitwidth and a polymorphic+-- value for the underlying bitvector.+unsafeSomeBV ::+  forall bv.+  Int ->+  (forall proxy n. (KnownNat n, 1 <= n) => proxy n -> bv n) ->+  SomeBV bv+unsafeSomeBV n i+  | n <= 0 = error "unsafeBV: trying to create a bitvector of non-positive size"+  | otherwise = case mkPositiveNatRepr (fromIntegral n) of+      SomePositiveNatRepr (_ :: NatRepr x) -> SomeBV (i (Proxy @x))+{-# INLINE unsafeSomeBV #-}++-- | Construct a symbolic t'SomeBV' with a given concrete t'SomeBV'. Similar to+-- 'con' but for t'SomeBV'.+--+-- >>> a = bv 8 0x12 :: SomeIntN+-- >>> conBV a :: SomeSymIntN+-- 0x12+conBV ::+  forall cbv bv.+  ( forall n. (KnownNat n, 1 <= n) => Solvable (cbv n) (bv n),+    Solvable (cbv 1) (bv 1)+  ) =>+  SomeBV cbv ->+  SomeBV bv+conBV (SomeBV (v :: cbv n)) = SomeBV $ con @(cbv n) @(bv n) v+conBV (SomeBVLit i) = SomeBVLit i++-- | View pattern for symbolic t'SomeBV' to see if it contains a concrete value+-- and extract it. Similar to 'conView' but for t'SomeBV'.+--+-- >>> conBVView (bv 8 0x12 :: SomeSymIntN)+-- Just 0x12+-- >>> conBVView (ssymBV 4 "a" :: SomeSymIntN)+-- Nothing+conBVView ::+  forall cbv bv.+  ( forall n. (KnownNat n, 1 <= n) => Solvable (cbv n) (bv n),+    Solvable (cbv 1) (bv 1)+  ) =>+  SomeBV bv ->+  Maybe (SomeBV cbv)+conBVView (SomeBV (bv :: bv n)) = case conView @(cbv n) bv of+  Just c -> Just $ SomeBV c+  Nothing -> Nothing+conBVView (SomeBVLit i) = Just $ SomeBVLit i++-- | Pattern synonym for symbolic t'SomeBV' to see if it contains a concrete+-- value and extract it. Similar to 'Grisette.Core.Con' but for t'SomeBV'.+--+-- >>> case (bv 8 0x12 :: SomeSymIntN) of { ConBV c -> c; _ -> error "impossible" }+-- 0x12+pattern ConBV ::+  forall cbv bv.+  ( forall n. (KnownNat n, 1 <= n) => Solvable (cbv n) (bv n),+    Solvable (cbv 1) (bv 1)+  ) =>+  SomeBV cbv ->+  SomeBV bv+pattern ConBV c <- (conBVView -> Just c)+  where+    ConBV c = conBV c++-- | Construct a symbolic t'SomeBV' with a given run-time bitwidth and a symbol.+-- Similar to 'sym' but for t'SomeBV'.+--+-- >>> symBV 8 "a" :: SomeSymIntN+-- a+symBV ::+  forall cbv bv.+  ( forall n. (KnownNat n, 1 <= n) => Solvable (cbv n) (bv n),+    Solvable (cbv 1) (bv 1)+  ) =>+  Int ->+  Symbol ->+  SomeBV bv+symBV n s = unsafeSomeBV n $ \(_ :: proxy n) -> sym @(cbv n) s++-- | Construct a symbolic t'SomeBV' with a given run-time bitwidth and an+-- identifier. Similar to 'ssym' but for t'SomeBV'.+--+-- >>> ssymBV 8 "a" :: SomeSymIntN+-- a+ssymBV ::+  forall cbv bv.+  ( forall n. (KnownNat n, 1 <= n) => Solvable (cbv n) (bv n),+    Solvable (cbv 1) (bv 1)+  ) =>+  Int ->+  Identifier ->+  SomeBV bv+ssymBV n s = unsafeSomeBV n $ \(_ :: proxy n) -> ssym @(cbv n) s++-- | Construct a symbolic t'SomeBV' with a given run-time bitwidth, an identifier+-- and an index. Similar to 'isym' but for t'SomeBV'.+--+-- >>> isymBV 8 "a" 1 :: SomeSymIntN+-- a@1+isymBV ::+  forall cbv bv.+  ( forall n. (KnownNat n, 1 <= n) => Solvable (cbv n) (bv n),+    Solvable (cbv 1) (bv 1)+  ) =>+  Int ->+  Identifier ->+  Int ->+  SomeBV bv+isymBV n s i = unsafeSomeBV n $ \(_ :: proxy n) -> isym @(cbv n) s i++-- | Generate an arbitrary t'SomeBV' with a given run-time bitwidth.+arbitraryBV ::+  forall bv.+  (forall n. (KnownNat n, 1 <= n) => Arbitrary (bv n)) =>+  Int ->+  Gen (SomeBV bv)+arbitraryBV n+  | n <= 0 =+      error "arbitraryBV: trying to create a bitvector of non-positive size"+  | otherwise = case mkPositiveNatRepr (fromIntegral n) of+      SomePositiveNatRepr (_ :: NatRepr x) -> do+        v <- arbitrary :: Gen (bv x)+        return $ SomeBV v++-- Helpers++-- | Lift a unary operation on sized bitvectors that returns anything to+-- t'SomeBV'.+unarySomeBV ::+  forall bv r.+  (forall n. (KnownNat n, 1 <= n) => bv n -> r) ->+  (SomeBVLit -> r) ->+  SomeBV bv ->+  r+unarySomeBV f _ (SomeBV bv) = f bv+unarySomeBV _ g (SomeBVLit i) = g i+{-# INLINE unarySomeBV #-}++-- | Lift a unary operation on sized bitvectors that returns a bitvector to+-- t'SomeBV'. The result will also be wrapped with t'SomeBV'.+unarySomeBVR1 ::+  (forall n. (KnownNat n, 1 <= n) => bv n -> bv n) ->+  (SomeBVLit -> SomeBVLit) ->+  SomeBV bv ->+  SomeBV bv+unarySomeBVR1 f g = unarySomeBV (SomeBV . f) (SomeBVLit . g)+{-# INLINE unarySomeBVR1 #-}++-- | Lift a binary operation on sized bitvectors that returns anything to+-- t'SomeBV'. Crash if the bitwidths do not match.+binSomeBV ::+  (forall n. (KnownNat n, 1 <= n) => Num (bv n), MaySomeBV bv) =>+  (forall n. (KnownNat n, 1 <= n) => bv n -> bv n -> r) ->+  (SomeBVLit -> SomeBVLit -> r) ->+  SomeBV bv ->+  SomeBV bv ->+  r+binSomeBV f _ (SomeBV (l :: bv l)) (SomeBV (r :: bv r)) =+  case sameNat (Proxy @l) (Proxy @r) of+    Just Refl -> f l r+    Nothing -> throw BitwidthMismatch+binSomeBV f _ (SomeBV (l :: bv l)) (SomeBVLit r) = f l $ assignLitBitWidth r+binSomeBV f _ (SomeBVLit l) (SomeBV (r :: bv r)) = f (assignLitBitWidth l) r+binSomeBV _ g (SomeBVLit l) (SomeBVLit r) = g l r+{-# INLINE binSomeBV #-}++-- | Lift a ternary operation on sized bitvectors that returns anything to+-- t'SomeBV'. Crash if the bitwidths do not match.+ternSomeBV ::+  (forall n. (KnownNat n, 1 <= n) => Num (bv n), MaySomeBV bv) =>+  (forall n. (KnownNat n, 1 <= n) => bv n -> bv n -> bv n -> r) ->+  SomeBV bv ->+  SomeBV bv ->+  SomeBV bv ->+  r+ternSomeBV f (SomeBV (a :: bv a)) (SomeBV (b :: bv b)) (SomeBV (c :: bv c)) =+  case (sameNat (Proxy @a) (Proxy @b), sameNat (Proxy @a) (Proxy @c)) of+    (Just Refl, Just Refl) -> f a b c+    _ -> throw BitwidthMismatch+ternSomeBV f a b c =+  case assignBitWidth "ternSomeBV" (a, b, c) of+    Right (a', b', c') -> ternSomeBV f a' b' c'+    Left e -> throw e+{-# INLINE ternSomeBV #-}++-- | Lift a binary operation on sized bitvectors that returns a bitvector to+-- t'SomeBV'. The result will also be wrapped with t'SomeBV'. Crash if the+-- bitwidths do not match.+binSomeBVR1 ::+  (forall n. (KnownNat n, 1 <= n) => Num (bv n), MaySomeBV bv) =>+  (forall n. (KnownNat n, 1 <= n) => bv n -> bv n -> bv n) ->+  (SomeBVLit -> SomeBVLit -> SomeBVLit) ->+  SomeBV bv ->+  SomeBV bv ->+  SomeBV bv+binSomeBVR1 f g = binSomeBV (\a b -> SomeBV $ f a b) (\a b -> SomeBVLit $ g a b)+{-# INLINE binSomeBVR1 #-}++-- | Lift a binary operation on sized bitvectors that returns two bitvectors to+-- t'SomeBV'. The results will also be wrapped with t'SomeBV'. Crash if the+-- bitwidths do not match.+binSomeBVR2 ::+  (forall n. (KnownNat n, 1 <= n) => Num (bv n), MaySomeBV bv) =>+  (forall n. (KnownNat n, 1 <= n) => bv n -> bv n -> (bv n, bv n)) ->+  (SomeBVLit -> SomeBVLit -> (SomeBVLit, SomeBVLit)) ->+  SomeBV bv ->+  SomeBV bv ->+  (SomeBV bv, SomeBV bv)+binSomeBVR2 f g =+  binSomeBV+    (\a b -> let (x, y) = f a b in (SomeBV x, SomeBV y))+    (\a b -> let (x, y) = g a b in (SomeBVLit x, SomeBVLit y))+{-# INLINE binSomeBVR2 #-}++-- | Lift a ternary operation on sized bitvectors that returns a bitvector to+-- t'SomeBV'. The result will also be wrapped with t'SomeBV'. Crash if the+-- bitwidths do not match.+ternSomeBVR1 ::+  (forall n. (KnownNat n, 1 <= n) => Num (bv n), MaySomeBV bv) =>+  (forall n. (KnownNat n, 1 <= n) => bv n -> bv n -> bv n -> bv n) ->+  SomeBV bv ->+  SomeBV bv ->+  SomeBV bv ->+  SomeBV bv+ternSomeBVR1 f = ternSomeBV (\a b c -> SomeBV $ f a b c)+{-# INLINE ternSomeBVR1 #-}++-- | Lift a binary operation on sized bitvectors that returns anything wrapped+-- with 'ExceptT' to t'SomeBV'. If the bitwidths do not match, throw an+-- 'BitwidthMismatch' error to the monadic context.+binSomeBVSafe ::+  ( MonadError (Either SomeBVException e) m,+    TryMerge m,+    Mergeable e,+    Mergeable r,+    forall n. (KnownNat n, 1 <= n) => Num (bv n),+    MaySomeBV bv+  ) =>+  (forall n. (KnownNat n, 1 <= n) => bv n -> bv n -> ExceptT e m r) ->+  (SomeBVLit -> SomeBVLit -> ExceptT (Either SomeBVException e) m r) ->+  SomeBV bv ->+  SomeBV bv ->+  m r+binSomeBVSafe f _ (SomeBV (l :: bv l)) (SomeBV (r :: bv r)) =+  case sameNat (Proxy @l) (Proxy @r) of+    Just Refl ->+      tryMerge $ runExceptT (f l r) >>= either (throwError . Right) pure+    Nothing -> tryMerge $ throwError $ Left BitwidthMismatch+binSomeBVSafe _ g (SomeBVLit l) (SomeBVLit r) =+  tryMerge $ runExceptT (g l r) >>= either throwError pure+binSomeBVSafe f g l r =+  case assignBitWidth "binSomeBVSafe" (l, r) of+    Right (l', r') -> binSomeBVSafe f g l' r'+    Left e -> tryMerge $ throwError $ Left e+{-# INLINE binSomeBVSafe #-}++-- | Lift a binary operation on sized bitvectors that returns a bitvector+-- wrapped with 'ExceptT' to t'SomeBV'. The result will also be wrapped with+-- t'SomeBV'.+--+-- If the bitwidths do not match, throw an 'BitwidthMismatch' error to the+-- monadic context.+binSomeBVSafeR1 ::+  ( MonadError (Either SomeBVException e) m,+    TryMerge m,+    Mergeable e,+    forall n. (KnownNat n, 1 <= n) => Mergeable (bv n),+    forall n. (KnownNat n, 1 <= n) => Num (bv n),+    MaySomeBV bv+  ) =>+  (forall n. (KnownNat n, 1 <= n) => bv n -> bv n -> ExceptT e m (bv n)) ->+  (SomeBVLit -> SomeBVLit -> ExceptT (Either SomeBVException e) m SomeBVLit) ->+  SomeBV bv ->+  SomeBV bv ->+  m (SomeBV bv)+binSomeBVSafeR1 f g =+  binSomeBVSafe+    (\l r -> mrgFmap SomeBV $ f l r)+    (\l r -> mrgFmap SomeBVLit $ g l r)+{-# INLINE binSomeBVSafeR1 #-}++-- | Lift a binary operation on sized bitvectors that returns two bitvectors+-- wrapped with 'ExceptT' to t'SomeBV'. The results will also be wrapped with+-- t'SomeBV'.+--+-- If the bitwidths do not match, throw an 'BitwidthMismatch' error to the+-- monadic context.+binSomeBVSafeR2 ::+  ( MonadError (Either SomeBVException e) m,+    TryMerge m,+    Mergeable e,+    forall n. (KnownNat n, 1 <= n) => Mergeable (bv n),+    forall n. (KnownNat n, 1 <= n) => Num (bv n),+    MaySomeBV bv+  ) =>+  ( forall n.+    (KnownNat n, 1 <= n) =>+    bv n ->+    bv n ->+    ExceptT e m (bv n, bv n)+  ) ->+  ( SomeBVLit ->+    SomeBVLit ->+    ExceptT (Either SomeBVException e) m (SomeBVLit, SomeBVLit)+  ) ->+  SomeBV bv ->+  SomeBV bv ->+  m (SomeBV bv, SomeBV bv)+binSomeBVSafeR2 f g =+  binSomeBVSafe+    (\l r -> mrgFmap (bimap SomeBV SomeBV) $ f l r)+    (\l r -> mrgFmap (bimap SomeBVLit SomeBVLit) $ g l r)+{-# INLINE binSomeBVSafeR2 #-}
+ src/Grisette/Internal/SymPrim/SymAlgReal.hs view
@@ -0,0 +1,222 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TypeFamilies #-}++-- |+-- Module      :   Grisette.Internal.SymPrim.SymAlgReal+-- 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.SymAlgReal+  ( SymAlgReal (SymAlgReal),+    SymAlgRealKey,+  )+where++import Control.DeepSeq (NFData)+import qualified Data.Binary as Binary+import Data.Bytes.Serial (Serial (deserialize, serialize))+import Data.Hashable (Hashable (hashWithSalt))+import qualified Data.Serialize as Cereal+import Data.String (IsString (fromString))+import GHC.Generics (Generic)+import Grisette.Internal.Core.Data.Class.AsKey+  ( AsKey,+    KeyEq (keyEq),+    KeyHashable (keyHashWithSalt),+    shouldUseAsKeyHasSymbolicVersionError,+    shouldUseSymbolicVersionError,+  )+import Grisette.Internal.Core.Data.Class.Function (Apply (FunType, apply))+import Grisette.Internal.Core.Data.Class.Solvable+  ( Solvable (con, conView, ssym, sym),+  )+import Grisette.Internal.Internal.Decl.SymPrim.AllSyms+  ( AllSyms (allSymsS),+    SomeSym (SomeSym),+  )+import Grisette.Internal.SymPrim.AlgReal (AlgReal)+import Grisette.Internal.SymPrim.Prim.Internal.Term+  ( FloatingUnaryOp+      ( FloatingAcos,+        FloatingAsin,+        FloatingAtan,+        FloatingCos,+        FloatingCosh,+        FloatingExp,+        FloatingLog,+        FloatingSin,+        FloatingSinh,+        FloatingSqrt,+        FloatingTan,+        FloatingTanh+      ),+    PEvalFloatingTerm (pevalFloatingUnaryTerm, pevalPowerTerm),+    PEvalFractionalTerm (pevalFdivTerm, pevalRecipTerm),+    PEvalNumTerm+      ( pevalAbsNumTerm,+        pevalMulNumTerm,+        pevalNegNumTerm,+        pevalSignumNumTerm+      ),+    PEvalOrdTerm (pevalLeOrdTerm),+    SupportedPrim (pevalITETerm),+    pevalSubNumTerm,+    typedConstantSymbol,+  )+import Grisette.Internal.SymPrim.Prim.Term+  ( ConRep (ConType),+    LinkedRep (underlyingTerm, wrapTerm),+    PEvalNumTerm (pevalAddNumTerm),+    SymRep (SymType),+    Term,+    conTerm,+    pformatTerm,+    symTerm,+    pattern ConTerm,+  )+import Language.Haskell.TH.Syntax (Lift)++-- | Symbolic representation of algebraic real numbers.+newtype SymAlgReal = SymAlgReal {underlyingAlgRealTerm :: Term AlgReal}+  deriving (Lift, Generic)+  deriving anyclass (NFData)++-- | t'SymAlgReal' type with identity equality.+type SymAlgRealKey = AsKey SymAlgReal++instance ConRep SymAlgReal where+  type ConType SymAlgReal = AlgReal++instance SymRep AlgReal where+  type SymType AlgReal = SymAlgReal++instance LinkedRep AlgReal SymAlgReal where+  underlyingTerm = underlyingAlgRealTerm+  wrapTerm = SymAlgReal++instance Apply SymAlgReal where+  type FunType SymAlgReal = SymAlgReal+  apply = id++-- | This will crash the program.+--+-- 'SymAlgReal' cannot be compared concretely.+--+-- If you want to use the type as keys in hash maps based on term equality, say+-- memo table, you should use @'AsKey' 'SymAlgReal'@ instead.+--+-- If you want symbolic version of the equality operator, use+-- t'Grisette.Core.SymEq' instead.+instance Eq SymAlgReal where+  (==) = shouldUseAsKeyHasSymbolicVersionError "SymAlgReal" "(==)" "(.==)"++instance KeyEq SymAlgReal where+  keyEq (SymAlgReal l) (SymAlgReal r) = l == r++-- | This will crash the program.+--+-- 'SymAlgReal' cannot be compared concretely.+--+-- If you want symbolic version of the comparison operators, use+-- t'Grisette.Core.SymOrd' instead.+instance Ord SymAlgReal where+  (<) = shouldUseSymbolicVersionError "SymAlgReal" "(<)" "(.<)"+  (<=) = shouldUseSymbolicVersionError "SymAlgReal" "(<=)" "(.<=)"+  (>=) = shouldUseSymbolicVersionError "SymAlgReal" "(>=)" "(.>=)"+  (>) = shouldUseSymbolicVersionError "SymAlgReal" "(>)" "(.>)"+  max (SymAlgReal l) (SymAlgReal r) =+    SymAlgReal $ pevalITETerm (pevalLeOrdTerm l r) r l+  min (SymAlgReal l) (SymAlgReal r) =+    SymAlgReal $ pevalITETerm (pevalLeOrdTerm l r) l r+  compare = shouldUseSymbolicVersionError "SymAlgReal" "compare" "symCompare"++instance Real SymAlgReal where+  toRational = error "toRational: toRational isn't supported for SymAlgReal"++instance KeyHashable SymAlgReal where+  keyHashWithSalt s (SymAlgReal v) = s `hashWithSalt` v++instance IsString SymAlgReal where+  fromString = ssym . fromString++instance Solvable AlgReal SymAlgReal where+  con = SymAlgReal . conTerm+  sym = SymAlgReal . symTerm . typedConstantSymbol+  conView (SymAlgReal (ConTerm t)) = Just t+  conView _ = Nothing++instance Show SymAlgReal where+  show (SymAlgReal t) = pformatTerm t++instance AllSyms SymAlgReal where+  allSymsS v = (SomeSym v :)++instance Num SymAlgReal where+  (SymAlgReal l) + (SymAlgReal r) = SymAlgReal $ pevalAddNumTerm l r+  (SymAlgReal l) - (SymAlgReal r) = SymAlgReal $ pevalSubNumTerm l r+  (SymAlgReal l) * (SymAlgReal r) = SymAlgReal $ pevalMulNumTerm l r+  negate (SymAlgReal v) = SymAlgReal $ pevalNegNumTerm v+  abs (SymAlgReal v) = SymAlgReal $ pevalAbsNumTerm v+  signum (SymAlgReal v) = SymAlgReal $ pevalSignumNumTerm v+  fromInteger = con . fromInteger++-- | The function is total and will not throw errors. The result is considered+-- undefined if the divisor is 0.+--+-- It is the responsibility of the caller to ensure that the divisor is not+-- zero with the symbolic constraints, or use the t'Grisette.Core.FdivOr' or+-- t'Grisette.Core.SafeFdiv' classes.+instance Fractional SymAlgReal where+  fromRational = con . fromRational+  (SymAlgReal l) / (SymAlgReal r) = SymAlgReal $ pevalFdivTerm l r+  recip (SymAlgReal l) = SymAlgReal $ pevalRecipTerm l++-- | The functions are total and will not throw errors. The result for 'logBase'+-- is considered undefined if the base is 1.+--+-- It is the responsibility of the caller to ensure that the base is not 1+-- with the symbolic constraints, or use the t'Grisette.Core.LogBaseOr' or+-- t'Grisette.Core.SafeLogBase' classes.+instance Floating SymAlgReal where+  pi = fromRational $ toRational pi+  exp (SymAlgReal v) = SymAlgReal $ pevalFloatingUnaryTerm FloatingExp v+  log (SymAlgReal v) = SymAlgReal $ pevalFloatingUnaryTerm FloatingLog v+  sqrt (SymAlgReal v) = SymAlgReal $ pevalFloatingUnaryTerm FloatingSqrt v+  sin (SymAlgReal v) = SymAlgReal $ pevalFloatingUnaryTerm FloatingSin v+  cos (SymAlgReal v) = SymAlgReal $ pevalFloatingUnaryTerm FloatingCos v+  tan (SymAlgReal v) = SymAlgReal $ pevalFloatingUnaryTerm FloatingTan v+  sinh (SymAlgReal v) = SymAlgReal $ pevalFloatingUnaryTerm FloatingSinh v+  cosh (SymAlgReal v) = SymAlgReal $ pevalFloatingUnaryTerm FloatingCosh v+  tanh (SymAlgReal v) = SymAlgReal $ pevalFloatingUnaryTerm FloatingTanh v+  asin (SymAlgReal v) = SymAlgReal $ pevalFloatingUnaryTerm FloatingAsin v+  acos (SymAlgReal v) = SymAlgReal $ pevalFloatingUnaryTerm FloatingAcos v+  atan (SymAlgReal v) = SymAlgReal $ pevalFloatingUnaryTerm FloatingAtan v+  asinh = error "asinh isn't supported by the underlying sbv library"+  acosh = error "acosh isn't supported by the underlying sbv library"+  atanh = error "atanh isn't supported by the underlying sbv library"+  SymAlgReal l ** SymAlgReal r = SymAlgReal $ pevalPowerTerm l r+  logBase (SymAlgReal baset) (SymAlgReal at) =+    SymAlgReal $+      pevalFdivTerm+        (pevalFloatingUnaryTerm FloatingLog at)+        (pevalFloatingUnaryTerm FloatingLog baset)++instance Serial SymAlgReal where+  serialize = serialize . underlyingAlgRealTerm+  deserialize = SymAlgReal <$> deserialize++instance Cereal.Serialize SymAlgReal where+  put = serialize+  get = deserialize++instance Binary.Binary SymAlgReal where+  put = serialize+  get = deserialize
+ src/Grisette/Internal/SymPrim/SymBV.hs view
@@ -0,0 +1,782 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.SymPrim.SymBV+-- 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.SymPrim.SymBV+  ( SymWordN (SymWordN),+    SymWordN8,+    SymWordN16,+    SymWordN32,+    SymWordN64,+    SymWordNKey,+    SymWordN8Key,+    SymWordN16Key,+    SymWordN32Key,+    SymWordN64Key,+    SymIntN (SymIntN),+    SymIntN8,+    SymIntN16,+    SymIntN32,+    SymIntN64,+    SymIntNKey,+    SymIntN8Key,+    SymIntN16Key,+    SymIntN32Key,+    SymIntN64Key,+  )+where++import Control.DeepSeq (NFData)+import qualified Data.Binary as Binary+import Data.Bits+  ( Bits+      ( bit,+        bitSize,+        bitSizeMaybe,+        complement,+        isSigned,+        popCount,+        rotate,+        shift,+        testBit,+        xor,+        (.&.),+        (.|.)+      ),+    FiniteBits (finiteBitSize),+  )+import Data.Bytes.Serial (Serial (deserialize, serialize))+import Data.Hashable (Hashable (hashWithSalt))+import Data.Proxy (Proxy (Proxy))+import qualified Data.Serialize as Cereal+import Data.String (IsString (fromString))+import GHC.Generics (Generic)+import GHC.TypeNats+  ( KnownNat,+    Nat,+    natVal,+    type (+),+    type (<=),+  )+import Grisette.Internal.Core.Data.Class.AsKey+  ( AsKey,+    KeyEq (keyEq),+    KeyHashable (keyHashWithSalt),+    shouldUseAsKeyHasSymbolicVersionError,+  )+import Grisette.Internal.Core.Data.Class.BitCast (BitCast (bitCast))+import Grisette.Internal.Core.Data.Class.BitVector+  ( SizedBV+      ( sizedBVConcat,+        sizedBVExt,+        sizedBVSelect,+        sizedBVSext,+        sizedBVZext+      ),+  )+import Grisette.Internal.Core.Data.Class.Function+  ( Apply (FunType, apply),+  )+import Grisette.Internal.Core.Data.Class.SignConversion+  ( SignConversion (toSigned, toUnsigned),+  )+import Grisette.Internal.Core.Data.Class.Solvable+  ( Solvable (con, conView, ssym, sym),+    pattern Con,+  )+import Grisette.Internal.Core.Data.Class.SymRotate+  ( SymRotate (symRotate, symRotateNegated),+  )+import Grisette.Internal.Core.Data.Class.SymShift+  ( SymShift (symShift, symShiftNegated),+  )+import Grisette.Internal.Internal.Decl.SymPrim.AllSyms+  ( AllSyms (allSymsS),+    SomeSym (SomeSym),+  )+import Grisette.Internal.SymPrim.BV+  ( IntN,+    WordN,+  )+import Grisette.Internal.SymPrim.Prim.Term+  ( ConRep (ConType),+    LinkedRep (underlyingTerm, wrapTerm),+    PEvalBVTerm (pevalBVConcatTerm, pevalBVExtendTerm, pevalBVSelectTerm),+    PEvalBitCastTerm (pevalBitCastTerm),+    PEvalBitwiseTerm+      ( pevalAndBitsTerm,+        pevalComplementBitsTerm,+        pevalOrBitsTerm,+        pevalXorBitsTerm+      ),+    PEvalNumTerm+      ( pevalAbsNumTerm,+        pevalAddNumTerm,+        pevalMulNumTerm,+        pevalNegNumTerm,+        pevalSignumNumTerm+      ),+    PEvalOrdTerm (pevalLeOrdTerm),+    PEvalRotateTerm+      ( pevalRotateLeftTerm,+        pevalRotateRightTerm+      ),+    PEvalShiftTerm (pevalShiftLeftTerm, pevalShiftRightTerm),+    SupportedPrim (pevalITETerm),+    SymRep (SymType),+    Term,+    conTerm,+    pevalDivIntegralTerm,+    pevalEqTerm,+    pevalGeOrdTerm,+    pevalModIntegralTerm,+    pevalOrTerm,+    pevalQuotIntegralTerm,+    pevalRemIntegralTerm,+    pevalSubNumTerm,+    pformatTerm,+    symTerm,+    typedConstantSymbol,+    pattern ConTerm,+  )+import Grisette.Internal.SymPrim.SymBool (SymBool (SymBool))+import Grisette.Internal.Utils.Parameterized+  ( KnownProof (KnownProof),+    LeqProof (LeqProof),+    knownAdd,+    leqAddPos,+    leqTrans,+  )+import Language.Haskell.TH.Syntax (Lift)++-- $setup+-- >>> import Grisette.Core+-- >>> import Grisette.SymPrim+-- >>> import Grisette.Backend+-- >>> import Data.Proxy++-- | Symbolic signed bit vector type. Indexed with the bit width.+-- Signedness affects the semantics of the operations, including+-- comparison/extension, etc.+--+-- >>> "a" + 5 :: SymIntN 5+-- (+ 0b00101 a)+-- >>> sizedBVConcat (con 0b101 :: SymIntN 3) (con 0b110 :: SymIntN 3)+-- 0b101110+-- >>> sizedBVExt (Proxy @6) (con 0b101 :: SymIntN 3)+-- 0b111101+-- >>> (8 :: SymIntN 4) .< (7 :: SymIntN 4)+-- true+--+-- 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)++-- | t'SymIntN' type with identity equality.+type SymIntNKey n = AsKey (SymIntN n)++-- | 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++-- | @t'SymIntN' 8@ type with identity equality.+type SymIntN8Key = SymIntNKey 8++-- | @t'SymIntN' 16@ type with identity equality.+type SymIntN16Key = SymIntNKey 16++-- | @t'SymIntN' 32@ type with identity equality.+type SymIntN32Key = SymIntNKey 32++-- | @t'SymIntN' 64@ type with identity equality.+type SymIntN64Key = SymIntNKey 64++-- | Symbolic unsigned bit vector type. Indexed with the bit width.+-- Signedness affects the semantics of the operations, including+-- comparison/extension, etc.+--+-- >>> "a" + 5 :: SymWordN 5+-- (+ 0b00101 a)+-- >>> sizedBVConcat (con 0b101 :: SymWordN 3) (con 0b110 :: SymWordN 3)+-- 0b101110+-- >>> sizedBVExt (Proxy @6) (con 0b101 :: SymWordN 3)+-- 0b000101+-- >>> (8 :: SymWordN 4) .< (7 :: SymWordN 4)+-- false+--+-- 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)++-- | t'SymWordN' type with identity equality.+type SymWordNKey n = AsKey (SymWordN n)++-- | 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++-- | t'SymWordN' 8@ type with identity equality.+type SymWordN8Key = SymWordNKey 8++-- | t'SymWordN' 16@ type with identity equality.+type SymWordN16Key = SymWordNKey 16++-- | t'SymWordN' 32@ type with identity equality.+type SymWordN32Key = SymWordNKey 32++-- | t'SymWordN' 64@ type with identity equality.+type SymWordN64Key = SymWordNKey 64++instance (KnownNat n, 1 <= n) => ConRep (SymIntN n) where+  type ConType (SymIntN n) = IntN n++instance (KnownNat n, 1 <= n) => SymRep (IntN n) where+  type SymType (IntN n) = SymIntN n++instance (KnownNat n, 1 <= n) => LinkedRep (IntN n) (SymIntN n) where+  underlyingTerm (SymIntN a) = a+  wrapTerm = SymIntN++instance (KnownNat n, 1 <= n) => ConRep (SymWordN n) where+  type ConType (SymWordN n) = WordN n++instance (KnownNat n, 1 <= n) => SymRep (WordN n) where+  type SymType (WordN n) = SymWordN n++instance (KnownNat n, 1 <= n) => LinkedRep (WordN n) (SymWordN n) where+  underlyingTerm (SymWordN a) = a+  wrapTerm = SymWordN++-- Aggregate instances++instance (KnownNat n, 1 <= n) => Apply (SymIntN n) where+  type FunType (SymIntN n) = SymIntN n+  apply = id++instance (KnownNat n, 1 <= n) => Apply (SymWordN n) where+  type FunType (SymWordN n) = SymWordN n+  apply = id++#define SOLVABLE_BV(contype, symtype) \+instance (KnownNat n, 1 <= n) => Solvable (contype n) (symtype n) where \+  con = symtype . conTerm; \+  sym = symtype . symTerm . typedConstantSymbol; \+  conView (symtype (ConTerm  t)) = Just t; \+  conView _ = Nothing++#if 1+SOLVABLE_BV(IntN, SymIntN)+SOLVABLE_BV(WordN, SymWordN)+#endif++-- Num++#define NUM_BV(symtype) \+instance (KnownNat n, 1 <= n) => Num (symtype n) where \+  (symtype l) + (symtype r) = symtype $ pevalAddNumTerm l r; \+  (symtype l) - (symtype r) = symtype $ pevalSubNumTerm l r; \+  (symtype l) * (symtype r) = symtype $ pevalMulNumTerm l r; \+  negate (symtype v) = symtype $ pevalNegNumTerm v; \+  abs (symtype v) = symtype $ pevalAbsNumTerm v; \+  signum (symtype v) = symtype $ pevalSignumNumTerm v; \+  fromInteger i = con $ fromInteger i++#if 1+NUM_BV(SymIntN)+NUM_BV(SymWordN)+#endif++instance (KnownNat n, 1 <= n) => Bounded (SymIntN n) where+  minBound = con $ minBound @(IntN n)+  maxBound = con $ maxBound @(IntN n)+  {-# INLINE minBound #-}+  {-# INLINE maxBound #-}++#define ENUM_BV(symtype, contype, symtypestring) \+instance (KnownNat n, 1 <= n) => Enum (symtype n) where \+  succ _ = error $ "succ: succ isn't supported for " ++ symtypestring; \+  pred _ = error $ "pred: pred isn't supported for " ++ symtypestring; \+  toEnum i \+    | (fromIntegral i :: Integer) >= fromIntegral (minBound @(contype n)) \+        && (fromIntegral i :: Integer) <= fromIntegral (maxBound @(contype n)) = \+        con $ fromIntegral i \+    | otherwise = error "toEnum: toEnum is out of bounds"; \+  fromEnum _ = \+    error $ "fromEnum: fromEnum isn't supported for " ++ symtypestring; \+  enumFrom = \+    error $ "enumFrom: enumFrom isn't supported for " ++ symtypestring; \+  enumFromThen = \+    error $ "enumFromThen: enumFromThen isn't supported for " ++ symtypestring; \+  enumFromTo = \+    error $ "enumFromTo: enumFromTo isn't supported for " ++ symtypestring; \+  enumFromThenTo = \+    error $ "enumFromThenTo: enumFromThenTo isn't supported for " ++ symtypestring++#if 1+ENUM_BV(SymIntN, IntN, "SymIntN")+ENUM_BV(SymWordN, WordN, "SymWordN")+#endif++#define ORD_BV(symtype, symtypestring) \+instance (KnownNat n, 1 <= n) => Ord (symtype n) where \+  (<) = error $ "Ord: < isn't supported for " ++ symtypestring ++ ". Consider using the symbolic comparison operators (.<)."; \+  (<=) = error $ "Ord: <= isn't supported for " ++ symtypestring ++ ". Consider using the symbolic comparison operators (.<=)."; \+  (>=) = error $ "Ord: >= isn't supported for " ++ symtypestring ++ ". Consider using the symbolic comparison operators (.>=)."; \+  (>) = error $ "Ord: > isn't supported for " ++ symtypestring ++ ". Consider using the symbolic comparison operators (.>)."; \+  max (symtype l) (symtype r) = symtype $ pevalITETerm (pevalLeOrdTerm l r) r l; \+  {-# INLINE max #-}; \+  min (symtype l) (symtype r) = symtype $ pevalITETerm (pevalLeOrdTerm l r) l r; \+  {-# INLINE min #-}; \+  compare _ _ = \+    error $ "compare: compare isn't supported for " ++ symtypestring ++ ". Consider using the symbolic comparison operators (symCompare)."++#if 1+ORD_BV(SymIntN, "SymIntN")+ORD_BV(SymWordN, "SymWordN")+#endif++instance (KnownNat n, 1 <= n) => Real (SymIntN n) where+  toRational _ = error $ "toRational: toRational isn't supported for " ++ "SymIntN"++instance (KnownNat n, 1 <= n) => Real (SymWordN n) where+  toRational _ = error $ "toRational: toRational isn't supported for " ++ "SymWordN"++#define INTEGRAL_BV(symtype, symtypestring) \+instance (KnownNat n, 1 <= n) => Integral (symtype n) where \+  toInteger = error $ "toInteger: toInteger isn't supported for " ++ symtypestring; \+  div (symtype l) (symtype r) = symtype $ pevalDivIntegralTerm l r; \+  {-# INLINE div #-}; \+  mod (symtype l) (symtype r) = symtype $ pevalModIntegralTerm l r; \+  {-# INLINE mod #-}; \+  quot (symtype l) (symtype r) = symtype $ pevalQuotIntegralTerm l r; \+  {-# INLINE quot #-}; \+  rem (symtype l) (symtype r) = symtype $ pevalRemIntegralTerm l r; \+  {-# INLINE rem #-}; \+  divMod (symtype l) (symtype r) = \+    (symtype $ pevalDivIntegralTerm l r, symtype $ pevalModIntegralTerm l r); \+  {-# INLINE divMod #-}; \+  quotRem (symtype l) (symtype r) = \+    (symtype $ pevalQuotIntegralTerm l r, symtype $ pevalRemIntegralTerm l r); \+  {-# INLINE quotRem #-}++#if 1+-- | The functions are total and will not throw errors. The result is considered+-- undefined if the divisor is 0.+--+-- It is the responsibility of the caller to ensure that the divisor is not+-- zero with the symbolic constraints, or use the t'Grisette.Core.DivOr' or+-- t'Grisette.Core.SafeDiv' classes.+INTEGRAL_BV(SymIntN, "SymIntN")+-- | The functions are total and will not throw errors. The result is considered+-- undefined if the divisor is 0.+--+-- It is the responsibility of the caller to ensure that the divisor is not+-- zero with the symbolic constraints, or use the t'Grisette.Core.DivOr' or+-- t'Grisette.Core.SafeDiv' classes.+INTEGRAL_BV(SymWordN, "SymWordN")+#endif++-- Bits++#define BITS_BV(symtype, signed) \+instance (KnownNat n, 1 <= n) => Bits (symtype n) where \+  symtype l .&. symtype r = symtype $ pevalAndBitsTerm l r; \+  {-# INLINE (.&.) #-}; \+  symtype l .|. symtype r = symtype $ pevalOrBitsTerm l r; \+  {-# INLINE (.|.) #-}; \+  symtype l `xor` symtype r = symtype $ pevalXorBitsTerm l r; \+  {-# INLINE xor #-}; \+  complement (symtype n) = symtype $ pevalComplementBitsTerm n; \+  {-# INLINE complement #-}; \+  shift (symtype n) i | i > 0 = symtype $ pevalShiftLeftTerm n (conTerm $ fromIntegral i); \+  shift (symtype n) i | i < 0 = symtype $ pevalShiftRightTerm n (conTerm $ fromIntegral (-i)); \+  shift (symtype n) _ = symtype n; \+  {-# INLINE shift #-}; \+  rotate (symtype n) i | i > 0 = symtype $ pevalRotateLeftTerm n (conTerm $ fromIntegral i); \+  rotate (symtype n) i | i < 0 = symtype $ pevalRotateRightTerm n (conTerm $ fromIntegral (-i)); \+  rotate (symtype n) _ = symtype n; \+  {-# INLINE rotate #-}; \+  bitSize = finiteBitSize; \+  {-# INLINE bitSize #-}; \+  bitSizeMaybe = Just . finiteBitSize; \+  {-# INLINE bitSizeMaybe #-}; \+  isSigned _ = signed; \+  {-# INLINE isSigned #-}; \+  testBit (Con n) =  testBit n; \+  testBit _ = error "You cannot call testBit on symbolic variables"; \+  {-# INLINE testBit #-}; \+  bit = con . bit; \+  {-# INLINE bit #-}; \+  popCount (Con n) = popCount n; \+  popCount _ = error "You cannot call popCount on symbolic variables"; \+  {-# INLINE popCount #-}++#if 1+BITS_BV(SymIntN, True)+BITS_BV(SymWordN, False)+#endif++-- FiniteBits++#define FINITE_BITS_BV(symtype) \+instance (KnownNat n, 1 <= n) => FiniteBits (symtype n) where \+  finiteBitSize _ = fromIntegral $ natVal (Proxy @n); \+  {-# INLINE finiteBitSize #-}; \++#if 1+FINITE_BITS_BV(SymIntN)+FINITE_BITS_BV(SymWordN)+#endif++-- Show++#define SHOW_BV(symtype) \+instance (KnownNat n, 1 <= n) => Show (symtype n) where \+  show (symtype t) = pformatTerm t++#if 1+SHOW_BV(SymIntN)+SHOW_BV(SymWordN)+#endif++-- Hashable++#define KEY_HASHABLE_BV(symtype) \+instance (KnownNat n, 1 <= n) => KeyHashable (symtype n) where \+  keyHashWithSalt s (symtype v) = s `hashWithSalt` v++#if 1+KEY_HASHABLE_BV(SymIntN)+KEY_HASHABLE_BV(SymWordN)+#endif++-- Eq++#define EQ_BV(symtype) \+instance (KnownNat n, 1 <= n) => Eq (symtype n) where \+  (==) = shouldUseAsKeyHasSymbolicVersionError "symtype" "(==)" "(.==)"++#define KEY_EQ_BV(symtype) \+instance (KnownNat n, 1 <= n) => KeyEq (symtype n) where \+  keyEq (symtype l) (symtype r) = l == r++#if 1+-- This will crash the program.+--+-- 'SymIntN' cannot be compared concretely.+--+-- If you want to use the type as keys in hash maps based on term equality, say+-- memo table, you should use @'AsKey' ('SymIntN' n)@ instead.+EQ_BV(SymIntN)+KEY_EQ_BV(SymIntN)+-- | This will crash the program.+--+-- 'SymWordN' cannot be compared concretely.+--+-- If you want to use the type as keys in hash maps based on term equality, say+-- memo table, you should use @'AsKey' ('SymWordN' n)@ instead.+EQ_BV(SymWordN)+KEY_EQ_BV(SymWordN)+#endif++-- IsString++#define IS_STRING_BV(symtype) \+instance (KnownNat n, 1 <= n) => IsString (symtype n) where \+  fromString = ssym . fromString++#if 1+IS_STRING_BV(SymIntN)+IS_STRING_BV(SymWordN)+#endif++-- SizedBV++#define BVCONCAT_SIZED(symtype) \+sizedBVConcat :: forall l r. (KnownNat l, KnownNat r, 1 <= l, 1 <= r) => symtype l -> symtype r -> symtype (l + r); \+sizedBVConcat (symtype l) (symtype r) = \+  case (leqAddPos pl pr, knownAdd (KnownProof @l) (KnownProof @r)) of \+    (LeqProof, KnownProof) -> \+      symtype (pevalBVConcatTerm l r); \+  where; \+    pl = Proxy :: Proxy l; \+    pr = Proxy :: Proxy r++#define BVZEXT_SIZED(symtype) \+sizedBVZext :: forall l r proxy. (KnownNat l, KnownNat r, 1 <= l, KnownNat r, l <= r) => proxy r -> symtype l -> symtype r; \+sizedBVZext _ (symtype v) = \+  case leqTrans (LeqProof @1 @l) (LeqProof @l @r) of \+    LeqProof -> symtype $ pevalBVExtendTerm False (Proxy @r) v++#define BVSEXT_SIZED(symtype) \+sizedBVSext :: forall l r proxy. (KnownNat l, KnownNat r, 1 <= l, KnownNat r, l <= r) => proxy r -> symtype l -> symtype r; \+sizedBVSext _ (symtype v) = \+  case leqTrans (LeqProof @1 @l) (LeqProof @l @r) of \+    LeqProof -> symtype $ pevalBVExtendTerm True (Proxy @r) v++#define BVSELECT_SIZED(symtype) \+sizedBVSelect :: forall n ix w p q. (KnownNat n, KnownNat ix, KnownNat w, 1 <= n, 1 <= w, ix + w <= n) => \+  p ix -> q w -> symtype n -> symtype w; \+sizedBVSelect pix pw (symtype v) = symtype $ pevalBVSelectTerm pix pw v++#if 1+instance SizedBV SymIntN where+  BVCONCAT_SIZED(SymIntN)+  BVZEXT_SIZED(SymIntN)+  BVSEXT_SIZED(SymIntN)+  sizedBVExt = sizedBVSext+  BVSELECT_SIZED(SymIntN)++instance SizedBV SymWordN where+  BVCONCAT_SIZED(SymWordN)+  BVZEXT_SIZED(SymWordN)+  BVSEXT_SIZED(SymWordN)+  sizedBVExt = sizedBVZext+  BVSELECT_SIZED(SymWordN)+#endif++-- BV++#define BVCONCAT(somety, origty) \+bvConcat (somety (a :: origty l)) (somety (b :: origty r)) = \+  case (leqAddPos (Proxy @l) (Proxy @r), knownAdd @l @r KnownProof KnownProof) of \+    (LeqProof, KnownProof) -> \+      somety $ sizedBVConcat a b++#define BVZEXT(somety, origty) \+bvZext l (somety (a :: origty n)) \+  | l < n = error "bvZext: trying to zero extend a value to a smaller size" \+  | otherwise = res (Proxy @n) \+  where \+    n = fromIntegral $ natVal (Proxy @n); \+    res :: forall (l :: Nat). Proxy l -> somety; \+    res p = \+      case (unsafeKnownProof @l (fromIntegral l), unsafeLeqProof @1 @l, unsafeLeqProof @n @l) of \+        (KnownProof, LeqProof, LeqProof) -> somety $ sizedBVZext p a++#define BVSEXT(somety, origty) \+bvSext l (somety (a :: origty n)) \+  | l < n = error "bvZext: trying to zero extend a value to a smaller size" \+  | otherwise = res (Proxy @n) \+  where \+    n = fromIntegral $ natVal (Proxy @n); \+    res :: forall (l :: Nat). Proxy l -> somety; \+    res p = \+      case (unsafeKnownProof @l (fromIntegral l), unsafeLeqProof @1 @l, unsafeLeqProof @n @l) of \+        (KnownProof, LeqProof, LeqProof) -> somety $ sizedBVSext p a++#define BVSELECT(somety, origty) \+bvSelect ix w (somety (a :: origty n)) \+    | ix + w > n = error "bvSelect: trying to select a bitvector outside the bounds of the input" \+    | w == 0 = error "bvSelect: trying to select a bitvector of size 0" \+    | otherwise = res (Proxy @n) (Proxy @n) \+    where \+      n = fromIntegral $ natVal (Proxy @n); \+      res :: forall (w :: Nat) (ix :: Nat). Proxy w -> Proxy ix -> somety; \+      res _ _ = \+        case ( unsafeKnownProof @ix (fromIntegral ix), \+               unsafeKnownProof @w (fromIntegral w), \+               unsafeLeqProof @1 @w, \+               unsafeLeqProof @(ix + w) @n \+             ) of \+          (KnownProof, KnownProof, LeqProof, LeqProof) -> \+            somety $ sizedBVSelect (Proxy @ix) (Proxy @w) a++#define BVBV(somety, origty) \+  bv n i = case mkNatRepr n of \+    Some (natRepr :: NatRepr x) -> \+      case unsafeLeqProof @1 @x of \+        LeqProof -> withKnownNat natRepr $ \+          somety (fromIntegral i :: origty x)++-- BVSignConversion++instance (KnownNat n, 1 <= n) => SignConversion (SymWordN n) (SymIntN n) where+  toSigned (SymWordN n) = SymIntN $ pevalBitCastTerm n+  toUnsigned (SymIntN n) = SymWordN $ pevalBitCastTerm n++-- SymShift+instance (KnownNat n, 1 <= n) => SymShift (SymWordN n) where+  symShift (SymWordN a) (SymWordN s) = SymWordN $ pevalShiftLeftTerm a s+  symShiftNegated (SymWordN a) (SymWordN s) = SymWordN $ pevalShiftRightTerm a s++instance (KnownNat n, 1 <= n) => SymShift (SymIntN n) where+  symShift a _ | finiteBitSize a == 1 = a+  symShift as@(SymIntN a) (SymIntN s)+    | finiteBitSize as == 2 =+        SymIntN $+          pevalITETerm+            (pevalGeOrdTerm s (conTerm 0))+            (pevalShiftLeftTerm a s)+            ( pevalITETerm+                (pevalEqTerm s (conTerm (-2)))+                ( pevalITETerm+                    (pevalGeOrdTerm a (conTerm 0))+                    (conTerm 0)+                    (conTerm (-1))+                )+                (pevalShiftRightTerm a (pevalNegNumTerm s))+            )+  symShift (SymIntN a) (SymIntN s) =+    SymIntN $+      pevalITETerm+        (pevalGeOrdTerm s (conTerm 0))+        (pevalShiftLeftTerm a s)+        ( pevalITETerm+            (pevalLeOrdTerm s (conTerm (-bs)))+            (pevalShiftRightTerm a (conTerm bs))+            (pevalShiftRightTerm a (pevalNegNumTerm s))+        )+    where+      bs = fromIntegral (finiteBitSize (0 :: IntN n)) :: IntN n+  symShiftNegated (SymIntN a) (SymIntN s) =+    SymIntN $+      pevalITETerm+        (pevalGeOrdTerm s (conTerm 0))+        (pevalShiftRightTerm a s)+        ( pevalITETerm+            (pevalLeOrdTerm s (conTerm (-bs)))+            (conTerm 0)+            (pevalShiftLeftTerm a (pevalNegNumTerm s))+        )+    where+      bs = fromIntegral (finiteBitSize (0 :: IntN n)) :: IntN n++-- SymRotate+instance (KnownNat n, 1 <= n) => SymRotate (SymWordN n) where+  symRotate (SymWordN a) (SymWordN s) = SymWordN (pevalRotateLeftTerm a s)+  symRotateNegated (SymWordN a) (SymWordN s) =+    SymWordN (pevalRotateRightTerm a s)++instance (KnownNat n, 1 <= n) => SymRotate (SymIntN n) where+  symRotate as@(SymIntN a) (SymIntN s)+    | finiteBitSize as == 1 = as+    | finiteBitSize as == 2 =+        SymIntN $+          pevalITETerm+            ( pevalOrTerm+                (pevalEqTerm s (conTerm 0))+                (pevalEqTerm s (conTerm (-2)))+            )+            a+            (pevalRotateLeftTerm a (conTerm 1))+    | otherwise =+        SymIntN $+          pevalRotateLeftTerm+            a+            ( pevalModIntegralTerm+                s+                (conTerm (fromIntegral $ finiteBitSize as))+            )+  symRotateNegated as@(SymIntN a) (SymIntN s)+    | finiteBitSize as == 1 = as+    | finiteBitSize as == 2 =+        SymIntN $+          pevalITETerm+            ( pevalOrTerm+                (pevalEqTerm s (conTerm 0))+                (pevalEqTerm s (conTerm (-2)))+            )+            a+            (pevalRotateLeftTerm a (conTerm 1))+    | otherwise =+        SymIntN $+          pevalRotateRightTerm+            a+            ( pevalModIntegralTerm+                s+                (conTerm (fromIntegral $ finiteBitSize as))+            )++#define ALLSYMS_BV(t) \+instance (KnownNat n, 1 <= n) => AllSyms (t n) where \+  allSymsS v = (SomeSym v :)++#if 1+ALLSYMS_BV(SymIntN)+ALLSYMS_BV(SymWordN)+#endif++instance (KnownNat n, 1 <= n) => BitCast (SymIntN n) (SymWordN n) where+  bitCast (SymIntN n) = SymWordN $ pevalBitCastTerm n++instance (KnownNat n, 1 <= n) => BitCast (SymWordN n) (SymIntN n) where+  bitCast (SymWordN n) = SymIntN $ pevalBitCastTerm n++instance BitCast (SymIntN 1) SymBool where+  bitCast (SymIntN v) = SymBool $ pevalBitCastTerm v++instance BitCast (SymWordN 1) SymBool where+  bitCast (SymWordN v) = SymBool $ pevalBitCastTerm v++instance BitCast SymBool (SymIntN 1) where+  bitCast (SymBool v) = SymIntN $ pevalBitCastTerm v++instance BitCast SymBool (SymWordN 1) where+  bitCast (SymBool v) = SymWordN $ pevalBitCastTerm v++instance (KnownNat n, 1 <= n) => Serial (SymWordN n) where+  serialize = serialize . underlyingWordNTerm+  deserialize = SymWordN <$> deserialize++instance (KnownNat n, 1 <= n) => Serial (SymIntN n) where+  serialize = serialize . underlyingIntNTerm+  deserialize = SymIntN <$> deserialize++instance (KnownNat n, 1 <= n) => Cereal.Serialize (SymWordN n) where+  put = serialize+  get = deserialize++instance (KnownNat n, 1 <= n) => Binary.Binary (SymWordN n) where+  put = serialize+  get = deserialize++instance (KnownNat n, 1 <= n) => Cereal.Serialize (SymIntN n) where+  put = serialize+  get = deserialize++instance (KnownNat n, 1 <= n) => Binary.Binary (SymIntN n) where+  put = serialize+  get = deserialize
+ src/Grisette/Internal/SymPrim/SymBool.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TypeFamilies #-}++-- |+-- Module      :   Grisette.Internal.SymPrim.SymBool+-- 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.SymBool (SymBool (SymBool), SymBoolKey) where++import Control.DeepSeq (NFData)+import qualified Data.Binary as Binary+import Data.Bytes.Serial (Serial (deserialize, serialize))+import Data.Hashable (Hashable (hashWithSalt))+import qualified Data.Serialize as Cereal+import Data.String (IsString (fromString))+import GHC.Generics (Generic)+import Grisette.Internal.Core.Data.Class.AsKey+  ( AsKey,+    KeyEq (keyEq),+    KeyHashable (keyHashWithSalt),+    shouldUseAsKeyHasSymbolicVersionError,+  )+import Grisette.Internal.Core.Data.Class.Function (Apply (FunType, apply))+import Grisette.Internal.Core.Data.Class.Solvable+  ( Solvable (con, conView, ssym, sym),+  )+import Grisette.Internal.Internal.Decl.SymPrim.AllSyms+  ( AllSyms (allSymsS),+    SomeSym (SomeSym),+  )+import Grisette.Internal.SymPrim.Prim.Internal.Term+  ( ConRep (ConType),+    LinkedRep (underlyingTerm, wrapTerm),+    SymRep (SymType),+    Term,+    conTerm,+    pformatTerm,+    symTerm,+    typedConstantSymbol,+    pattern ConTerm,+  )+import Language.Haskell.TH.Syntax (Lift)++-- $setup+-- >>> import Grisette.Core+-- >>> import Grisette.SymPrim+-- >>> import Grisette.Backend+-- >>> import Data.Proxy++-- | Symbolic Boolean type.+--+-- >>> "a" :: SymBool+-- a+-- >>> "a" .&& "b" :: SymBool+-- (&& a b)+--+-- More operations are available. Please refer to "Grisette.Core#g:symops" for+-- more information.+newtype SymBool = SymBool {underlyingBoolTerm :: Term Bool}+  deriving (Lift, NFData, Generic)++-- | t'SymBool' type with identity equality.+type SymBoolKey = AsKey SymBool++instance ConRep SymBool where+  type ConType SymBool = Bool++instance SymRep Bool where+  type SymType Bool = SymBool++instance LinkedRep Bool SymBool where+  underlyingTerm (SymBool a) = a+  wrapTerm = SymBool++instance Apply SymBool where+  type FunType SymBool = SymBool+  apply = id++-- | This will crash the program.+--+-- 'SymBool' cannot be compared concretely.+--+-- If you want to use the type as keys in hash maps based on term equality, say+-- memo table, you should use @'AsKey' 'SymBool'@ instead.+--+-- If you want symbolic version of the equality operator, use+-- t'Grisette.Core.SymEq' instead.+instance Eq SymBool where+  (==) = shouldUseAsKeyHasSymbolicVersionError "SymBool" "(==)" "(.==)"++instance KeyEq SymBool where+  keyEq (SymBool l) (SymBool r) = l == r++instance KeyHashable SymBool where+  keyHashWithSalt s (SymBool v) = s `hashWithSalt` v++instance Solvable Bool SymBool where+  con = SymBool . conTerm+  sym = SymBool . symTerm . typedConstantSymbol+  conView (SymBool (ConTerm t)) = Just t+  conView _ = Nothing++instance IsString SymBool where+  fromString = ssym . fromString++instance Show SymBool where+  show (SymBool t) = pformatTerm t++instance AllSyms SymBool where+  allSymsS v = (SomeSym v :)++instance Serial SymBool where+  serialize = serialize . underlyingBoolTerm+  deserialize = SymBool <$> deserialize++instance Cereal.Serialize SymBool where+  put = serialize+  get = deserialize++instance Binary.Binary SymBool where+  put = serialize+  get = deserialize
+ src/Grisette/Internal/SymPrim/SymFP.hs view
@@ -0,0 +1,566 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# 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,+    SymFPKey,+    SymFP16Key,+    SymFP32Key,+    SymFP64Key,+    SymFPRoundingMode (SymFPRoundingMode),+    SymFPRoundingModeKey,+  )+where++import Control.DeepSeq (NFData)+import qualified Data.Binary as Binary+import Data.Bytes.Serial (Serial (deserialize, serialize))+import Data.Hashable (Hashable (hashWithSalt))+import Data.Proxy (Proxy (Proxy))+import qualified Data.Serialize as Cereal+import Data.String (IsString (fromString))+import GHC.Generics (Generic)+import GHC.TypeLits (KnownNat, type (+), type (<=))+import Grisette.Internal.Core.Data.Class.AsKey+  ( AsKey,+    KeyEq (keyEq),+    KeyHashable (keyHashWithSalt),+    shouldUseAsKeyError,+    shouldUseAsKeyHasSymbolicVersionError,+  )+import Grisette.Internal.Core.Data.Class.BitCast+  ( BitCast (bitCast),+    BitCastCanonical (bitCastCanonicalValue),+    BitCastOr (bitCastOr),+  )+import Grisette.Internal.Core.Data.Class.Function (Apply (FunType, apply))+import Grisette.Internal.Core.Data.Class.IEEEFP+  ( IEEEFPConstants+      ( fpMaxNormalized,+        fpMaxSubnormal,+        fpMinNormalized,+        fpMinSubnormal,+        fpNaN,+        fpNegativeInfinite,+        fpNegativeZero,+        fpPositiveInfinite,+        fpPositiveZero+      ),+    IEEEFPConvertible (fromFPOr, toFP),+    IEEEFPOp+      ( fpAbs,+        fpMaximum,+        fpMaximumNumber,+        fpMinimum,+        fpMinimumNumber,+        fpNeg,+        fpRem+      ),+    IEEEFPRoundingMode (rna, rne, rtn, rtp, rtz),+    IEEEFPRoundingOp+      ( fpAdd,+        fpDiv,+        fpFMA,+        fpMul,+        fpRoundToIntegral,+        fpSqrt,+        fpSub+      ),+    IEEEFPToAlgReal,+  )+import Grisette.Internal.Core.Data.Class.Solvable+  ( Solvable (con, conView, ssym, sym),+  )+import Grisette.Internal.Core.Data.Class.SymIEEEFP+  ( SymIEEEFPTraits+      ( symFpIsInfinite,+        symFpIsNaN,+        symFpIsNegative,+        symFpIsNegativeInfinite,+        symFpIsNegativeZero,+        symFpIsNormal,+        symFpIsPoint,+        symFpIsPositive,+        symFpIsPositiveInfinite,+        symFpIsPositiveZero,+        symFpIsSubnormal,+        symFpIsZero+      ),+  )+import Grisette.Internal.Internal.Decl.SymPrim.AllSyms+  ( AllSyms (allSymsS),+    SomeSym (SomeSym),+  )+import Grisette.Internal.SymPrim.BV (IntN, WordN)+import Grisette.Internal.SymPrim.FP+  ( FP,+    FPRoundingMode (RNA, RNE, RTN, RTP, RTZ),+    ValidFP,+    withValidFPProofs,+  )+import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalFP ()+import Grisette.Internal.SymPrim.Prim.Internal.Term+  ( ConRep (ConType),+    FPBinaryOp (FPMaximum, FPMaximumNumber, FPMinimum, FPMinimumNumber, FPRem),+    FPRoundingBinaryOp (FPAdd, FPDiv, FPMul, FPSub),+    FPRoundingUnaryOp (FPRoundToIntegral, FPSqrt),+    FPTrait+      ( FPIsInfinite,+        FPIsNaN,+        FPIsNegative,+        FPIsNegativeInfinite,+        FPIsNegativeZero,+        FPIsNormal,+        FPIsPoint,+        FPIsPositive,+        FPIsPositiveInfinite,+        FPIsPositiveZero,+        FPIsSubnormal,+        FPIsZero+      ),+    FPUnaryOp (FPAbs, FPNeg),+    FloatingUnaryOp (FloatingSqrt),+    LinkedRep (underlyingTerm, wrapTerm),+    PEvalBitCastOrTerm (pevalBitCastOrTerm),+    PEvalBitCastTerm (pevalBitCastTerm),+    PEvalFPTerm+      ( pevalFPBinaryTerm,+        pevalFPFMATerm,+        pevalFPRoundingBinaryTerm,+        pevalFPRoundingUnaryTerm,+        pevalFPTraitTerm,+        pevalFPUnaryTerm+      ),+    PEvalFloatingTerm (pevalFloatingUnaryTerm),+    PEvalFractionalTerm (pevalFdivTerm, pevalRecipTerm),+    PEvalIEEEFPConvertibleTerm (pevalFromFPOrTerm, pevalToFPTerm),+    PEvalNumTerm+      ( pevalAbsNumTerm,+        pevalAddNumTerm,+        pevalMulNumTerm,+        pevalNegNumTerm,+        pevalSignumNumTerm+      ),+    SymRep (SymType),+    Term,+    conTerm,+    pevalSubNumTerm,+    pformatTerm,+    symTerm,+    typedConstantSymbol,+    pattern ConTerm,+  )+import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal (SymAlgReal))+import Grisette.Internal.SymPrim.SymBV (SymIntN (SymIntN), SymWordN (SymWordN))+import Grisette.Internal.SymPrim.SymBool (SymBool (SymBool))+import Grisette.Internal.SymPrim.SymInteger (SymInteger (SymInteger))+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.+--+-- >>> "a" + 2.0 :: SymFP 11 53+-- (+ a 2.0)+-- >>> fpAdd 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)++-- | t'SymFP' type with identity equality.+type SymFPKey eb sb = AsKey (SymFP eb sb)++-- | Symbolic IEEE 754 half-precision floating-point number.+type SymFP16 = SymFP 5 11++-- | Symbolic IEEE 754 single-precision floating-point number.+type SymFP32 = SymFP 8 24++-- | Symbolic IEEE 754 double-precision floating-point number.+type SymFP64 = SymFP 11 53++-- | @t'SymFP' 16@ type with identity equality.+type SymFP16Key = SymFPKey 5 11++-- | @t'SymFP' 32@ type with identity equality.+type SymFP32Key = SymFPKey 8 24++-- | @t'SymFP' 64@ type with identity equality.+type SymFP64Key = SymFPKey 11 53++instance ConRep (SymFP eb sb) where+  type ConType (SymFP eb sb) = FP eb sb++instance (ValidFP eb sb) => SymRep (FP eb sb) where+  type SymType (FP eb sb) = SymFP eb sb++instance (ValidFP eb sb) => LinkedRep (FP eb sb) (SymFP eb sb) where+  underlyingTerm (SymFP a) = a+  wrapTerm = SymFP++instance (ValidFP eb sb) => Apply (SymFP eb sb) where+  type FunType (SymFP eb sb) = SymFP eb sb+  apply = id++-- | This will crash the program.+--+-- 'SymFP' cannot be compared concretely.+--+-- If you want to use the type as keys in hash maps based on term equality, say+-- memo table, you should use @'AsKey' 'SymFP'@ instead.+--+-- If you want symbolic version of the equality operator, use+-- t'Grisette.Core.SymEq' instead.+instance (ValidFP eb sb) => Eq (SymFP eb sb) where+  (==) = shouldUseAsKeyHasSymbolicVersionError "SymFP" "(==)" "(.==)"++instance (ValidFP eb sb) => KeyEq (SymFP eb sb) where+  keyEq (SymFP l) (SymFP r) = l == r++-- | This will crash the program.+--+-- 'SymFP' cannot be hashed concretely.+--+-- If you want to use the type as keys in hash maps based on term equality, say+-- memo table, you should use @'AsKey' 'SymFP'@ instead.+instance (ValidFP eb sb) => Hashable (SymFP eb sb) where+  hashWithSalt = shouldUseAsKeyError "SymFP" "hashWithSalt"++instance (ValidFP eb sb) => KeyHashable (SymFP eb sb) where+  keyHashWithSalt s (SymFP a) = hashWithSalt s a++instance (ValidFP eb sb) => IsString (SymFP eb sb) where+  fromString = ssym . fromString++instance (ValidFP eb sb) => Solvable (FP eb sb) (SymFP eb sb) where+  con = SymFP . conTerm+  sym = SymFP . symTerm . typedConstantSymbol+  conView (SymFP (ConTerm t)) = Just t+  conView _ = Nothing++instance (ValidFP eb sb) => Show (SymFP eb sb) where+  show (SymFP a) = pformatTerm a++instance (ValidFP eb sb) => AllSyms (SymFP eb sb) where+  allSymsS v = (SomeSym v :)++instance (ValidFP eb sb) => Num (SymFP eb sb) where+  (SymFP l) + (SymFP r) = SymFP $ pevalAddNumTerm l r+  (SymFP l) - (SymFP r) = SymFP $ pevalSubNumTerm l r+  (SymFP l) * (SymFP r) = SymFP $ pevalMulNumTerm l r+  negate (SymFP v) = SymFP $ pevalNegNumTerm v+  abs (SymFP v) = SymFP $ pevalAbsNumTerm v+  signum (SymFP v) = SymFP $ pevalSignumNumTerm v+  fromInteger = con . fromInteger++instance (ValidFP eb sb) => Fractional (SymFP eb sb) where+  (SymFP l) / (SymFP r) = SymFP $ pevalFdivTerm l r+  recip (SymFP v) = SymFP $ pevalRecipTerm v+  fromRational = con . fromRational++instance (ValidFP eb sb) => Floating (SymFP eb sb) where+  pi = error "pi isn't supported by the underlying sbv library"+  exp = error "exp isn't supported by the underlying sbv library"+  log = error "log isn't supported by the underlying sbv library"+  sqrt (SymFP v) = SymFP $ pevalFloatingUnaryTerm FloatingSqrt v+  (**) = error "(**) isn't supported by the underlying sbv library"+  logBase = error "logBase isn't supported by the underlying sbv library"+  sin = error "sin isn't supported by the underlying sbv library"+  cos = error "cos isn't supported by the underlying sbv library"+  asin = error "asin isn't supported by the underlying sbv library"+  acos = error "acos isn't supported by the underlying sbv library"+  atan = error "atan isn't supported by the underlying sbv library"+  sinh = error "sinh isn't supported by the underlying sbv library"+  cosh = error "cosh isn't supported by the underlying sbv library"+  asinh = error "asinh isn't supported by the underlying sbv library"+  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)++-- | t'SymFPRoundingMode' type with identity equality.+type SymFPRoundingModeKey = AsKey SymFPRoundingMode++instance ConRep SymFPRoundingMode where+  type ConType SymFPRoundingMode = FPRoundingMode++instance SymRep FPRoundingMode where+  type SymType FPRoundingMode = SymFPRoundingMode++instance LinkedRep FPRoundingMode SymFPRoundingMode where+  underlyingTerm (SymFPRoundingMode a) = a+  wrapTerm = SymFPRoundingMode++instance Apply SymFPRoundingMode where+  type FunType SymFPRoundingMode = SymFPRoundingMode+  apply = id++-- | This will crash the program.+--+-- 'SymFPRoundingMode' cannot be compared concretely.+--+-- If you want to use the type as keys in hash maps based on term equality, say+-- memo table, you should use @'AsKey' 'SymFPRoundingMode'@ instead.+instance Eq SymFPRoundingMode where+  (==) =+    shouldUseAsKeyHasSymbolicVersionError "SymFPRoundingMode" "(==)" "(.==)"++instance KeyEq SymFPRoundingMode where+  keyEq (SymFPRoundingMode l) (SymFPRoundingMode r) = l == r++instance KeyHashable SymFPRoundingMode where+  keyHashWithSalt s (SymFPRoundingMode a) = hashWithSalt s a++instance IsString SymFPRoundingMode where+  fromString = ssym . fromString++instance Solvable FPRoundingMode SymFPRoundingMode where+  con = SymFPRoundingMode . conTerm+  sym = SymFPRoundingMode . symTerm . typedConstantSymbol+  conView (SymFPRoundingMode (ConTerm t)) = Just t+  conView _ = Nothing++instance Show SymFPRoundingMode where+  show (SymFPRoundingMode a) = pformatTerm a++instance AllSyms SymFPRoundingMode where+  allSymsS v = (SomeSym v :)++instance+  (ValidFP eb sb, r ~ (eb + sb)) =>+  BitCastCanonical (SymFP eb sb) (SymWordN r)+  where+  bitCastCanonicalValue _ =+    withValidFPProofs @eb @sb $+      con (bitCastCanonicalValue (Proxy @(FP eb sb)) :: WordN r)++instance+  (ValidFP eb sb, r ~ (eb + sb)) =>+  BitCastCanonical (SymFP eb sb) (SymIntN r)+  where+  bitCastCanonicalValue _ =+    withValidFPProofs @eb @sb $+      con (bitCastCanonicalValue (Proxy @(FP eb sb)) :: IntN r)++instance+  (ValidFP eb sb, r ~ (eb + sb)) =>+  BitCastOr (SymFP eb sb) (SymWordN r)+  where+  bitCastOr (SymWordN d) (SymFP a) =+    withValidFPProofs @eb @sb $ SymWordN (pevalBitCastOrTerm d a)++instance+  (ValidFP eb sb, r ~ (eb + sb)) =>+  BitCastOr (SymFP eb sb) (SymIntN r)+  where+  bitCastOr (SymIntN d) (SymFP a) =+    withValidFPProofs @eb @sb $ SymIntN (pevalBitCastOrTerm d a)++#define BIT_CAST_CANONICAL_VIA_INTERMEDIATE(from, to, intermediate) \+  instance BitCastCanonical (from) (to) where \+    bitCastCanonicalValue x = bitCast (bitCastCanonicalValue x :: intermediate)++instance+  (ValidFP eb sb, r ~ (eb + sb)) =>+  BitCast (SymIntN r) (SymFP eb sb)+  where+  bitCast (SymIntN a) =+    withValidFPProofs @eb @sb $ SymFP $ pevalBitCastTerm a++instance+  (ValidFP eb sb, r ~ (eb + sb)) =>+  BitCast (SymWordN r) (SymFP eb sb)+  where+  bitCast (SymWordN a) =+    withValidFPProofs @eb @sb $ SymFP $ pevalBitCastTerm a++instance (ValidFP eb sb) => IEEEFPConstants (SymFP eb sb) where+  fpPositiveInfinite = con fpPositiveInfinite+  {-# INLINE fpPositiveInfinite #-}+  fpNegativeInfinite = con fpNegativeInfinite+  {-# INLINE fpNegativeInfinite #-}+  fpNaN = con fpNaN+  {-# INLINE fpNaN #-}+  fpNegativeZero = con fpNegativeZero+  {-# INLINE fpNegativeZero #-}+  fpPositiveZero = con fpPositiveZero+  {-# INLINE fpPositiveZero #-}+  fpMinNormalized = con fpMinNormalized+  {-# INLINE fpMinNormalized #-}+  fpMinSubnormal = con fpMinSubnormal+  {-# INLINE fpMinSubnormal #-}+  fpMaxNormalized = con fpMaxNormalized+  {-# INLINE fpMaxNormalized #-}+  fpMaxSubnormal = con fpMaxSubnormal+  {-# INLINE fpMaxSubnormal #-}++instance (ValidFP eb sb) => SymIEEEFPTraits (SymFP eb sb) where+  symFpIsNaN (SymFP x) = SymBool $ pevalFPTraitTerm FPIsNaN x+  {-# INLINE symFpIsNaN #-}+  symFpIsPositive (SymFP x) = SymBool $ pevalFPTraitTerm FPIsPositive x+  {-# INLINE symFpIsPositive #-}+  symFpIsNegative (SymFP x) = SymBool $ pevalFPTraitTerm FPIsNegative x+  {-# INLINE symFpIsNegative #-}+  symFpIsInfinite (SymFP x) = SymBool $ pevalFPTraitTerm FPIsInfinite x+  {-# INLINE symFpIsInfinite #-}+  symFpIsPositiveInfinite (SymFP x) =+    SymBool $ pevalFPTraitTerm FPIsPositiveInfinite x+  {-# INLINE symFpIsPositiveInfinite #-}+  symFpIsNegativeInfinite (SymFP x) =+    SymBool $ pevalFPTraitTerm FPIsNegativeInfinite x+  {-# INLINE symFpIsNegativeInfinite #-}+  symFpIsPositiveZero (SymFP x) = SymBool $ pevalFPTraitTerm FPIsPositiveZero x+  {-# INLINE symFpIsPositiveZero #-}+  symFpIsNegativeZero (SymFP x) = SymBool $ pevalFPTraitTerm FPIsNegativeZero x+  {-# INLINE symFpIsNegativeZero #-}+  symFpIsZero (SymFP x) = SymBool $ pevalFPTraitTerm FPIsZero x+  {-# INLINE symFpIsZero #-}+  symFpIsNormal (SymFP x) = SymBool $ pevalFPTraitTerm FPIsNormal x+  {-# INLINE symFpIsNormal #-}+  symFpIsSubnormal (SymFP x) = SymBool $ pevalFPTraitTerm FPIsSubnormal x+  {-# INLINE symFpIsSubnormal #-}+  symFpIsPoint (SymFP x) = SymBool $ pevalFPTraitTerm FPIsPoint x+  {-# INLINE symFpIsPoint #-}++instance (ValidFP eb sb) => IEEEFPOp (SymFP eb sb) where+  fpAbs (SymFP l) = SymFP $ pevalFPUnaryTerm FPAbs l+  {-# INLINE fpAbs #-}+  fpNeg (SymFP l) = SymFP $ pevalFPUnaryTerm FPNeg l+  {-# INLINE fpNeg #-}+  fpRem (SymFP l) (SymFP r) = SymFP $ pevalFPBinaryTerm FPRem l r+  {-# INLINE fpRem #-}+  fpMinimum (SymFP l) (SymFP r) = SymFP $ pevalFPBinaryTerm FPMinimum l r+  {-# INLINE fpMinimum #-}+  fpMinimumNumber (SymFP l) (SymFP r) =+    SymFP $ pevalFPBinaryTerm FPMinimumNumber l r+  {-# INLINE fpMinimumNumber #-}+  fpMaximum (SymFP l) (SymFP r) = SymFP $ pevalFPBinaryTerm FPMaximum l r+  {-# INLINE fpMaximum #-}+  fpMaximumNumber (SymFP l) (SymFP r) =+    SymFP $ pevalFPBinaryTerm FPMaximumNumber l r+  {-# INLINE fpMaximumNumber #-}++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 #-}++instance (ValidFP eb sb) => IEEEFPRoundingOp (SymFP eb sb) SymFPRoundingMode where+  fpAdd (SymFPRoundingMode mode) (SymFP l) (SymFP r) =+    SymFP $ pevalFPRoundingBinaryTerm FPAdd mode l r+  {-# INLINE fpAdd #-}+  fpSub (SymFPRoundingMode mode) (SymFP l) (SymFP r) =+    SymFP $ pevalFPRoundingBinaryTerm FPSub mode l r+  {-# INLINE fpSub #-}+  fpMul (SymFPRoundingMode mode) (SymFP l) (SymFP r) =+    SymFP $ pevalFPRoundingBinaryTerm FPMul mode l r+  {-# INLINE fpMul #-}+  fpDiv (SymFPRoundingMode mode) (SymFP l) (SymFP r) =+    SymFP $ pevalFPRoundingBinaryTerm FPDiv mode l r+  {-# INLINE fpDiv #-}+  fpFMA (SymFPRoundingMode mode) (SymFP l) (SymFP m) (SymFP r) =+    SymFP $ pevalFPFMATerm mode l m r+  {-# INLINE fpFMA #-}+  fpSqrt (SymFPRoundingMode mode) (SymFP v) =+    SymFP $ pevalFPRoundingUnaryTerm FPSqrt mode v+  {-# INLINE fpSqrt #-}+  fpRoundToIntegral (SymFPRoundingMode mode) (SymFP v) =+    SymFP $ pevalFPRoundingUnaryTerm FPRoundToIntegral mode v+  {-# INLINE fpRoundToIntegral #-}++instance+  (ValidFP eb sb) =>+  IEEEFPConvertible SymInteger (SymFP eb sb) SymFPRoundingMode+  where+  fromFPOr (SymInteger d) (SymFPRoundingMode mode) (SymFP fp) =+    SymInteger $ pevalFromFPOrTerm d mode fp+  toFP (SymFPRoundingMode mode) (SymInteger v) = SymFP $ pevalToFPTerm mode v++instance+  (ValidFP eb sb) =>+  IEEEFPConvertible SymAlgReal (SymFP eb sb) SymFPRoundingMode+  where+  fromFPOr (SymAlgReal d) (SymFPRoundingMode mode) (SymFP fp) =+    SymAlgReal $ pevalFromFPOrTerm d mode fp+  toFP (SymFPRoundingMode mode) (SymAlgReal v) = SymFP $ pevalToFPTerm mode v++instance+  (ValidFP eb sb) =>+  IEEEFPToAlgReal SymAlgReal (SymFP eb sb) SymFPRoundingMode++instance+  (ValidFP eb sb, KnownNat n, 1 <= n) =>+  IEEEFPConvertible (SymWordN n) (SymFP eb sb) SymFPRoundingMode+  where+  fromFPOr (SymWordN d) (SymFPRoundingMode mode) (SymFP fp) =+    SymWordN $ pevalFromFPOrTerm d mode fp+  toFP (SymFPRoundingMode mode) (SymWordN v) = SymFP $ pevalToFPTerm mode v++instance+  (ValidFP eb sb, KnownNat n, 1 <= n) =>+  IEEEFPConvertible (SymIntN n) (SymFP eb sb) SymFPRoundingMode+  where+  fromFPOr (SymIntN d) (SymFPRoundingMode mode) (SymFP fp) =+    SymIntN $ pevalFromFPOrTerm d mode fp+  toFP (SymFPRoundingMode mode) (SymIntN v) = SymFP $ pevalToFPTerm mode v++instance+  (ValidFP eb sb, ValidFP eb' sb') =>+  IEEEFPConvertible (SymFP eb' sb') (SymFP eb sb) SymFPRoundingMode+  where+  fromFPOr (SymFP d) (SymFPRoundingMode mode) (SymFP fp) =+    SymFP $ pevalFromFPOrTerm d mode fp+  toFP (SymFPRoundingMode mode) (SymFP v) = SymFP $ pevalToFPTerm mode v++instance (ValidFP eb sb) => Serial (SymFP eb sb) where+  serialize = serialize . underlyingFPTerm+  deserialize = SymFP <$> deserialize++instance (ValidFP eb sb) => Cereal.Serialize (SymFP eb sb) where+  put = serialize+  get = deserialize++instance (ValidFP eb sb) => Binary.Binary (SymFP eb sb) where+  put = serialize+  get = deserialize
+ src/Grisette/Internal/SymPrim/SymGeneralFun.hs view
@@ -0,0 +1,252 @@+{-# HLINT ignore "Unused LANGUAGE pragma" #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++-- |+-- Module      :   Grisette.Internal.SymPrim.SymGeneralFun+-- 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.SymGeneralFun+  ( type (-~>) (SymGeneralFun),+    (-->),+  )+where++import Control.DeepSeq (NFData (rnf))+import qualified Data.Binary as Binary+import Data.Bytes.Serial (Serial (deserialize, serialize))+import Data.Hashable (Hashable (hashWithSalt))+import qualified Data.Serialize as Cereal+import Data.String (IsString (fromString))+import GHC.Generics (Generic)+import Grisette.Internal.Core.Data.Class.AsKey+  ( KeyEq (keyEq),+    KeyHashable (keyHashWithSalt),+    shouldUseAsKeyHasSymbolicVersionError,+  )+import Grisette.Internal.Core.Data.Class.Function+  ( Apply (FunType, apply),+    Function ((#)),+  )+import Grisette.Internal.Core.Data.Class.Solvable+  ( Solvable (con, conView, ssym, sym),+  )+import Grisette.Internal.Internal.Decl.SymPrim.AllSyms+  ( AllSyms (allSymsS),+    SomeSym (SomeSym),+  )+import Grisette.Internal.SymPrim.GeneralFun (buildGeneralFun, type (-->))+import Grisette.Internal.SymPrim.Prim.Term+  ( ConRep (ConType),+    LinkedRep (underlyingTerm, wrapTerm),+    PEvalApplyTerm (pevalApplyTerm),+    SupportedNonFuncPrim,+    SupportedPrim,+    SymRep (SymType),+    Term,+    TypedConstantSymbol,+    conTerm,+    pformatTerm,+    symTerm,+    typedAnySymbol,+    pattern ConTerm,+  )+import Language.Haskell.TH.Syntax (Lift (liftTyped))++-- $setup+-- >>> import Grisette.Core+-- >>> import Grisette.SymPrim+-- >>> import Grisette.Backend+-- >>> import Data.Proxy++-- |+-- Symbolic general function type.+--+-- >>> f' = "f" :: SymInteger -~> SymInteger+-- >>> f = (f' #)+-- >>> f 1+-- (apply f 1)+--+-- >>> f' = con ("a" --> "a" + 1) :: SymInteger -~> SymInteger+-- >>> f'+-- \(arg@0 :: Integer) -> (+ 1 arg@0)+-- >>> f = (f' #)+-- >>> f 1+-- 2+-- >>> f 2+-- 3+-- >>> f 3+-- 4+-- >>> f "b"+-- (+ 1 b)+data sa -~> sb where+  SymGeneralFun ::+    ( LinkedRep ca sa,+      LinkedRep cb sb,+      SupportedPrim (ca --> cb),+      SupportedNonFuncPrim ca+    ) =>+    Term (ca --> cb) ->+    sa -~> sb++infixr 0 -~>++-- | Construction of general symbolic functions.+--+-- >>> f = "a" --> "a" + 1 :: Integer --> Integer+-- >>> f+-- \(arg@0 :: Integer) -> (+ 1 arg@0)+--+-- This general symbolic function needs to be applied to symbolic values:+--+-- >>> f # ("a" :: SymInteger)+-- (+ 1 a)+-- >>> f # (2 :: SymInteger)+-- 3+(-->) ::+  (SupportedNonFuncPrim ca, SupportedPrim cb, LinkedRep cb sb) =>+  TypedConstantSymbol ca ->+  sb ->+  ca --> cb+(-->) arg = buildGeneralFun arg . underlyingTerm++infixr 0 -->++data ARG = ARG+  deriving (Eq, Ord, Lift, Show, Generic)++instance NFData ARG where+  rnf ARG = ()++instance Hashable ARG where+  hashWithSalt s ARG = s `hashWithSalt` (0 :: Int)++instance Lift (sa -~> sb) where+  liftTyped (SymGeneralFun t) = [||SymGeneralFun t||]++instance NFData (sa -~> sb) where+  rnf (SymGeneralFun t) = rnf t++instance (ConRep a, ConRep b) => ConRep (a -~> b) where+  type ConType (a -~> b) = ConType a --> ConType b++instance+  ( SymRep ca,+    SymRep cb,+    SupportedPrim (ca --> cb)+  ) =>+  SymRep (ca --> cb)+  where+  type SymType (ca --> cb) = SymType ca -~> SymType cb++instance+  ( LinkedRep ca sa,+    LinkedRep cb sb,+    SupportedPrim cb,+    SupportedPrim (ca --> cb),+    SupportedNonFuncPrim ca+  ) =>+  LinkedRep (ca --> cb) (sa -~> sb)+  where+  underlyingTerm (SymGeneralFun a) = a+  wrapTerm = SymGeneralFun++instance Function (sa -~> sb) sa sb where+  (SymGeneralFun f) # t = wrapTerm $ pevalApplyTerm f (underlyingTerm t)++instance (Apply st) => Apply (sa -~> st) where+  type FunType (sa -~> st) = sa -> FunType st+  apply uf a = apply (uf # a)++instance+  ( SupportedNonFuncPrim ca,+    LinkedRep ca sa,+    LinkedRep cb sb,+    SupportedPrim (ca --> cb)+  ) =>+  Solvable (ca --> cb) (sa -~> sb)+  where+  con = SymGeneralFun . conTerm+  sym = SymGeneralFun . symTerm . typedAnySymbol+  conView (SymGeneralFun (ConTerm t)) = Just t+  conView _ = Nothing++instance+  ( SupportedPrim (ca --> cb),+    SupportedNonFuncPrim ca,+    LinkedRep ca sa,+    LinkedRep cb sb+  ) =>+  IsString (sa -~> sb)+  where+  fromString = ssym . fromString++instance Show (sa -~> sb) where+  show (SymGeneralFun t) = pformatTerm t++-- | This will crash the program.+--+-- 'SymGeneralFun' cannot be compared concretely.+--+-- If you want to use the type as keys in hash maps based on term equality, say+-- memo table, you should use @'AsKey' 'SymGeneralFun'@ instead.+instance Eq (sa -~> sb) where+  (==) = shouldUseAsKeyHasSymbolicVersionError "SymGeneralFun" "(==)" "(.==)"++instance KeyEq (sa -~> sb) where+  keyEq (SymGeneralFun l) (SymGeneralFun r) = l == r++instance KeyHashable (sa -~> sb) where+  keyHashWithSalt s (SymGeneralFun v) = hashWithSalt s v++instance AllSyms (sa -~> sb) where+  allSymsS v@SymGeneralFun {} = (SomeSym v :)++instance+  ( LinkedRep ca sa,+    LinkedRep cb sb,+    SupportedPrim (ca --> cb),+    SupportedNonFuncPrim ca+  ) =>+  Serial (sa -~> sb)+  where+  serialize = serialize . underlyingTerm+  deserialize = SymGeneralFun <$> deserialize++instance+  ( LinkedRep ca sa,+    LinkedRep cb sb,+    SupportedPrim (ca --> cb),+    SupportedNonFuncPrim ca+  ) =>+  Cereal.Serialize (sa -~> sb)+  where+  put = serialize+  get = deserialize++instance+  ( LinkedRep ca sa,+    LinkedRep cb sb,+    SupportedPrim (ca --> cb),+    SupportedNonFuncPrim ca+  ) =>+  Binary.Binary (sa -~> sb)+  where+  put = serialize+  get = deserialize
+ src/Grisette/Internal/SymPrim/SymInteger.hs view
@@ -0,0 +1,210 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TypeFamilies #-}++-- |+-- Module      :   Grisette.Internal.SymPrim.SymInteger+-- 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.SymInteger+  ( SymInteger (SymInteger),+    SymIntegerKey,+  )+where++import Control.DeepSeq (NFData)+import qualified Data.Binary as Binary+import Data.Bytes.Serial (Serial (deserialize, serialize))+import Data.Hashable (Hashable (hashWithSalt))+import qualified Data.Serialize as Cereal+import Data.String (IsString (fromString))+import GHC.Generics (Generic)+import Grisette.Internal.Core.Data.Class.AsKey+  ( AsKey,+    KeyEq (keyEq),+    KeyHashable (keyHashWithSalt),+    shouldUseAsKeyHasSymbolicVersionError,+    shouldUseSymbolicVersionError,+  )+import Grisette.Internal.Core.Data.Class.Function (Apply (FunType, apply))+import Grisette.Internal.Core.Data.Class.Solvable+  ( Solvable (con, conView, ssym, sym),+  )+import Grisette.Internal.Internal.Decl.SymPrim.AllSyms+  ( AllSyms (allSymsS),+    SomeSym (SomeSym),+  )+import Grisette.Internal.SymPrim.Prim.Term+  ( ConRep (ConType),+    LinkedRep (underlyingTerm, wrapTerm),+    PEvalNumTerm+      ( pevalAbsNumTerm,+        pevalAddNumTerm,+        pevalMulNumTerm,+        pevalNegNumTerm,+        pevalSignumNumTerm+      ),+    SymRep (SymType),+    Term,+    conTerm,+    pevalDivIntegralTerm,+    pevalITETerm,+    pevalLeOrdTerm,+    pevalModIntegralTerm,+    pevalQuotIntegralTerm,+    pevalRemIntegralTerm,+    pevalSubNumTerm,+    pformatTerm,+    symTerm,+    typedConstantSymbol,+    pattern ConTerm,+  )+import Language.Haskell.TH.Syntax (Lift)++-- $setup+-- >>> import Grisette.Core+-- >>> import Grisette.SymPrim+-- >>> import Grisette.Backend+-- >>> import Data.Proxy++-- | Symbolic (unbounded, mathematical) integer type.+--+-- >>> "a" + 1 :: SymInteger+-- (+ 1 a)+--+-- More operations are available. Please refer to "Grisette.Core#g:symops" for+-- more information.+newtype SymInteger = SymInteger {underlyingIntegerTerm :: Term Integer}+  deriving (Lift, NFData, Generic)++-- | t'SymInteger' type with identity equality.+type SymIntegerKey = AsKey SymInteger++instance ConRep SymInteger where+  type ConType SymInteger = Integer++instance SymRep Integer where+  type SymType Integer = SymInteger++instance LinkedRep Integer SymInteger where+  underlyingTerm (SymInteger a) = a+  wrapTerm = SymInteger++instance Apply SymInteger where+  type FunType SymInteger = SymInteger+  apply = id++instance Num SymInteger where+  (SymInteger l) + (SymInteger r) = SymInteger $ pevalAddNumTerm l r+  (SymInteger l) - (SymInteger r) = SymInteger $ pevalSubNumTerm l r+  (SymInteger l) * (SymInteger r) = SymInteger $ pevalMulNumTerm l r+  negate (SymInteger v) = SymInteger $ pevalNegNumTerm v+  abs (SymInteger v) = SymInteger $ pevalAbsNumTerm v+  signum (SymInteger v) = SymInteger $ pevalSignumNumTerm v+  fromInteger = con++{-# NOINLINE [1] enumDeltaSymInteger #-}+enumDeltaSymInteger :: SymInteger -> SymInteger -> [SymInteger]+enumDeltaSymInteger x d = x `seq` (x : enumDeltaSymInteger (d + x) d)++instance Enum SymInteger where+  succ x = x + 1+  pred x = x - 1+  toEnum = fromIntegral+  fromEnum = error "fromEnum: fromEnum isn't supported for SymInteger"+  enumFrom x = enumDeltaSymInteger x 1+  {-# INLINE enumFrom #-}+  enumFromThen x y = enumDeltaSymInteger x (y - x)+  {-# INLINE enumFromThen #-}+  enumFromTo = error "enumFromTo: enumFromTo isn't supported for SymInteger"+  enumFromThenTo =+    error "enumFromThenTo: enumFromThenTo isn't supported for SymInteger"++-- | Except for 'max' and 'min', the other functions will crash the program.+--+-- 'SymInteger' cannot be compared concretely.+--+-- If you want symbolic version of the comparison operators, use+-- t'Grisette.Core.SymOrd' instead.+instance Ord SymInteger where+  (<) = shouldUseSymbolicVersionError "SymInteger" "(<)" "(.<)"+  (<=) = shouldUseSymbolicVersionError "SymInteger" "(<=)" "(.<=)"+  (>=) = shouldUseSymbolicVersionError "SymInteger" "(>=)" "(.>=)"+  (>) = shouldUseSymbolicVersionError "SymInteger" "(>)" "(.>)"+  max (SymInteger l) (SymInteger r) =+    SymInteger $ pevalITETerm (pevalLeOrdTerm l r) r l+  min (SymInteger l) (SymInteger r) =+    SymInteger $ pevalITETerm (pevalLeOrdTerm l r) l r+  compare = shouldUseSymbolicVersionError "SymInteger" "compare" "symCompare"++instance Real SymInteger where+  toRational _ = error "toRational: toRational isn't supported for SymInteger"++-- | The functions are total and will not throw errors. The result is considered+-- undefined if the divisor is 0.+--+-- It is the responsibility of the caller to ensure that the divisor is not+-- zero with the symbolic constraints, or use the t'Grisette.Core.DivOr' or+-- t'Grisette.Core.SafeDiv' classes.+instance Integral SymInteger where+  toInteger = error "toInteger: toInteger isn't supported for SymInteger"+  div (SymInteger l) (SymInteger r) = SymInteger $ pevalDivIntegralTerm l r+  mod (SymInteger l) (SymInteger r) = SymInteger $ pevalModIntegralTerm l r+  quot (SymInteger l) (SymInteger r) = SymInteger $ pevalQuotIntegralTerm l r+  rem (SymInteger l) (SymInteger r) = SymInteger $ pevalRemIntegralTerm l r+  divMod (SymInteger l) (SymInteger r) =+    (SymInteger $ pevalDivIntegralTerm l r, SymInteger $ pevalModIntegralTerm l r)+  quotRem (SymInteger l) (SymInteger r) =+    (SymInteger $ pevalQuotIntegralTerm l r, SymInteger $ pevalRemIntegralTerm l r)++-- | This will crash the program.+--+-- 'SymInteger' cannot be compared concretely.+--+-- If you want to use the type as keys in hash maps based on term equality, say+-- memo table, you should use @'AsKey' 'SymInteger'@ instead.+--+-- If you want symbolic version of the equality operator, use+-- t'Grisette.Core.SymEq' instead.+instance Eq SymInteger where+  (==) = shouldUseAsKeyHasSymbolicVersionError "SymInteger" "(==)" "(.==)"++instance KeyEq SymInteger where+  keyEq (SymInteger l) (SymInteger r) = l == r++instance KeyHashable SymInteger where+  keyHashWithSalt s (SymInteger v) = s `hashWithSalt` v++instance Solvable Integer SymInteger where+  con = SymInteger . conTerm+  sym = SymInteger . symTerm . typedConstantSymbol+  conView (SymInteger (ConTerm t)) = Just t+  conView _ = Nothing++instance IsString SymInteger where+  fromString = ssym . fromString++instance Show SymInteger where+  show (SymInteger t) = pformatTerm t++instance AllSyms SymInteger where+  allSymsS v = (SomeSym v :)++instance Serial SymInteger where+  serialize = serialize . underlyingIntegerTerm+  deserialize = SymInteger <$> deserialize++instance Cereal.Serialize SymInteger where+  put = serialize+  get = deserialize++instance Binary.Binary SymInteger where+  put = serialize+  get = deserialize
+ src/Grisette/Internal/SymPrim/SymPrim.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeOperators #-}++-- |+-- Module      :   Grisette.Internal.SymPrim.SymPrim+-- 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.SymPrim (Prim, SymPrim, BasicSymPrim) where++import Control.DeepSeq (NFData)+import Data.Binary (Binary)+import Data.Bytes.Serial (Serial)+import Data.Serialize (Serialize)+import Grisette.Internal.Core.Data.Class.AsKey (KeyEq, KeyHashable)+import Grisette.Internal.Core.Data.Class.EvalSym (EvalSym)+import Grisette.Internal.Core.Data.Class.ExtractSym (ExtractSym)+import Grisette.Internal.Core.Data.Class.Function (Apply (FunType))+import Grisette.Internal.Core.Data.Class.GenSym (GenSymSimple)+import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp)+import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable)+import Grisette.Internal.Core.Data.Class.SimpleMergeable (SimpleMergeable)+import Grisette.Internal.Core.Data.Class.Solvable (Solvable)+import Grisette.Internal.Core.Data.Class.SubstSym (SubstSym)+import Grisette.Internal.Core.Data.Class.ToCon (ToCon)+import Grisette.Internal.Core.Data.Class.ToSym (ToSym)+import Grisette.Internal.Internal.Decl.Core.Data.Class.PPrint (PPrint)+import Grisette.Internal.Internal.Decl.Core.Data.Class.SymEq (SymEq)+import Grisette.Internal.Internal.Decl.Core.Data.Class.SymOrd (SymOrd)+import Grisette.Internal.SymPrim.AllSyms (AllSyms)+import Grisette.Internal.SymPrim.Prim.Internal.Term+  ( ConRep (ConType),+    LinkedRep,+    SupportedNonFuncPrim,+  )+import Language.Haskell.TH.Syntax (Lift)+import Type.Reflection (Typeable)++-- | A type that is used as a constraint for all the primitive types (including+-- concrete primitives) in Grisette.+type Prim a =+  ( Show a,+    Binary a,+    Serial a,+    Serialize a,+    NFData a,+    Eq a,+    EvalSym a,+    ExtractSym a,+    Mergeable a,+    PPrint a,+    SubstSym a,+    SymEq a,+    SymOrd a,+    AllSyms a,+    KeyEq a,+    KeyHashable a,+    Lift a,+    Typeable a+  )++-- | A type that is used as a constraint for all the symbolic primitive types+-- in Grisette.+type SymPrim a =+  ( Prim a,+    ITEOp a,+    GenSymSimple a a+  )++-- | A type that is used as a constraint for all the basic symbolic primitive+-- types in Grisette.+--+-- 'Grisette.SymPrim.SomeSymWordN' is not considered as a basic symbolic+-- primitive type.+type BasicSymPrim a =+  ( SymPrim a,+    SimpleMergeable a,+    GenSymSimple () a,+    Solvable (ConType a) a,+    ConRep a,+    LinkedRep (ConType a) a,+    ToCon a (ConType a),+    ToSym (ConType a) a,+    Apply a,+    a ~ FunType a,+    SupportedNonFuncPrim (ConType a)+  )
+ src/Grisette/Internal/SymPrim/SymTabularFun.hs view
@@ -0,0 +1,206 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Unused LANGUAGE pragma" #-}++-- |+-- Module      :   Grisette.Internal.SymPrim.SymTabularFun+-- 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.SymTabularFun+  ( type (=~>) (SymTabularFun),+  )+where++import Control.DeepSeq (NFData (rnf))+import qualified Data.Binary as Binary+import Data.Bytes.Serial (Serial (deserialize, serialize))+import Data.Hashable (Hashable (hashWithSalt))+import qualified Data.Serialize as Cereal+import Data.String (IsString (fromString))+import Grisette.Internal.Core.Data.Class.AsKey+  ( KeyEq (keyEq),+    KeyHashable (keyHashWithSalt),+    shouldUseAsKeyHasSymbolicVersionError,+  )+import Grisette.Internal.Core.Data.Class.Function+  ( Apply (FunType, apply),+    Function ((#)),+  )+import Grisette.Internal.Core.Data.Class.Solvable+  ( Solvable (con, conView, ssym, sym),+  )+import Grisette.Internal.Internal.Decl.SymPrim.AllSyms+  ( AllSyms (allSymsS),+    SomeSym (SomeSym),+  )+import Grisette.Internal.SymPrim.Prim.Term+  ( ConRep (ConType),+    LinkedRep (underlyingTerm, wrapTerm),+    PEvalApplyTerm (pevalApplyTerm),+    SupportedNonFuncPrim,+    SupportedPrim,+    SymRep (SymType),+    Term,+    conTerm,+    pformatTerm,+    symTerm,+    typedAnySymbol,+    pattern ConTerm,+  )+import Grisette.Internal.SymPrim.TabularFun (type (=->))+import Language.Haskell.TH.Syntax (Lift (liftTyped))++-- $setup+-- >>> import Grisette.Core+-- >>> import Grisette.SymPrim+-- >>> import Grisette.Backend+-- >>> import Data.Proxy++-- | Symbolic tabular function type.+--+-- >>> f' = "f" :: SymInteger =~> SymInteger+-- >>> f = (f' #)+-- >>> f 1+-- (apply f 1)+--+-- >>> f' = con (TabularFun [(1, 2), (2, 3)] 4) :: SymInteger =~> SymInteger+-- >>> f = (f' #)+-- >>> f 1+-- 2+-- >>> f 2+-- 3+-- >>> f 3+-- 4+-- >>> f "b"+-- (ite (= b 1) 2 (ite (= b 2) 3 4))+data sa =~> sb where+  SymTabularFun ::+    ( LinkedRep ca sa,+      LinkedRep cb sb,+      SupportedPrim (ca =-> cb),+      SupportedNonFuncPrim ca+    ) =>+    Term (ca =-> cb) ->+    sa =~> sb++infixr 0 =~>++instance Lift (sa =~> sb) where+  liftTyped (SymTabularFun t) = [||SymTabularFun t||]++instance NFData (sa =~> sb) where+  rnf (SymTabularFun t) = rnf t++instance (ConRep a, ConRep b) => ConRep (a =~> b) where+  type ConType (a =~> b) = ConType a =-> ConType b++instance (SymRep a, SymRep b, SupportedPrim (a =-> b)) => SymRep (a =-> b) where+  type SymType (a =-> b) = SymType a =~> SymType b++instance+  ( LinkedRep ca sa,+    LinkedRep cb sb,+    SupportedPrim (ca =-> cb),+    SupportedNonFuncPrim ca+  ) =>+  LinkedRep (ca =-> cb) (sa =~> sb)+  where+  underlyingTerm (SymTabularFun a) = a+  wrapTerm = SymTabularFun++instance Function (sa =~> sb) sa sb where+  (SymTabularFun f) # t = wrapTerm $ pevalApplyTerm f (underlyingTerm t)++instance (Apply st) => Apply (sa =~> st) where+  type FunType (sa =~> st) = sa -> FunType st+  apply uf a = apply (uf # a)++instance+  ( LinkedRep ca sa,+    LinkedRep cb sb,+    SupportedPrim (ca =-> cb),+    SupportedNonFuncPrim ca+  ) =>+  Solvable (ca =-> cb) (sa =~> sb)+  where+  con = SymTabularFun . conTerm+  sym = SymTabularFun . symTerm . typedAnySymbol+  conView (SymTabularFun (ConTerm t)) = Just t+  conView _ = Nothing++instance+  ( SupportedPrim (ca =-> cb),+    LinkedRep ca sa,+    LinkedRep cb sb,+    SupportedNonFuncPrim ca+  ) =>+  IsString (sa =~> sb)+  where+  fromString = ssym . fromString++instance Show (sa =~> sb) where+  show (SymTabularFun t) = pformatTerm t++-- | This will crash the program.+--+-- 'SymTabularFun' cannot be compared concretely.+--+-- If you want to use the type as keys in hash maps based on term equality, say+-- memo table, you should use @'AsKey' 'SymTabularFun'@ instead.+instance Eq (sa =~> sb) where+  (==) = shouldUseAsKeyHasSymbolicVersionError "SymTabularFun" "(==)" "(.==)"++instance KeyEq (sa =~> sb) where+  keyEq (SymTabularFun l) (SymTabularFun r) = l == r++instance KeyHashable (sa =~> sb) where+  keyHashWithSalt s (SymTabularFun v) = hashWithSalt s v++instance AllSyms (sa =~> sb) where+  allSymsS v@SymTabularFun {} = (SomeSym v :)++instance+  ( LinkedRep ca sa,+    LinkedRep cb sb,+    SupportedPrim (ca =-> cb),+    SupportedNonFuncPrim ca+  ) =>+  Serial (sa =~> sb)+  where+  serialize = serialize . underlyingTerm+  deserialize = SymTabularFun <$> deserialize++instance+  ( LinkedRep ca sa,+    LinkedRep cb sb,+    SupportedPrim (ca =-> cb),+    SupportedNonFuncPrim ca+  ) =>+  Cereal.Serialize (sa =~> sb)+  where+  put = serialize+  get = deserialize++instance+  ( LinkedRep ca sa,+    LinkedRep cb sb,+    SupportedPrim (ca =-> cb),+    SupportedNonFuncPrim ca+  ) =>+  Binary.Binary (sa =~> sb)+  where+  put = serialize+  get = deserialize
+ src/Grisette/Internal/SymPrim/TabularFun.hs view
@@ -0,0 +1,201 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# HLINT ignore "Eta reduce" #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Avoid lambda" #-}++-- |+-- Module      :   Grisette.Internal.SymPrim.TabularFun+-- 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.SymPrim.TabularFun+  ( type (=->) (..),+  )+where++import Control.DeepSeq (NFData, NFData1)+import Data.Bifunctor (Bifunctor (second))+import qualified Data.Binary as Binary+import Data.Bytes.Serial (Serial (deserialize, serialize))+import Data.Hashable (Hashable)+import qualified Data.SBV as SBV+import qualified Data.SBV.Dynamic as SBVD+import qualified Data.Serialize as Cereal+import GHC.Generics (Generic, Generic1)+import Grisette.Internal.Core.Data.Class.Function+  ( Apply (FunType, apply),+    Function ((#)),+  )+import Grisette.Internal.SymPrim.FunInstanceGen (supportedPrimFunUpTo)+import Grisette.Internal.SymPrim.Prim.Internal.PartialEval (totalize2)+import Grisette.Internal.SymPrim.Prim.Internal.Term+  ( NonFuncPrimConstraint,+    NonFuncSBVRep (NonFuncSBVBaseType),+    PEvalApplyTerm (pevalApplyTerm, sbvApplyTerm),+    SBVRep (SBVType),+    SupportedNonFuncPrim (conNonFuncSBVTerm, withNonFuncPrim),+    SupportedPrim+      ( conSBVTerm,+        defaultValue,+        parseSMTModelResult,+        pevalITETerm,+        withPrim+      ),+    SupportedPrimConstraint (PrimConstraint),+    Term,+    applyTerm,+    conTerm,+    partitionCVArg,+    pevalEqTerm,+    pevalITEBasicTerm,+    pattern ConTerm,+    pattern ITETerm,+  )+import Language.Haskell.TH.Syntax (Lift)++-- $setup+-- >>> import Grisette.Core+-- >>> import Grisette.SymPrim++-- |+-- Functions as a table. Use the `#` operator to apply the function.+--+-- >>> let f = TabularFun [(1, 2), (3, 4)] 0 :: Int =-> Int+-- >>> f # 1+-- 2+-- >>> f # 2+-- 0+-- >>> f # 3+-- 4+data (=->) a b = TabularFun {funcTable :: [(a, b)], defaultFuncValue :: b}+  deriving (Show, Eq, Generic, Generic1, Lift, NFData, NFData1, Serial)++instance (Serial a, Serial b) => Cereal.Serialize (a =-> b) where+  put = serialize+  get = deserialize++instance (Serial a, Serial b) => Binary.Binary (a =-> b) where+  put = serialize+  get = deserialize++infixr 0 =->++instance (Eq a) => Function (a =-> b) a b where+  (TabularFun table d) # a = go table+    where+      go [] = d+      go ((av, bv) : s)+        | a == av = bv+        | otherwise = go s++instance (Hashable a, Hashable b) => Hashable (a =-> b)++instance+  (SupportedNonFuncPrim a, SupportedPrim b) =>+  SupportedPrimConstraint (a =-> b)+  where+  type+    PrimConstraint (a =-> b) =+      ( SupportedNonFuncPrim a,+        SupportedPrim b,+        NonFuncPrimConstraint a,+        PrimConstraint b+      )++instance (SupportedNonFuncPrim a, SupportedPrim b) => SBVRep (a =-> b) where+  type SBVType (a =-> b) = SBV.SBV (NonFuncSBVBaseType a) -> SBVType b++instance+  (SupportedPrim a, SupportedPrim b, Eq a, SupportedPrim (a =-> b)) =>+  PEvalApplyTerm (a =-> b) a b+  where+  pevalApplyTerm = totalize2 doPevalApplyTerm applyTerm+    where+      doPevalApplyTerm ::+        (SupportedPrim a, SupportedPrim b) =>+        Term (a =-> b) ->+        Term a ->+        Maybe (Term b)+      doPevalApplyTerm (ConTerm f) (ConTerm a) = Just $ conTerm $ f # a+      doPevalApplyTerm (ConTerm (TabularFun f d)) a = Just $ go f+        where+          go [] = conTerm d+          go ((x, y) : xs) =+            pevalITETerm (pevalEqTerm a (conTerm x)) (conTerm y) (go xs)+      doPevalApplyTerm (ITETerm cond t f) v =+        Just $ pevalITETerm cond (pevalApplyTerm t v) (pevalApplyTerm f v)+      doPevalApplyTerm _ _ = Nothing+  sbvApplyTerm f a =+    withPrim @(a =-> b) $ withNonFuncPrim @a $ f a++instance (Apply t, Eq a) => Apply (a =-> t) where+  type FunType (a =-> t) = a -> FunType t+  apply uf a = apply (uf # a)++lowerTFunCon ::+  forall a b.+  ( SupportedNonFuncPrim a,+    SupportedPrim b,+    SBV.Mergeable (SBVType b)+  ) =>+  (a =-> b) ->+  ( SBV.SBV (NonFuncSBVBaseType a) ->+    SBVType b+  )+lowerTFunCon (TabularFun l d) = withNonFuncPrim @a $ go l d+  where+    go [] d _ = conSBVTerm d+    go ((x, r) : xs) d v =+      SBV.ite (conNonFuncSBVTerm x SBV..== v) (conSBVTerm r) (go xs d v)++parseTabularFunSMTModelResult ::+  forall a b.+  (SupportedNonFuncPrim a, SupportedPrim b) =>+  Int ->+  ([([SBVD.CV], SBVD.CV)], SBVD.CV) ->+  a =-> b+parseTabularFunSMTModelResult level (l, s) =+  TabularFun+    ( second+        ( \r ->+            case r of+              [([], v)] -> parseSMTModelResult (level + 1) ([], v)+              _ -> parseSMTModelResult (level + 1) (r, s)+        )+        <$> partitionCVArg @a l+    )+    (parseSMTModelResult (level + 1) ([], s))++supportedPrimFunUpTo+  [|TabularFun [] defaultValue|]+  [|pevalITEBasicTerm|]+  [|parseTabularFunSMTModelResult|]+  ( \tyVars ->+      [|+        \f ->+          withNonFuncPrim @($(last tyVars)) $+            lowerTFunCon f+        |]+  )+  "TabularFun"+  "tfunc"+  ''(=->)+  8
+ src/Grisette/Internal/TH/ADT.hs view
@@ -0,0 +1,201 @@+-- |+-- Module      :   Grisette.Internal.TH.ADT+-- Copyright   :   (c) Sirui Lu 2025+-- License     :   BSD-3-Clause (see the LICENSE file)+--+-- Maintainer  :   siruilu@cs.washington.edu+-- Stability   :   Experimental+-- Portability :   GHC only+module Grisette.Internal.TH.ADT+  ( makeGrisetteADTWithClasses,+    makeGrisetteBasicADT,+    makeGrisetteBasicADT1,+    makeGrisetteBasicADT2,+    makeGrisetteBasicADTWith,+    makeGrisetteBasicADT1With,+    makeGrisetteBasicADT2With,+    makeGrisetteADT,+    makeGrisetteADT1,+    makeGrisetteADT2,+    makeGrisetteADTWith,+    makeGrisetteADT1With,+    makeGrisetteADT2With,+  )+where++import Grisette.Internal.TH.Ctor.SmartConstructor (makeSmartCtor)+import Grisette.Internal.TH.Derivation.Common (DeriveConfig)+import Grisette.Internal.TH.Derivation.Derive+  ( allClasses0,+    allClasses01,+    allClasses012,+    basicClasses0,+    basicClasses01,+    basicClasses012,+    deriveWith,+  )+import Language.Haskell.TH (Dec, Name, Q)++-- | Make an ADT compatible with Grisette.+--+-- This will generate instances for the ADT with the given classes,+-- and smart constructors for each constructor.+--+-- The derivation is done with the given configuration.+makeGrisetteADTWithClasses :: DeriveConfig -> Name -> [Name] -> Q [Dec]+makeGrisetteADTWithClasses config name classes = do+  instances <- deriveWith config [name] classes+  ctors <- makeSmartCtor name+  return (instances ++ ctors)++-- | Make an ADT compatible with Grisette.+--+-- This will generate most useful instances for the ADT,+-- and smart constructors for each constructor.+--+-- This does not include 'Ord' instances.+--+-- See 'derive', 'basicClasses0', and 'makeSmartCtor' for more details.+makeGrisetteBasicADT :: Name -> Q [Dec]+makeGrisetteBasicADT = makeGrisetteBasicADTWith mempty++-- | Make an ADT compatible with Grisette.+--+-- This will generate most useful instances for the ADT,+-- and smart constructors for each constructor.+--+-- This does not include 'Ord' instances.+--+-- The derivation is done with the given configuration.+--+-- See 'deriveWith', 'basicClasses0', and 'makeSmartCtor' for more details.+makeGrisetteBasicADTWith :: DeriveConfig -> Name -> Q [Dec]+makeGrisetteBasicADTWith config name =+  makeGrisetteADTWithClasses config name basicClasses0++-- | Make an ADT compatible with Grisette.+--+-- This will generate most useful instances for the ADT,+-- and smart constructors for each constructor.+--+-- This does not include 'Ord' instances.+--+-- See 'derive', 'basicClasses01', and 'makeSmartCtor' for more details.+makeGrisetteBasicADT1 :: Name -> Q [Dec]+makeGrisetteBasicADT1 name =+  makeGrisetteADTWithClasses mempty name basicClasses01++-- | Make an ADT compatible with Grisette.+--+-- This will generate most useful instances for the ADT,+-- and smart constructors for each constructor.+--+-- This does not include 'Ord' instances.+--+-- The derivation is done with the given configuration.+--+-- See 'deriveWith', 'basicClasses01', and 'makeSmartCtor' for more details.+makeGrisetteBasicADT1With :: DeriveConfig -> Name -> Q [Dec]+makeGrisetteBasicADT1With config name =+  makeGrisetteADTWithClasses config name basicClasses01++-- | Make an ADT compatible with Grisette.+--+-- This will generate most useful instances for the ADT,+-- and smart constructors for each constructor.+--+-- This does not include 'Ord' instances.+--+-- See 'derive', 'basicClasses012', and 'makeSmartCtor' for more details.+makeGrisetteBasicADT2 :: Name -> Q [Dec]+makeGrisetteBasicADT2 name =+  makeGrisetteADTWithClasses mempty name basicClasses012++-- | Make an ADT compatible with Grisette.+--+-- This will generate most useful instances for the ADT,+-- and smart constructors for each constructor.+--+-- This does not include 'Ord' instances.+--+-- The derivation is done with the given configuration.+--+-- See 'deriveWith', 'basicClasses012', and 'makeSmartCtor' for more details.+makeGrisetteBasicADT2With :: DeriveConfig -> Name -> Q [Dec]+makeGrisetteBasicADT2With config name =+  makeGrisetteADTWithClasses config name basicClasses012++-- | Make an ADT compatible with Grisette.+--+-- This will generate almost all useful instances for the ADT,+-- and smart constructors for each constructor.+--+-- This cannot be used for ADTs with existential type variables.+--+-- See 'derive', 'allClasses0', and 'makeSmartCtor' for more details.+makeGrisetteADT :: Name -> Q [Dec]+makeGrisetteADT = makeGrisetteADTWith mempty++-- | Make an ADT compatible with Grisette.+--+-- This will generate almost all useful instances for the ADT,+-- and smart constructors for each constructor.+--+-- This cannot be used for ADTs with existential type variables.+--+-- The derivation is done with the given configuration.+--+-- See 'deriveWith', 'allClasses0', and 'makeSmartCtor' for more details.+makeGrisetteADTWith :: DeriveConfig -> Name -> Q [Dec]+makeGrisetteADTWith config name =+  makeGrisetteADTWithClasses config name allClasses0++-- | Make an ADT compatible with Grisette.+--+-- This will generate almost all useful instances for the ADT,+-- and smart constructors for each constructor.+--+-- This cannot be used for ADTs with existential type variables.+--+-- See 'derive', 'allClasses01', and 'makeSmartCtor' for more details.+makeGrisetteADT1 :: Name -> Q [Dec]+makeGrisetteADT1 = makeGrisetteADT1With mempty++-- | Make an ADT compatible with Grisette.+--+-- This will generate almost all useful instances for the ADT,+-- and smart constructors for each constructor.+--+-- This cannot be used for ADTs with existential type variables.+--+-- The derivation is done with the given configuration.+--+-- See 'deriveWith', 'allClasses01', and 'makeSmartCtor' for more details.+makeGrisetteADT1With :: DeriveConfig -> Name -> Q [Dec]+makeGrisetteADT1With config name =+  makeGrisetteADTWithClasses config name allClasses01++-- | Make an ADT compatible with Grisette.+--+-- This will generate almost all useful instances for the ADT,+-- and smart constructors for each constructor.+--+-- This cannot be used for ADTs with existential type variables.+--+-- See 'derive', 'allClasses012', and 'makeSmartCtor' for more details.+makeGrisetteADT2 :: Name -> Q [Dec]+makeGrisetteADT2 = makeGrisetteADT2With mempty++-- | Make an ADT compatible with Grisette.+--+-- This will generate almost all useful instances for the ADT,+-- and smart constructors for each constructor.+--+-- This cannot be used for ADTs with existential type variables.+--+-- The derivation is done with the given configuration.+--+-- See 'deriveWith', 'allClasses012', and 'makeSmartCtor' for more details.+makeGrisetteADT2With :: DeriveConfig -> Name -> Q [Dec]+makeGrisetteADT2With config name =+  makeGrisetteADTWithClasses config name allClasses012
+ src/Grisette/Internal/TH/Ctor/Common.hs view
@@ -0,0 +1,60 @@+-- |+-- Module      :   Grisette.Internal.TH.Ctor.Common+-- 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.Ctor.Common+  ( withNameTransformer,+    prefixTransformer,+    decapitalizeTransformer,+  )+where++import Control.Monad (unless)+import Data.Char (isAlphaNum, toLower)+import Data.Foldable (traverse_)+import Language.Haskell.TH (Dec, Name, Q, nameBase)+import Language.Haskell.TH.Datatype+  ( ConstructorInfo (constructorName),+    DatatypeInfo (datatypeCons),+    reifyDatatype,+  )++checkName :: String -> Q ()+checkName name =+  unless (all (\x -> isAlphaNum x || x == '\'' || x == '_') name) $+    fail+      ( "Constructor name contain invalid characters, consider providing a "+          ++ "custom name: "+          ++ show name+      )++-- | Generate smart constructor given a type name, using a name transformer+-- to transform constructor names.+withNameTransformer ::+  -- | A function that generates decs given a list of constructor names and a+  -- type name+  ([String] -> Name -> Q [Dec]) ->+  -- | A function that transforms constructor names+  (String -> String) ->+  -- | The type to generate the wrappers for+  Name ->+  Q [Dec]+withNameTransformer namedGen nameTransformer typName = do+  d <- reifyDatatype typName+  let constructorNames = nameBase . constructorName <$> datatypeCons d+  let transformedNames = nameTransformer <$> constructorNames+  traverse_ checkName transformedNames+  namedGen transformedNames typName++-- | A name transformer that prefixes a string to the constructor name+prefixTransformer :: String -> String -> String+prefixTransformer = (++)++-- | A name transformer that converts the first character to lowercase+decapitalizeTransformer :: String -> String+decapitalizeTransformer (x : xs) = toLower x : xs+decapitalizeTransformer [] = []
+ src/Grisette/Internal/TH/Ctor/SmartConstructor.hs view
@@ -0,0 +1,180 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+{-# LANGUAGE Trustworthy #-}++-- |+-- Module      :   Grisette.Internal.TH.Ctor.SmartConstructor+-- 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.Ctor.SmartConstructor+  ( makeSmartCtorWith,+    makePrefixedSmartCtor,+    makeNamedSmartCtor,+    makeSmartCtor,+  )+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, mrgSingle)+import Grisette.Internal.TH.Ctor.Common+  ( decapitalizeTransformer,+    prefixTransformer,+    withNameTransformer,+  )+import Grisette.Internal.TH.Util (constructorInfoToType, 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 name transformer.+--+-- > makeSmartCtorWith (\name -> "mrg" ++ name) ''Maybe+--+-- generates+--+-- > mrgNothing :: (Mergeable (Maybe a), Applicative m, TryMerge m) => m (Maybe a)+-- > mrgNothing = mrgSingle Nothing+makeSmartCtorWith :: (String -> String) -> Name -> Q [Dec]+makeSmartCtorWith = withNameTransformer makeNamedSmartCtor++-- | Generate constructor wrappers that wraps the result in a container with+-- `TryMerge`.+--+-- > makePrefixedSmartCtor "mrg" ''Maybe+--+-- generates+--+-- > mrgNothing :: (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)+makePrefixedSmartCtor ::+  -- | Prefix for generated wrappers+  String ->+  -- | The type to generate the wrappers for+  Name ->+  Q [Dec]+makePrefixedSmartCtor = makeSmartCtorWith . prefixTransformer++-- | Generate constructor wrappers that wraps the result in a container with+-- `TryMerge`.+--+-- > makeSmartCtor ''Maybe+--+-- generates+--+-- > nothing :: (Mergeable (Maybe a), Applicative m, TryMerge m) => m (Maybe a)+-- > nothing = mrgSingle Nothing+-- > just :: (Mergeable (Maybe a), Applicative m, TryMerge m) => a -> m (Maybe a)+-- > just = \x -> mrgSingle (Just x)+makeSmartCtor ::+  -- | The type to generate the wrappers for+  Name ->+  Q [Dec]+makeSmartCtor = makeSmartCtorWith decapitalizeTransformer++-- | Generate constructor wrappers that wraps the result in a container with+-- `TryMerge` with provided names.+--+-- > makeNamedSmartCtor ["mrgTuple2"] ''(,)+--+-- generates+--+-- > mrgTuple2 :: (Mergeable (a, b), Applicative m, TryMerge m) => a -> b -> u (a, b)+-- > mrgTuple2 = \v1 v2 -> mrgSingle (v1, v2)+makeNamedSmartCtor ::+  -- | Names for generated wrappers+  [String] ->+  -- | The type to generate the wrappers for+  Name ->+  Q [Dec]+makeNamedSmartCtor 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++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) []]+    ]
+ src/Grisette/Internal/TH/Ctor/UnifiedConstructor.hs view
@@ -0,0 +1,235 @@+{-# LANGUAGE TemplateHaskell #-}++-- |+-- Module      :   Grisette.Internal.TH.Ctor.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.Ctor.UnifiedConstructor+  ( makeUnifiedCtorWith,+    makePrefixedUnifiedCtor,+    makeNamedUnifiedCtor,+    makeUnifiedCtor,+  )+where++import Control.Monad (join, replicateM, when, zipWithM)+import Data.Maybe (catMaybes)+import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable, Mergeable1, Mergeable2)+import Grisette.Internal.TH.Ctor.Common+  ( decapitalizeTransformer,+    prefixTransformer,+    withNameTransformer,+  )+import Grisette.Internal.TH.Derivation.Common (ctxForVar)+import Grisette.Internal.TH.Util (constructorInfoToType, putHaddock, tvIsMode)+import Grisette.Internal.Unified.EvalModeTag (EvalModeTag)+import Grisette.Internal.Unified.UnifiedData+  ( GetData,+    UnifiedData,+    wrapData,+  )+import Language.Haskell.TH (conT, pprint, varT)+import Language.Haskell.TH.Datatype+  ( ConstructorInfo (constructorFields, constructorName),+    DatatypeInfo (datatypeCons, datatypeVars),+    reifyDatatype,+    tvKind,+    tvName,+  )+import Language.Haskell.TH.Datatype.TyVarBndr (TyVarBndrSpec, kindedTVSpecified)+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 with provided name+-- transformer.+--+-- For a type @T mode a b c@ with constructors @T1@, @T2@, etc., this function+-- will generate smart constructors with the name transformed, e.g., given the+-- name transformer @(\name -> "mk" ++ name)@, it will generate @mkT1@, @mkT2@,+-- @mkT2@, etc.+--+-- The generated smart constructors will contruct values of type+-- @GetData mode (T mode a b c)@.+makeUnifiedCtorWith :: [Name] -> (String -> String) -> Name -> Q [Dec]+makeUnifiedCtorWith = withNameTransformer . makeNamedUnifiedCtor++-- | 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)@.+makePrefixedUnifiedCtor ::+  [Name] ->+  -- | Prefix for generated wrappers+  String ->+  -- | The type to generate the wrappers for+  Name ->+  Q [Dec]+makePrefixedUnifiedCtor modeCtx =+  makeUnifiedCtorWith modeCtx . prefixTransformer++-- | 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 names decapitalized, e.g.,+-- @t1@, @t2@, etc.+--+-- The generated smart constructors will contruct values of type+-- @GetData mode (T mode a b c)@.+makeUnifiedCtor ::+  [Name] ->+  -- | The type to generate the wrappers for+  Name ->+  Q [Dec]+makeUnifiedCtor modeCtx = makeUnifiedCtorWith modeCtx decapitalizeTransformer++-- | 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)@.+makeNamedUnifiedCtor ::+  [Name] ->+  -- | Names for generated wrappers+  [String] ->+  -- | The type to generate the wrappers for+  Name ->+  Q [Dec]+makeNamedUnifiedCtor modeCtx 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 modeCtx d Nothing $ VarT $ tvName mode)+          names+          constructors+      return $ join ds+    [] -> do+      n <- newName "mode"+      let newBndr = kindedTVSpecified n (ConT ''EvalModeTag)+      ds <-+        zipWithM+          (mkSingleWrapper modeCtx d (Just newBndr) (VarT n))+          names+          constructors+      return $ join ds+    _ -> fail "Expected one or zero 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)|]+  predu <- [t|UnifiedData $(return mode) $(return t)|]+  return ([predu], r)++augmentConstructorType ::+  [Name] -> Maybe TyVarBndrSpec -> Type -> Type -> Q Type+augmentConstructorType+  modeCtx+  freshModeBndr+  mode+  (ForallT tybinders ctx ty1) = do+    (preds, augmentedTyp) <- augmentFinalType mode ty1+    let modeBndrsInForall = filter tvIsMode tybinders+    mergeablePreds <-+      catMaybes+        <$> traverse+          ( \bndr ->+              ctxForVar+                (ConT <$> [''Mergeable, ''Mergeable1, ''Mergeable2])+                (VarT $ tvName bndr)+                (tvKind bndr)+          )+          tybinders+    modePred <-+      case (modeBndrsInForall, freshModeBndr) of+        ([bndr], Nothing) ->+          traverse (\nm -> [t|$(conT nm) $(varT $ tvName bndr)|]) modeCtx+        ([], Just bndr) ->+          traverse (\nm -> [t|$(conT nm) $(varT $ tvName bndr)|]) modeCtx+        _ -> fail "Unsupported constructor type."+    case freshModeBndr of+      Just bndr -> do+        return $+          ForallT+            (bndr : tybinders)+            (modePred ++ mergeablePreds ++ preds ++ ctx)+            augmentedTyp+      Nothing ->+        return $+          ForallT+            tybinders+            (modePred ++ mergeablePreds ++ preds ++ ctx)+            augmentedTyp+augmentConstructorType _ freshModeBndr mode ty = do+  (preds, augmentedTyp) <- augmentFinalType mode ty+  case freshModeBndr of+    Just bndr -> return $ ForallT [bndr] (preds) augmentedTyp+    Nothing ->+      fail $+        "augmentConstructorType: unsupported constructor type: " ++ pprint ty++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 ::+  [Name] ->+  DatatypeInfo ->+  Maybe TyVarBndrSpec ->+  Type ->+  String ->+  ConstructorInfo ->+  Q [Dec]+mkSingleWrapper modeCtx dataType freshModeBndr mode name info = do+  constructorTyp <- constructorInfoToType dataType info+  augmentedTyp <-+    augmentConstructorType modeCtx freshModeBndr 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) []]+    ]
+ src/Grisette/Internal/TH/Derivation/BinaryOpCommon.hs view
@@ -0,0 +1,389 @@+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}++-- |+-- Module      :   Grisette.Internal.TH.Derivation.BinaryOpCommon+-- 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.Derivation.BinaryOpCommon+  ( BinaryOpClassConfig (..),+    BinaryOpFieldConfig (..),+    FieldFunExp,+    defaultFieldFunExp,+    genBinaryOpClause,+    genBinaryOpClass,+  )+where++import Control.Monad (replicateM, unless, when, zipWithM)+import Control.Monad.Identity (IdentityT)+import qualified Data.List as List+import qualified Data.Map as M+import Data.Maybe (catMaybes, mapMaybe)+import Data.Proxy (Proxy (Proxy))+import qualified Data.Set as S+import Grisette.Internal.TH.Derivation.Common+  ( CheckArgsResult+      ( argVars,+        constructors,+        keptVars+      ),+    DeriveConfig (unconstrainedPositions),+    checkArgs,+    ctxForVar,+    evalModeSpecializeList,+    extraConstraint,+    freshenCheckArgsResult,+    isVarUsedInFields,+    specializeResult,+  )+import Language.Haskell.TH+  ( Clause,+    Dec (FunD, InstanceD),+    Exp (VarE),+    Kind,+    Name,+    Pat (VarP, WildP),+    Q,+    Type (AppT, ConT, VarT),+    clause,+    conP,+    funD,+    nameBase,+    newName,+    normalB,+    recP,+    sigP,+    varE,+    varP,+    varT,+    wildP,+  )+import Language.Haskell.TH.Datatype+  ( ConstructorInfo (constructorFields, constructorName, constructorVars),+    TypeSubstitution (freeVariables),+    resolveTypeSynonyms,+    tvName,+  )+import Type.Reflection+  ( TypeRep,+    eqTypeRep,+    someTypeRep,+    typeRep,+    type (:~~:) (HRefl),+  )++-- | Type of field function expression generator.+type FieldFunExp = M.Map Name Name -> Type -> Q Exp++-- | Default field function expression generator.+defaultFieldFunExp :: [Name] -> FieldFunExp+defaultFieldFunExp binaryOpFunNames argToFunPat = go+  where+    go ty = do+      let allArgNames = M.keysSet argToFunPat+      let typeHasNoArg ty =+            S.fromList (freeVariables [ty])+              `S.intersection` allArgNames+              == S.empty+      let fun0 = varE $ head binaryOpFunNames+          fun1 b = [|$(varE $ binaryOpFunNames !! 1) $(go b)|]+          fun2 b c = [|$(varE $ binaryOpFunNames !! 2) $(go b) $(go c)|]+          fun3 b c d =+            [|$(varE $ binaryOpFunNames !! 3) $(go b) $(go c) $(go d)|]+      case ty of+        AppT (AppT (AppT (VarT _) b) c) d -> fun3 b c d+        AppT (AppT (VarT _) b) c -> fun2 b c+        AppT (VarT _) b -> fun1 b+        _ | typeHasNoArg ty -> fun0+        AppT a b | typeHasNoArg a -> fun1 b+        AppT (AppT a b) c | typeHasNoArg a -> fun2 b c+        AppT (AppT (AppT a b) c) d | typeHasNoArg a -> fun3 b c d+        VarT nm -> case M.lookup nm argToFunPat of+          Just pname -> varE pname+          _ -> fail $ "defaultFieldFunExp: unsupported type: " <> show ty+        _ -> fail $ "defaultFieldFunExp: unsupported type: " <> show ty++funPatAndExps ::+  FieldFunExp ->+  [(Type, Kind)] ->+  [Type] ->+  Q ([Pat], [Exp])+funPatAndExps fieldFunExpGen argTypes fields = do+  let usedArgs = S.fromList $ freeVariables fields+  args <-+    traverse+      ( \(ty, _) ->+          case ty of+            VarT nm ->+              if S.member nm usedArgs+                then do+                  pname <- newName "p"+                  return (nm, Just pname)+                else return ('undefined, Nothing)+            _ -> return ('undefined, Nothing)+      )+      argTypes+  let argToFunPat =+        M.fromList $ mapMaybe (\(ty, mpat) -> fmap (ty,) mpat) args+  let funPats = fmap (maybe WildP VarP . snd) args+  defaultFieldFunExps <- traverse (fieldFunExpGen argToFunPat) fields+  return (funPats, defaultFieldFunExps)++-- | Configuration for a binary operation field generation on a GADT.+data BinaryOpFieldConfig = BinaryOpFieldConfig+  { extraPatNames :: [String],+    fieldResFun :: [Exp] -> (Exp, Exp) -> Exp -> Q (Exp, [Bool]),+    fieldCombineFun :: Name -> [Exp] -> Q (Exp, [Bool]),+    fieldDifferentExistentialFun :: Exp -> Q Exp,+    fieldLMatchResult :: Q Exp,+    fieldRMatchResult :: Q Exp,+    fieldFunExp :: FieldFunExp,+    fieldFunNames :: [Name]+  }++-- | Generate a clause for a binary operation on a GADT.+genBinaryOpClause ::+  BinaryOpFieldConfig ->+  [(Type, Kind)] ->+  [(Type, Kind)] ->+  Bool ->+  ConstructorInfo ->+  ConstructorInfo ->+  Q [Clause]+genBinaryOpClause+  (BinaryOpFieldConfig {..})+  lhsArgNewVars+  _rhsArgNewVars+  isLast+  lhsConstructors+  rhsConstructors =+    do+      lhsFields <- mapM resolveTypeSynonyms $ constructorFields lhsConstructors+      rhsFields <- mapM resolveTypeSynonyms $ constructorFields rhsConstructors+      (funPats, defaultFieldFunExps) <-+        funPatAndExps fieldFunExp lhsArgNewVars lhsFields+      unless (null extraPatNames) $+        unless isLast $+          fail "Should not happen"+      extraPatNames <- traverse newName extraPatNames+      let extraPats = fmap VarP extraPatNames+      let extraPatExps = fmap VarE extraPatNames+      lhsFieldsPatNames <- replicateM (length lhsFields) $ newName "lhsField"+      rhsFieldsPatNames <- replicateM (length rhsFields) $ newName "rhsField"+      let lhsFieldPats =+            conP+              (constructorName lhsConstructors)+              ( zipWith+                  (\nm field -> sigP (varP nm) (return field))+                  lhsFieldsPatNames+                  lhsFields+              )+      let rhsFieldPats =+            conP+              (constructorName rhsConstructors)+              ( zipWith+                  (\nm field -> sigP (varP nm) (return field))+                  rhsFieldsPatNames+                  rhsFields+              )+      let singleMatchPat =+            if null lhsFields+              then conP (constructorName lhsConstructors) []+              else recP (constructorName rhsConstructors) []+      let lhsFieldPatExps = fmap VarE lhsFieldsPatNames+      let rhsFieldPatExps = fmap VarE rhsFieldsPatNames++      fieldResExpsAndArgsUsed <-+        zipWithM+          (fieldResFun extraPatExps)+          (zip lhsFieldPatExps rhsFieldPatExps)+          defaultFieldFunExps+      let fieldResExps = fst <$> fieldResExpsAndArgsUsed+      let extraArgsUsedByFields = snd <$> fieldResExpsAndArgsUsed+      (resExp, extraArgsUsedByResult) <-+        fieldCombineFun+          (constructorName lhsConstructors)+          fieldResExps++      let eqt l r =+            [|+              eqTypeRep+                (typeRep :: TypeRep $(varT $ tvName l))+                (typeRep :: TypeRep $(varT $ tvName r))+              |]+      let eqx trueCont l r = do+            cmp <-+              [|+                compare+                  (someTypeRep (Proxy :: Proxy $(varT $ tvName l)))+                  (someTypeRep (Proxy :: Proxy $(varT $ tvName r)))+                |]+            [|+              case $(eqt l r) of+                Just HRefl -> $(trueCont)+                _ ->+                  $(fieldDifferentExistentialFun cmp)+              |]+      let construct [] = return resExp+          construct ((l, r) : xs) = [|$(eqx (construct xs) l r)|]++      let extraArgsUsed =+            fmap or $+              List.transpose $+                extraArgsUsedByResult : extraArgsUsedByFields+      let extraArgsPats =+            zipWith+              (\pat used -> if used then pat else WildP)+              extraPats+              extraArgsUsed+      bothMatched <-+        clause+          ((return <$> funPats ++ extraArgsPats) ++ [lhsFieldPats, rhsFieldPats])+          ( normalB+              [|+                $( construct $+                     zip+                       (constructorVars lhsConstructors)+                       (constructorVars rhsConstructors)+                 )+                |]+          )+          []+      lhsMatched <-+        clause+          ((wildP <$ funPats) ++ [singleMatchPat, wildP])+          (normalB [|$(fieldLMatchResult)|])+          []+      rhsMatched <-+        clause+          ((wildP <$ funPats) ++ [wildP, singleMatchPat])+          (normalB [|$(fieldRMatchResult)|])+          []+      if isLast+        then return [bothMatched]+        else return [bothMatched, lhsMatched, rhsMatched]++-- | Configuration for a binary operation type class generation on a GADT.+data BinaryOpClassConfig = BinaryOpClassConfig+  { binaryOpFieldConfigs :: [BinaryOpFieldConfig],+    binaryOpInstanceNames :: [Name],+    binaryOpAllowSumType :: Bool,+    binaryOpAllowExistential :: Bool+  }++-- | Generate a function for a binary operation on a GADT.+genBinaryOpFun ::+  BinaryOpFieldConfig ->+  Int ->+  [(Type, Kind)] ->+  [(Type, Kind)] ->+  [ConstructorInfo] ->+  [ConstructorInfo] ->+  Q Dec+genBinaryOpFun config n _ _ [] [] =+  funD+    (fieldFunNames config !! n)+    [clause [] (normalB [|error "impossible"|]) []]+genBinaryOpFun+  config+  n+  lhsArgNewVars+  rhsArgNewVars+  lhsConstructors+  rhsConstructors = do+    clauses <-+      zipWithM+        (genBinaryOpClause config lhsArgNewVars rhsArgNewVars False)+        (init lhsConstructors)+        (init rhsConstructors)+    lastClause <-+      genBinaryOpClause+        config+        lhsArgNewVars+        rhsArgNewVars+        True+        (last lhsConstructors)+        (last rhsConstructors)+    let instanceFunName = (fieldFunNames config) !! n+    return $ FunD instanceFunName (concat clauses ++ lastClause)++-- | Generate a type class instance for a binary operation on a GADT.+genBinaryOpClass ::+  DeriveConfig -> BinaryOpClassConfig -> Int -> Name -> Q [Dec]+genBinaryOpClass deriveConfig (BinaryOpClassConfig {..}) n typName = do+  lhsResult <-+    specializeResult (evalModeSpecializeList deriveConfig)+      =<< freshenCheckArgsResult True+      =<< checkArgs+        (nameBase $ head binaryOpInstanceNames)+        (length binaryOpInstanceNames - 1)+        typName+        (n == 0 && binaryOpAllowExistential)+        n+  when (not binaryOpAllowSumType && length (constructors lhsResult) > 1) $+    fail $+      "Cannot derive "+        <> nameBase (binaryOpInstanceNames !! n)+        <> " for sum type"+  rhsResult <-+    specializeResult (evalModeSpecializeList deriveConfig)+      =<< checkArgs+        (nameBase $ head binaryOpInstanceNames)+        (length binaryOpInstanceNames - 1)+        typName+        (n == 0)+        n+  let keptVars' = keptVars lhsResult+  when (typName == ''IdentityT) $+    fail $+      show keptVars'+  let isTypeUsedInFields' (VarT nm) = isVarUsedInFields lhsResult nm+      isTypeUsedInFields' _ = False+  ctxs <-+    traverse (uncurry $ ctxForVar (fmap ConT binaryOpInstanceNames)) $+      filter (isTypeUsedInFields' . fst) $+        fmap snd $+          filter (not . (`elem` unconstrainedPositions deriveConfig) . fst) $+            zip [0 ..] keptVars'+  let keptType = foldl AppT (ConT typName) $ fmap fst keptVars'+  instanceFuns <-+    traverse+      ( \config ->+          genBinaryOpFun+            config+            n+            (argVars lhsResult)+            (argVars rhsResult)+            (constructors lhsResult)+            (constructors rhsResult)+      )+      binaryOpFieldConfigs+  let instanceName = binaryOpInstanceNames !! n+  let instanceType = AppT (ConT instanceName) keptType+  extraPreds <-+    extraConstraint+      deriveConfig+      typName+      instanceName+      []+      keptVars'+      (constructors lhsResult)+  return+    [ InstanceD+        Nothing+        ( extraPreds+            ++ if null (constructors lhsResult)+              then []+              else catMaybes ctxs+        )+        instanceType+        instanceFuns+    ]
+ src/Grisette/Internal/TH/Derivation/Common.hs view
@@ -0,0 +1,465 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-}++-- |+-- Module      :   Grisette.Internal.TH.Derivation.Common+-- 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.Derivation.Common+  ( CheckArgsResult (..),+    checkArgs,+    ctxForVar,+    EvalModeConfig (..),+    DeriveConfig (..),+    extraEvalModeConstraint,+    extraBitSizeConstraint,+    extraFpBitSizeConstraint,+    extraExtraMergeableConstraint,+    extraConstraint,+    specializeResult,+    evalModeSpecializeList,+    isVarUsedInFields,+    freshenCheckArgsResult,+  )+where++import Control.Monad (foldM, unless, when, zipWithM)+import Data.Bifunctor (first)+import qualified Data.Map as M+import Data.Maybe (catMaybes, mapMaybe)+import qualified Data.Set as S+import GHC.TypeLits (KnownNat, Nat, type (<=))+import Grisette.Internal.Internal.Decl.Core.Data.Class.Mergeable+  ( Mergeable,+    Mergeable1,+    Mergeable2,+  )+import Grisette.Internal.SymPrim.FP (ValidFP)+import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C, S))+import Grisette.Internal.Unified.Util (DecideEvalMode)+import Language.Haskell.TH+  ( Kind,+    Name,+    Pred,+    Q,+    Type (AppT, ArrowT, ConT, PromotedT, StarT, VarT),+    conT,+    nameBase,+    newName,+  )+import Language.Haskell.TH.Datatype+  ( ConstructorInfo (constructorFields, constructorName, constructorVars),+    DatatypeInfo (datatypeCons, datatypeVars),+    TypeSubstitution (applySubstitution, freeVariables),+    reifyDatatype,+    tvName,+  )+import Language.Haskell.TH.Datatype.TyVarBndr (mapTVName, tvKind)++-- | Result of 'checkArgs' for a data type.+data CheckArgsResult = CheckArgsResult+  { constructors :: [ConstructorInfo],+    keptVars :: [(Type, Kind)],+    argVars :: [(Type, Kind)]+  }++-- | Specialize the evaluation mode tags for the t'CheckArgsResult'.+specializeResult :: [(Int, EvalModeTag)] -> CheckArgsResult -> Q CheckArgsResult+specializeResult evalModeConfigs result = do+  let modeToName C = 'C+      modeToName S = 'S+  map <-+    foldM+      ( \lst (n, tag) -> do+          let (_, knd) = lst !! n+          return $+            take n lst+              ++ [(PromotedT $ modeToName tag, knd)]+              ++ drop (n + 1) lst+      )+      (keptVars result)+      evalModeConfigs+  return $ result {keptVars = map}++freshenConstructorInfo :: ConstructorInfo -> Q ConstructorInfo+freshenConstructorInfo conInfo = do+  let vars = constructorVars conInfo+  newNames <- traverse (newName . nameBase . tvName) vars+  let newVars = zipWith (mapTVName . const) newNames vars+  let substMap = M.fromList $ zip (tvName <$> vars) $ VarT <$> newNames+  return $ applySubstitution substMap conInfo {constructorVars = newVars}++-- | Freshen the type variables in the t'CheckArgsResult'.+freshenCheckArgsResult :: Bool -> CheckArgsResult -> Q CheckArgsResult+freshenCheckArgsResult freshenNats result = do+  let genNewName :: (Type, Kind) -> Q (Maybe Name)+      genNewName (VarT _, knd) =+        if not freshenNats && knd == ConT ''Nat+          then return Nothing+          else Just <$> newName "a"+      genNewName _ = return Nothing+  keptNewNames <- traverse genNewName (keptVars result)+  argNewNames <- traverse genNewName (argVars result)++  let substMap =+        M.fromList+          $ mapMaybe+            ( \(newName, oldVar) ->+                case (newName, oldVar) of+                  (Just newName, (VarT oldName, _)) ->+                    Just (oldName, VarT newName)+                  _ -> Nothing+            )+          $ zip+            (keptNewNames ++ argNewNames)+            (keptVars result ++ argVars result)+  constructors <-+    mapM freshenConstructorInfo $+      applySubstitution substMap $+        constructors result+  let newKeptVars = first (applySubstitution substMap) <$> (keptVars result)+  let newArgVars = first (applySubstitution substMap) <$> (argVars result)+  return $+    result+      { constructors = constructors,+        keptVars = newKeptVars,+        argVars = newArgVars+      }++-- | Check if the number of type parameters is valid for a data type, and return+-- new names for the type variables, split into kept and arg parts.+checkArgs ::+  String ->+  Int ->+  Name ->+  Bool ->+  Int ->+  Q CheckArgsResult+checkArgs clsName maxArgNum typName allowExistential n = do+  when (n < 0) $+    fail $+      unlines+        [ "Cannot derive "+            ++ clsName+            ++ " instance with negative type parameters",+          "\tRequested: " ++ show n,+          "\tHint: Use a non-negative number of type parameters"+        ]+  when (n > maxArgNum) $+    fail $+      unlines+        [ "Cannot derive "+            <> clsName+            <> " instance with more than "+            <> show maxArgNum+            <> " type parameters",+          "\tRequested: " <> show n+        ]+  d <- reifyDatatype typName+  let dvars = datatypeVars d+  when (length dvars < n) $+    fail $+      unlines+        [ "Cannot derive "+            <> clsName+            <> show n+            <> " instance for the type "+            <> show typName,+          "\tReason: The type "+            <> show typName+            <> " has only "+            <> show (length dvars)+            <> " type variables."+        ]+  let keptVars =+        (\bndr -> (VarT $ tvName bndr, tvKind bndr))+          <$> take (length dvars - n) dvars+  let argVars =+        (\bndr -> (VarT $ tvName bndr, tvKind bndr))+          <$> drop (length dvars - n) dvars+  let constructors = datatypeCons d+  unless allowExistential $+    mapM_+      ( \c ->+          when (constructorVars c /= []) $+            fail $+              unlines+                [ "Cannot derive "+                    <> clsName+                    <> show n+                    <> " instance for the type "+                    <> show typName,+                  "\tReason: The constructor "+                    <> nameBase (constructorName c)+                    <> " has existential variables"+                ]+      )+      constructors+  mapM_+    ( \c -> do+        let fields = constructorFields c+        let existentialVars = tvName <$> constructorVars c+        let fieldReferencedVars = freeVariables fields+        let notReferencedVars =+              S.fromList existentialVars S.\\ S.fromList fieldReferencedVars+        unless (null notReferencedVars) $+          fail $+            unlines+              [ "Cannot derive "+                  <> clsName+                  <> show n+                  <> " instance for the type "+                  <> show typName,+                "Reason: Ambiguous existential variable in the constructor: "+                  <> nameBase (constructorName c)+                  <> ", this is not supported. Please consider binding the "+                  <> "existential variable to a field. You can use Proxy type to "+                  <> "do this."+              ]+    )+    constructors+  return $ CheckArgsResult {..}++isVarUsedInConstructorFields :: [ConstructorInfo] -> Name -> Bool+isVarUsedInConstructorFields constructors var =+  let allFields = concatMap constructorFields constructors+      allFieldsFreeVars = S.fromList $ freeVariables allFields+   in S.member var allFieldsFreeVars++-- | Check if a variable is used in the fields of a constructor.+isVarUsedInFields :: CheckArgsResult -> Name -> Bool+isVarUsedInFields CheckArgsResult {..} =+  isVarUsedInConstructorFields constructors++-- | Generate a context for a variable in a GADT.+ctxForVar :: [Type] -> Type -> Kind -> Q (Maybe Pred)+ctxForVar instanceExps ty knd = case knd of+  StarT ->+    Just+      <$> [t|$(return $ head instanceExps) $(return ty)|]+  AppT (AppT ArrowT StarT) StarT ->+    Just+      <$> [t|$(return $ instanceExps !! 1) $(return ty)|]+  AppT (AppT (AppT ArrowT StarT) StarT) StarT ->+    Just+      <$> [t|$(return $ instanceExps !! 2) $(return ty)|]+  AppT (AppT (AppT (AppT ArrowT StarT) StarT) StarT) StarT ->+    Just+      <$> [t|$(return $ instanceExps !! 3) $(return ty)|]+  AppT (AppT (AppT (AppT ArrowT StarT) StarT) StarT) _ ->+    fail $ "Unsupported kind: " <> show knd+  _ -> return Nothing++-- | Configuration for constraints for evaluation modes tag.+--+-- * 'EvalModeConstraints' specifies a list of constraints for the tag, for+--   example, we may use 'Grisette.Unified.EvalModeBase' and+--   'Grisette.Unified.EvalModeBV' to specify that the evaluation mode must+--   support both base (boolean and data types) and bit vectors. This should be+--   used when the data type uses bit vectors.+--+-- * 'EvalModeSpecified' specifies a that an evaluation mode tag should be+--   specialized to a specific tag for all the instances.+data EvalModeConfig+  = EvalModeConstraints [Name]+  | EvalModeSpecified EvalModeTag++-- | Configuration for deriving instances for a data type.+data DeriveConfig = DeriveConfig+  { evalModeConfig :: [(Int, EvalModeConfig)],+    bitSizePositions :: [Int],+    fpBitSizePositions :: [(Int, Int)],+    unconstrainedPositions :: [Int],+    needExtraMergeableUnderEvalMode :: Bool,+    needExtraMergeableWithConcretizedEvalMode :: Bool,+    useNoStrategy :: Bool,+    useSerialForCerealAndBinary :: Bool+  }++-- | Get all the evaluation modes to specialize in the t'DeriveConfig'.+evalModeSpecializeList :: DeriveConfig -> [(Int, EvalModeTag)]+evalModeSpecializeList DeriveConfig {..} =+  mapMaybe+    ( \(n, cfg) ->+        case cfg of+          EvalModeConstraints _ -> Nothing+          EvalModeSpecified tag -> Just (n, tag)+    )+    evalModeConfig++instance Semigroup DeriveConfig where+  l <> r =+    DeriveConfig+      { evalModeConfig = evalModeConfig l <> evalModeConfig r,+        bitSizePositions = bitSizePositions l <> bitSizePositions r,+        fpBitSizePositions = fpBitSizePositions l <> fpBitSizePositions r,+        unconstrainedPositions = unconstrainedPositions l <> unconstrainedPositions r,+        needExtraMergeableUnderEvalMode =+          needExtraMergeableUnderEvalMode l+            || needExtraMergeableUnderEvalMode r,+        needExtraMergeableWithConcretizedEvalMode =+          needExtraMergeableWithConcretizedEvalMode l+            || needExtraMergeableWithConcretizedEvalMode r,+        useNoStrategy = useNoStrategy l || useNoStrategy r,+        useSerialForCerealAndBinary =+          useSerialForCerealAndBinary l && useSerialForCerealAndBinary r+      }++instance Monoid DeriveConfig where+  mempty = DeriveConfig [] [] [] [] False False False True+  mappend = (<>)++-- | Generate extra constraints for evaluation modes.+extraEvalModeConstraint ::+  Name -> Name -> [(Type, Kind)] -> (Int, EvalModeConfig) -> Q [Pred]+extraEvalModeConstraint+  tyName+  instanceName+  args+  (n, EvalModeConstraints names)+    | n >= length args = return []+    | otherwise = do+        let (arg, argKind) = args !! n+        when (argKind /= ConT ''EvalModeTag) $+          fail $+            "Cannot introduce EvalMode constraint for the "+              <> show n+              <> "th argument of "+              <> show tyName+              <> " when deriving the "+              <> show instanceName+              <> " instance because it is not an EvalModeTag."+        traverse (\nm -> [t|$(conT nm) $(return arg)|]) names+extraEvalModeConstraint _ _ _ (_, EvalModeSpecified _) = return []++-- | Generate extra constraints for bit vectors.+extraBitSizeConstraint :: Name -> Name -> [(Type, Kind)] -> Int -> Q [Pred]+extraBitSizeConstraint tyName instanceName args n+  | n >= length args = return []+  | otherwise = do+      let (arg, argKind) = args !! n+      when (argKind /= ConT ''Nat) $+        fail $+          "Cannot introduce BitSize constraint for the "+            <> show n+            <> "th argument of "+            <> show tyName+            <> " when deriving the "+            <> show instanceName+            <> " instance because it is not a Nat."+      predKnown <- [t|KnownNat $(return arg)|]+      predPositive <- [t|1 <= $(return arg)|]+      return [predKnown, predPositive]++-- | Generate extra constraints for floating point exponents and significands.+extraFpBitSizeConstraint ::+  Name -> Name -> [(Type, Kind)] -> (Int, Int) -> Q [Pred]+extraFpBitSizeConstraint tyName instanceName args (eb, sb)+  | eb >= length args || sb >= length args = return []+  | otherwise = do+      let (argEb, argEbKind) = args !! eb+      let (argSb, argSbKind) = args !! sb+      when (argEbKind /= ConT ''Nat || argSbKind /= ConT ''Nat) $+        fail $+          "Cannot introduce ValidFP constraint for the "+            <> show eb+            <> "th and "+            <> show sb+            <> "th arguments of "+            <> show tyName+            <> " when deriving the "+            <> show instanceName+            <> " instance because they are not Nats."+      pred <- [t|ValidFP $(return argEb) $(return argSb)|]+      return [pred]++-- | Generate extra constraints for 'Mergeable' instances.+extraExtraMergeableConstraint ::+  DeriveConfig -> [ConstructorInfo] -> [(Type, Kind)] -> Q [Pred]+extraExtraMergeableConstraint deriveConfig constructors args = do+  let isTypeUsedInFields' (VarT nm) =+        isVarUsedInConstructorFields constructors nm+      isTypeUsedInFields' _ = False+  catMaybes+    <$> zipWithM+      ( \position (arg, knd) ->+          if isTypeUsedInFields' arg+            && notElem position (unconstrainedPositions deriveConfig)+            then+              ctxForVar+                [ ConT ''Mergeable,+                  ConT ''Mergeable1,+                  ConT ''Mergeable2+                ]+                arg+                knd+            else return Nothing+      )+      [0 ..]+      args++-- | Generate extra constraints for a data type.+extraConstraint ::+  DeriveConfig ->+  Name ->+  Name ->+  [(Type, Kind)] ->+  [(Type, Kind)] ->+  [ConstructorInfo] ->+  Q [Pred]+extraConstraint+  deriveConfig@DeriveConfig {..}+  tyName+  instanceName+  extraArgs+  keptArgs+  constructors = do+    evalModePreds <-+      traverse+        (extraEvalModeConstraint tyName instanceName keptArgs)+        evalModeConfig+    extraArgEvalModePreds <-+      if null evalModeConfig+        then+          traverse+            ( \(arg, kind) ->+                if kind == ConT ''EvalModeTag+                  then (: []) <$> [t|DecideEvalMode $(return arg)|]+                  else return []+            )+            extraArgs+        else return []+    bitSizePreds <-+      traverse+        (extraBitSizeConstraint tyName instanceName keptArgs)+        bitSizePositions+    fpBitSizePreds <-+      traverse+        (extraFpBitSizeConstraint tyName instanceName keptArgs)+        fpBitSizePositions+    extraMergeablePreds <-+      if needExtraMergeableUnderEvalMode+        && ( any+               ( \case+                   (_, EvalModeConstraints _) -> True+                   (_, EvalModeSpecified _) -> False+               )+               evalModeConfig+               || needExtraMergeableWithConcretizedEvalMode+           )+        then extraExtraMergeableConstraint deriveConfig constructors keptArgs+        else return []+    return $+      concat (extraArgEvalModePreds ++ evalModePreds)+        ++ if null constructors+          then []+          else extraMergeablePreds ++ concat (bitSizePreds ++ fpBitSizePreds)
+ src/Grisette/Internal/TH/Derivation/ConvertOpCommon.hs view
@@ -0,0 +1,453 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}++-- |+-- Module      :   Grisette.Internal.TH.Derivation.ConvertOpCommon+-- 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.Derivation.ConvertOpCommon+  ( genConvertOpClass,+    ConvertOpClassConfig (..),+    defaultFieldFunExp,+  )+where++import Control.Monad (foldM, replicateM, zipWithM)+import qualified Data.Map as M+import Data.Maybe (catMaybes, mapMaybe)+import qualified Data.Set as S+import Grisette.Internal.Core.Data.Class.UnionView (unionToCon)+import Grisette.Internal.Internal.Decl.Core.Control.Monad.Union (Union)+import Grisette.Internal.Internal.Decl.Core.Data.Class.TryMerge (toUnionSym)+import Grisette.Internal.TH.Derivation.Common+  ( CheckArgsResult (argVars, constructors, keptVars),+    DeriveConfig+      ( DeriveConfig,+        bitSizePositions,+        evalModeConfig,+        fpBitSizePositions,+        needExtraMergeableUnderEvalMode,+        needExtraMergeableWithConcretizedEvalMode,+        unconstrainedPositions+      ),+    EvalModeConfig (EvalModeConstraints, EvalModeSpecified),+    checkArgs,+    extraBitSizeConstraint,+    extraEvalModeConstraint,+    extraExtraMergeableConstraint,+    extraFpBitSizeConstraint,+    freshenCheckArgsResult,+    isVarUsedInFields,+  )+import Grisette.Internal.TH.Util (allUsedNames)+import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C, S))+import Grisette.Internal.Unified.Util+  ( EvalModeConvertible (withModeConvertible'),+  )+import Language.Haskell.TH+  ( Body (NormalB),+    Clause (Clause),+    Dec (FunD, InstanceD),+    Exp (VarE),+    Kind,+    Name,+    Overlap (Incoherent),+    Pat (VarP, WildP),+    Pred,+    Q,+    Type (AppT, ArrowT, ConT, StarT, VarT),+    clause,+    conP,+    funD,+    nameBase,+    newName,+    normalB,+    varE,+    varP,+  )+import Language.Haskell.TH.Datatype+  ( ConstructorInfo (constructorFields, constructorName),+    TypeSubstitution (freeVariables),+    resolveTypeSynonyms,+  )++type FieldFunExp = M.Map Name Name -> Type -> Q Exp++-- | Default field transformation function.+defaultFieldFunExp :: [Name] -> FieldFunExp+defaultFieldFunExp binaryOpFunNames argToFunPat = go+  where+    go ty = do+      let allArgNames = M.keysSet argToFunPat+      let typeHasNoArg ty =+            S.fromList (freeVariables [ty])+              `S.intersection` allArgNames+              == S.empty+      let fun0 = varE $ head binaryOpFunNames+          fun1 b = [|$(varE $ binaryOpFunNames !! 1) $(go b)|]+          fun2 b c = [|$(varE $ binaryOpFunNames !! 2) $(go b) $(go c)|]+          fun3 b c d =+            [|$(varE $ binaryOpFunNames !! 3) $(go b) $(go c) $(go d)|]+      case ty of+        AppT (AppT (AppT (VarT _) b) c) d -> fun3 b c d+        AppT (AppT (VarT _) b) c -> fun2 b c+        AppT (VarT _) b -> fun1 b+        _ | typeHasNoArg ty -> fun0+        AppT a b | typeHasNoArg a -> fun1 b+        AppT (AppT a b) c | typeHasNoArg a -> fun2 b c+        AppT (AppT (AppT a b) c) d | typeHasNoArg a -> fun3 b c d+        VarT nm -> case M.lookup nm argToFunPat of+          Just pname -> varE pname+          _ -> fail $ "defaultFieldFunExp: unsupported type: " <> show ty+        _ -> fail $ "defaultFieldFunExp: unsupported type: " <> show ty++funPatAndExps ::+  FieldFunExp ->+  [(Type, Kind)] ->+  [Type] ->+  Q ([Pat], [Exp])+funPatAndExps fieldFunExpGen argTypes fields = do+  let usedArgs = S.fromList $ freeVariables fields+  args <-+    traverse+      ( \(ty, _) ->+          case ty of+            VarT nm ->+              if S.member nm usedArgs+                then do+                  pname <- newName "p"+                  return (nm, Just pname)+                else return ('undefined, Nothing)+            _ -> return ('undefined, Nothing)+      )+      argTypes+  let argToFunPat =+        M.fromList $ mapMaybe (\(ty, mpat) -> fmap (ty,) mpat) args+  let funPats = fmap (maybe WildP VarP . snd) args+  defaultFieldFunExps <- traverse (fieldFunExpGen argToFunPat) fields+  return (funPats, defaultFieldFunExps)++tagPair ::+  DeriveConfig ->+  EvalModeTag ->+  [(Type, Kind)] ->+  [(Type, Kind)] ->+  [(Type, Type)]+tagPair deriveConfig convertOpTarget lhsKeptVars rhsKeptVars =+  let conKeptVars =+        if convertOpTarget == S then lhsKeptVars else rhsKeptVars+      symKeptVars =+        if convertOpTarget == S then rhsKeptVars else lhsKeptVars+   in mapMaybe+        ( \case+            (n, EvalModeConstraints _)+              | n < length conKeptVars && n >= 0 ->+                  Just (fst $ conKeptVars !! n, fst $ symKeptVars !! n)+            _ -> Nothing+        )+        (evalModeConfig deriveConfig)++caseSplitTagPairs ::+  DeriveConfig ->+  EvalModeTag ->+  [(Type, Kind)] ->+  [(Type, Kind)] ->+  Exp ->+  Q Exp+caseSplitTagPairs deriveConfig convertOpTarget lhsKeptVars rhsKeptVars exp = do+  let tags = tagPair deriveConfig convertOpTarget lhsKeptVars rhsKeptVars+  foldM+    ( \exp (lty, rty) ->+        [|+          withModeConvertible'+            @($(return lty))+            @($(return rty))+            $(return exp)+            $(return exp)+            $(return exp)+          |]+    )+    exp+    tags++genConvertOpFieldClause ::+  DeriveConfig ->+  ConvertOpClassConfig ->+  [(Type, Kind)] ->+  [(Type, Kind)] ->+  [(Type, Kind)] ->+  [(Type, Kind)] ->+  ConstructorInfo ->+  Q Clause+genConvertOpFieldClause+  deriveConfig@DeriveConfig {..}+  ConvertOpClassConfig {..}+  lhsKeptTypes+  rhsKeptTypes+  lhsArgTypes+  _rhsArgTypes+  lhsConInfo = do+    fields <- mapM resolveTypeSynonyms $ constructorFields lhsConInfo+    (funPats, defaultFieldFunExps) <- funPatAndExps convertFieldFunExp lhsArgTypes fields+    fieldsPatNames <- replicateM (length fields) $ newName "field"+    fieldPats <- conP (constructorName lhsConInfo) (fmap varP fieldsPatNames)+    let fieldPatExps = fmap VarE fieldsPatNames+    fieldResExps <- zipWithM convertFieldResFun fieldPatExps defaultFieldFunExps+    resExp <- convertFieldCombineFun (constructorName lhsConInfo) fieldResExps+    let resUsedNames = allUsedNames resExp+    let transformPat (VarP nm) =+          if S.member nm resUsedNames then VarP nm else WildP+        transformPat p = p+    resExpWithTags <-+      caseSplitTagPairs+        deriveConfig+        convertOpTarget+        lhsKeptTypes+        rhsKeptTypes+        resExp+    return $+      Clause+        (fmap transformPat $ funPats ++ [fieldPats])+        (NormalB resExpWithTags)+        []++genConvertOpFun ::+  DeriveConfig ->+  ConvertOpClassConfig ->+  Int ->+  [(Type, Kind)] ->+  [(Type, Kind)] ->+  [(Type, Kind)] ->+  [(Type, Kind)] ->+  [ConstructorInfo] ->+  Q Dec+genConvertOpFun _ convertOpClassConfig n _ _ _ _ [] = do+  let instanceFunName = (convertOpFunNames convertOpClassConfig) !! n+  funD instanceFunName [clause [] (normalB [|error "impossible"|]) []]+genConvertOpFun+  deriveConfig+  convertOpClassConfig+  n+  lhsKeptTypes+  rhsKeptTypes+  lhsArgTypes+  rhsArgTypes+  lhsConstructors = do+    clauses <-+      traverse+        ( genConvertOpFieldClause+            deriveConfig+            convertOpClassConfig+            lhsKeptTypes+            rhsKeptTypes+            lhsArgTypes+            rhsArgTypes+        )+        lhsConstructors+    let instanceFunName = (convertOpFunNames convertOpClassConfig) !! n+    return $ FunD instanceFunName clauses++-- | Configuration for a convert operation class.+data ConvertOpClassConfig = ConvertOpClassConfig+  { convertOpTarget :: EvalModeTag,+    convertOpInstanceNames :: [Name],+    convertOpFunNames :: [Name],+    convertFieldResFun :: Exp -> Exp -> Q Exp,+    convertFieldCombineFun :: Name -> [Exp] -> Q Exp,+    convertFieldFunExp :: FieldFunExp+  }++convertCtxForVar :: [Type] -> Type -> Type -> Kind -> Q (Maybe Pred)+convertCtxForVar instanceExps lty rty knd = case knd of+  StarT ->+    Just+      <$> [t|$(return $ head instanceExps) $(return lty) $(return rty)|]+  AppT (AppT ArrowT StarT) StarT ->+    Just+      <$> [t|$(return $ instanceExps !! 1) $(return lty) $(return rty)|]+  AppT (AppT (AppT ArrowT StarT) StarT) StarT ->+    Just+      <$> [t|$(return $ instanceExps !! 2) $(return lty) $(return rty)|]+  AppT (AppT (AppT StarT StarT) StarT) _ ->+    fail $ "Unsupported kind: " <> show knd+  _ -> return Nothing++-- | Generate extra constraints for a data type.+extraConstraintConvert ::+  DeriveConfig ->+  EvalModeTag ->+  Name ->+  Name ->+  [(Type, Kind)] ->+  [(Type, Kind)] ->+  [ConstructorInfo] ->+  Q [Pred]+extraConstraintConvert+  deriveConfig@DeriveConfig {..}+  convertOpTarget+  tyName+  instanceName+  lhsKeptArgs+  rhsKeptArgs+  rhsConstructors = do+    let conKeptVars = if convertOpTarget == S then lhsKeptArgs else rhsKeptArgs+    let symKeptVars = if convertOpTarget == S then rhsKeptArgs else lhsKeptArgs++    rhsEvalModePreds <-+      if convertOpTarget == S && needExtraMergeableWithConcretizedEvalMode+        then+          traverse+            (extraEvalModeConstraint tyName instanceName rhsKeptArgs)+            evalModeConfig+        else return []+    extraArgEvalModePreds <-+      traverse+        ( \case+            (n, EvalModeConstraints _)+              | n < length lhsKeptArgs && n >= 0 ->+                  (: [])+                    <$> [t|+                      EvalModeConvertible+                        $(return $ fst $ conKeptVars !! n)+                        $(return $ fst $ symKeptVars !! n)+                      |]+            _ -> return []+        )+        evalModeConfig+    bitSizePreds <-+      traverse+        (extraBitSizeConstraint tyName instanceName lhsKeptArgs)+        bitSizePositions+    fpBitSizePreds <-+      traverse+        (extraFpBitSizeConstraint tyName instanceName lhsKeptArgs)+        fpBitSizePositions+    extraMergeablePreds <-+      if convertOpTarget == S+        && ( any+               ( \case+                   (_, EvalModeConstraints _) -> True+                   (_, EvalModeSpecified _) -> False+               )+               evalModeConfig+               || needExtraMergeableWithConcretizedEvalMode+           )+        then extraExtraMergeableConstraint deriveConfig rhsConstructors rhsKeptArgs+        else return []+    return $+      concat+        ( rhsEvalModePreds+            ++ extraArgEvalModePreds+            ++ bitSizePreds+            ++ fpBitSizePreds+            ++ [extraMergeablePreds]+        )++-- | Generate a convert operation class instance.+genConvertOpClass ::+  DeriveConfig -> ConvertOpClassConfig -> Int -> Name -> Q [Dec]+genConvertOpClass deriveConfig (ConvertOpClassConfig {..}) n typName = do+  oldLhsResult <-+    freshenCheckArgsResult True+      =<< checkArgs+        (nameBase $ head convertOpInstanceNames)+        (length convertOpInstanceNames - 1)+        typName+        False+        n+  oldRhsResult <- freshenCheckArgsResult False oldLhsResult+  let lResult = oldLhsResult+  let rResult = oldRhsResult+  let instanceName = convertOpInstanceNames !! n+  let lKeptVars = keptVars lResult+  let rKeptVars = keptVars rResult+  let lConstructors = constructors lResult+  let rConstructors = constructors rResult+  let lKeptType = foldl AppT (ConT typName) $ fmap fst lKeptVars+  let rKeptType = foldl AppT (ConT typName) $ fmap fst rKeptVars+  extraPreds <-+    extraConstraintConvert+      deriveConfig+      convertOpTarget+      typName+      instanceName+      lKeptVars+      rKeptVars+      rConstructors+  unionExtraPreds <-+    extraConstraintConvert+      deriveConfig {needExtraMergeableWithConcretizedEvalMode = True}+      convertOpTarget+      typName+      instanceName+      lKeptVars+      rKeptVars+      rConstructors++  let instanceType = AppT (AppT (ConT instanceName) lKeptType) rKeptType+  let isTypeUsedInFields (VarT nm) = isVarUsedInFields lResult nm+      isTypeUsedInFields _ = False+  ctxs <-+    traverse+      ( \(position, ((lty, knd), (rty, _))) ->+          if position `elem` unconstrainedPositions deriveConfig+            then return Nothing+            else convertCtxForVar (ConT <$> convertOpInstanceNames) lty rty knd+      )+      $ filter (isTypeUsedInFields . fst . fst . snd)+      $ zip [0 ..]+      $ zip lKeptVars rKeptVars++  instanceFun <-+    genConvertOpFun+      deriveConfig+      (ConvertOpClassConfig {..})+      n+      (keptVars lResult)+      (keptVars rResult)+      (argVars lResult)+      (argVars rResult)+      lConstructors++  let instanceUnionType =+        case convertOpTarget of+          S ->+            AppT+              (AppT (ConT instanceName) lKeptType)+              (AppT (ConT ''Union) rKeptType)+          C ->+            AppT+              (AppT (ConT instanceName) (AppT (ConT ''Union) lKeptType))+              rKeptType+  instanceUnionFun <- do+    resExp <-+      if convertOpTarget == S+        then varE 'toUnionSym+        else varE 'unionToCon+    funD (head convertOpFunNames) [clause [] (normalB $ return resExp) []]++  return $+    InstanceD+      (Just Incoherent)+      (extraPreds ++ if null (constructors lResult) then [] else catMaybes ctxs)+      instanceType+      [instanceFun]+      : ( [ InstanceD+              (Just Incoherent)+              ( unionExtraPreds+                  ++ if null (constructors lResult)+                    then []+                    else catMaybes ctxs+              )+              instanceUnionType+              [instanceUnionFun]+          | n == 0+          ]+        )
+ src/Grisette/Internal/TH/Derivation/Derive.hs view
@@ -0,0 +1,1005 @@+{-# LANGUAGE LambdaCase #-}+{-# HLINT ignore "Unused LANGUAGE pragma" #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++-- |+-- Module      :   Grisette.Internal.TH.Derivation.Derive+-- 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.Derivation.Derive+  ( derive,+    deriveWith,+    allClasses0,+    allClasses01,+    allClasses012,+    basicClasses0,+    basicClasses1,+    basicClasses2,+    basicClasses01,+    basicClasses012,+    noExistentialClasses0,+    concreteOrdClasses0,+    hashableClasses0,+    noExistentialClasses1,+    concreteOrdClasses1,+    hashableClasses1,+    noExistentialClasses2,+    concreteOrdClasses2,+    hashableClasses2,+    showClasses,+    pprintClasses,+    evalSymClasses,+    extractSymClasses,+    substSymClasses,+    allSymsClasses,+    eqClasses,+    ordClasses,+    symOrdClasses,+    symEqClasses,+    unifiedSymOrdClasses,+    unifiedSymEqClasses,+    mergeableClasses,+    nfDataClasses,+    hashableClasses,+    toSymClasses,+    toConClasses,+    serialClasses,+    simpleMergeableClasses,+    unifiedSimpleMergeableClasses,+    filterExactNumArgs,+    filterLeqNumArgs,+  )+where++import Control.Arrow (Arrow (second))+import Control.DeepSeq (NFData, NFData1, NFData2)+import Data.Binary (Binary)+import Data.Bytes.Serial (Serial, Serial1, Serial2)+import Data.Functor.Classes (Eq1, Eq2, Ord1, Ord2, Show1, Show2)+import Data.Hashable (Hashable)+import Data.Hashable.Lifted (Hashable1, Hashable2)+import qualified Data.Map as M+import Data.Serialize (Serialize)+import qualified Data.Set as S+import Grisette.Internal.Internal.Decl.Core.Data.Class.EvalSym+  ( EvalSym,+    EvalSym1,+    EvalSym2,+  )+import Grisette.Internal.Internal.Decl.Core.Data.Class.ExtractSym+  ( ExtractSym,+    ExtractSym1,+    ExtractSym2,+  )+import Grisette.Internal.Internal.Decl.Core.Data.Class.Mergeable+  ( Mergeable,+    Mergeable1,+    Mergeable2,+    Mergeable3,+  )+import Grisette.Internal.Internal.Decl.Core.Data.Class.PPrint+  ( PPrint,+    PPrint1,+    PPrint2,+  )+import Grisette.Internal.Internal.Decl.Core.Data.Class.SimpleMergeable+  ( SimpleMergeable,+    SimpleMergeable1,+    SimpleMergeable2,+  )+import Grisette.Internal.Internal.Decl.Core.Data.Class.SubstSym+  ( SubstSym,+    SubstSym1,+    SubstSym2,+  )+import Grisette.Internal.Internal.Decl.Core.Data.Class.SymEq+  ( SymEq,+    SymEq1,+    SymEq2,+  )+import Grisette.Internal.Internal.Decl.Core.Data.Class.SymOrd+  ( SymOrd,+    SymOrd1,+    SymOrd2,+  )+import Grisette.Internal.Internal.Decl.Core.Data.Class.ToCon+  ( ToCon,+    ToCon1,+    ToCon2,+  )+import Grisette.Internal.Internal.Decl.Core.Data.Class.ToSym+  ( ToSym,+    ToSym1,+    ToSym2,+  )+import Grisette.Internal.Internal.Decl.SymPrim.AllSyms+  ( AllSyms,+    AllSyms1,+    AllSyms2,+  )+import Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSimpleMergeable+  ( UnifiedSimpleMergeable,+    UnifiedSimpleMergeable1,+    UnifiedSimpleMergeable2,+  )+import Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSymEq+  ( UnifiedSymEq,+    UnifiedSymEq1,+    UnifiedSymEq2,+  )+import Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSymOrd+  ( UnifiedSymOrd,+    UnifiedSymOrd1,+    UnifiedSymOrd2,+  )+import Grisette.Internal.TH.Derivation.Common+  ( DeriveConfig+      ( evalModeConfig,+        needExtraMergeableUnderEvalMode,+        needExtraMergeableWithConcretizedEvalMode+      ),+    EvalModeConfig (EvalModeConstraints, EvalModeSpecified),+  )+import Grisette.Internal.TH.Derivation.DeriveAllSyms+  ( deriveAllSyms,+    deriveAllSyms1,+    deriveAllSyms2,+  )+import Grisette.Internal.TH.Derivation.DeriveBinary (deriveBinary)+import Grisette.Internal.TH.Derivation.DeriveCereal (deriveCereal)+import Grisette.Internal.TH.Derivation.DeriveEq+  ( deriveEq,+    deriveEq1,+    deriveEq2,+  )+import Grisette.Internal.TH.Derivation.DeriveEvalSym+  ( deriveEvalSym,+    deriveEvalSym1,+    deriveEvalSym2,+  )+import Grisette.Internal.TH.Derivation.DeriveExtractSym+  ( deriveExtractSym,+    deriveExtractSym1,+    deriveExtractSym2,+  )+import Grisette.Internal.TH.Derivation.DeriveHashable+  ( deriveHashable,+    deriveHashable1,+    deriveHashable2,+  )+import Grisette.Internal.TH.Derivation.DeriveMergeable (genMergeableList)+import Grisette.Internal.TH.Derivation.DeriveNFData+  ( deriveNFData,+    deriveNFData1,+    deriveNFData2,+  )+import Grisette.Internal.TH.Derivation.DeriveOrd+  ( deriveOrd,+    deriveOrd1,+    deriveOrd2,+  )+import Grisette.Internal.TH.Derivation.DerivePPrint+  ( derivePPrint,+    derivePPrint1,+    derivePPrint2,+  )+import Grisette.Internal.TH.Derivation.DeriveSerial+  ( deriveSerial,+    deriveSerial1,+    deriveSerial2,+  )+import Grisette.Internal.TH.Derivation.DeriveShow+  ( deriveShow,+    deriveShow1,+    deriveShow2,+  )+import Grisette.Internal.TH.Derivation.DeriveSimpleMergeable+  ( deriveSimpleMergeable,+    deriveSimpleMergeable1,+    deriveSimpleMergeable2,+  )+import Grisette.Internal.TH.Derivation.DeriveSubstSym+  ( deriveSubstSym,+    deriveSubstSym1,+    deriveSubstSym2,+  )+import Grisette.Internal.TH.Derivation.DeriveSymEq+  ( deriveSymEq,+    deriveSymEq1,+    deriveSymEq2,+  )+import Grisette.Internal.TH.Derivation.DeriveSymOrd+  ( deriveSymOrd,+    deriveSymOrd1,+    deriveSymOrd2,+  )+import Grisette.Internal.TH.Derivation.DeriveToCon+  ( deriveToCon,+    deriveToCon1,+    deriveToCon2,+  )+import Grisette.Internal.TH.Derivation.DeriveToSym+  ( deriveToSym,+    deriveToSym1,+    deriveToSym2,+  )+import Grisette.Internal.TH.Derivation.DeriveUnifiedSimpleMergeable+  ( deriveUnifiedSimpleMergeable,+    deriveUnifiedSimpleMergeable1,+    deriveUnifiedSimpleMergeable2,+  )+import Grisette.Internal.TH.Derivation.DeriveUnifiedSymEq+  ( deriveUnifiedSymEq,+    deriveUnifiedSymEq1,+    deriveUnifiedSymEq2,+  )+import Grisette.Internal.TH.Derivation.DeriveUnifiedSymOrd+  ( deriveUnifiedSymOrd,+    deriveUnifiedSymOrd1,+    deriveUnifiedSymOrd2,+  )+import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C, S))+import Language.Haskell.TH (Dec, Name, Q)++deriveProcedureMap :: M.Map Name (DeriveConfig -> Name -> Q [Dec])+deriveProcedureMap =+  M.fromList+    [ (''EvalSym, deriveEvalSym),+      (''EvalSym1, deriveEvalSym1),+      (''EvalSym2, deriveEvalSym2),+      (''ExtractSym, deriveExtractSym),+      (''ExtractSym1, deriveExtractSym1),+      (''ExtractSym2, deriveExtractSym2),+      (''SubstSym, deriveSubstSym),+      (''SubstSym1, deriveSubstSym1),+      (''SubstSym2, deriveSubstSym2),+      (''NFData, deriveNFData),+      (''NFData1, deriveNFData1),+      (''NFData2, deriveNFData2),+      (''Hashable, deriveHashable),+      (''Hashable1, deriveHashable1),+      (''Hashable2, deriveHashable2),+      (''Show, deriveShow),+      (''Show1, deriveShow1),+      (''Show2, deriveShow2),+      (''PPrint, derivePPrint),+      (''PPrint1, derivePPrint1),+      (''PPrint2, derivePPrint2),+      (''AllSyms, deriveAllSyms),+      (''AllSyms1, deriveAllSyms1),+      (''AllSyms2, deriveAllSyms2),+      (''Eq, deriveEq),+      (''Eq1, deriveEq1),+      (''Eq2, deriveEq2),+      (''Ord, deriveOrd),+      (''Ord1, deriveOrd1),+      (''Ord2, deriveOrd2),+      (''SymOrd, deriveSymOrd),+      (''SymOrd1, deriveSymOrd1),+      (''SymOrd2, deriveSymOrd2),+      (''SymEq, deriveSymEq),+      (''SymEq1, deriveSymEq1),+      (''SymEq2, deriveSymEq2),+      (''UnifiedSymEq, deriveUnifiedSymEq),+      (''UnifiedSymEq1, deriveUnifiedSymEq1),+      (''UnifiedSymEq2, deriveUnifiedSymEq2),+      (''UnifiedSymOrd, deriveUnifiedSymOrd),+      (''UnifiedSymOrd1, deriveUnifiedSymOrd1),+      (''UnifiedSymOrd2, deriveUnifiedSymOrd2),+      (''ToSym, deriveToSym),+      (''ToSym1, deriveToSym1),+      (''ToSym2, deriveToSym2),+      (''ToCon, deriveToCon),+      (''ToCon1, deriveToCon1),+      (''ToCon2, deriveToCon2),+      (''Serial, deriveSerial),+      (''Serial1, deriveSerial1),+      (''Serial2, deriveSerial2),+      (''SimpleMergeable, deriveSimpleMergeable),+      (''SimpleMergeable1, deriveSimpleMergeable1),+      (''SimpleMergeable2, deriveSimpleMergeable2),+      (''UnifiedSimpleMergeable, deriveUnifiedSimpleMergeable),+      (''UnifiedSimpleMergeable1, deriveUnifiedSimpleMergeable1),+      (''UnifiedSimpleMergeable2, deriveUnifiedSimpleMergeable2),+      (''Binary, deriveBinary),+      (''Serialize, deriveCereal)+    ]++deriveSingle :: DeriveConfig -> Name -> Name -> Q [Dec]+deriveSingle deriveConfig typName className = do+  let newExtra+        | className+            `elem` [ ''Eq,+                     ''Eq1,+                     ''Eq2,+                     ''SymEq,+                     ''SymEq1,+                     ''SymEq2,+                     ''SymOrd,+                     ''SymOrd1,+                     ''SymOrd2,+                     ''UnifiedSymEq,+                     ''UnifiedSymEq1,+                     ''UnifiedSymEq2,+                     ''UnifiedSymOrd,+                     ''UnifiedSymOrd1,+                     ''UnifiedSymOrd2,+                     ''UnifiedSimpleMergeable,+                     ''UnifiedSimpleMergeable1,+                     ''UnifiedSimpleMergeable2+                   ] =+            deriveConfig+              { needExtraMergeableUnderEvalMode = False,+                needExtraMergeableWithConcretizedEvalMode = False+              }+        | className+            `elem` [''SimpleMergeable, ''SimpleMergeable1, ''SimpleMergeable2] =+            deriveConfig+              { evalModeConfig =+                  second+                    ( \case+                        EvalModeConstraints _ -> EvalModeSpecified S+                        EvalModeSpecified tag -> EvalModeSpecified tag+                    )+                    <$> evalModeConfig deriveConfig,+                needExtraMergeableUnderEvalMode = False,+                needExtraMergeableWithConcretizedEvalMode = False+              }+        | className+            `elem` [''Ord, ''Ord1, ''Ord2, ''Hashable, ''Hashable1, ''Hashable2] =+            deriveConfig+              { evalModeConfig =+                  second+                    ( \case+                        EvalModeConstraints _ -> EvalModeSpecified C+                        EvalModeSpecified tag -> EvalModeSpecified tag+                    )+                    <$> evalModeConfig deriveConfig,+                needExtraMergeableUnderEvalMode = False,+                needExtraMergeableWithConcretizedEvalMode = False+              }+        | otherwise = deriveConfig+  case M.lookup className deriveProcedureMap of+    Just procedure -> procedure newExtra typName+    Nothing ->+      fail $ "No derivation available for class " ++ show className++deriveWith' :: DeriveConfig -> Name -> [Name] -> Q [Dec]+deriveWith' deriveConfig typName classNameList = do+  let classNames = S.fromList classNameList+  let (ns, ms) = splitMergeable $ S.toList classNames+  decs <- mapM (deriveSingle deriveConfig typName) ns+  decMergeables <- deriveMergeables ms+  return $ concat decs ++ decMergeables+  where+    configWithOutExtraMergeable :: DeriveConfig+    configWithOutExtraMergeable =+      deriveConfig {needExtraMergeableUnderEvalMode = False}+    deriveMergeables :: [Int] -> Q [Dec]+    deriveMergeables = genMergeableList configWithOutExtraMergeable typName+    splitMergeable :: [Name] -> ([Name], [Int])+    splitMergeable [] = ([], [])+    splitMergeable (x : xs) =+      let (ns, is) = splitMergeable xs+       in if+            | x == ''Mergeable -> (ns, 0 : is)+            | x == ''Mergeable1 -> (ns, 1 : is)+            | x == ''Mergeable2 -> (ns, 2 : is)+            | x == ''Mergeable3 -> (ns, 3 : is)+            | otherwise -> (x : ns, is)++-- | Derive the specified classes for a data type with the given name.+--+-- Support the following classes for both vanilla data types and GADTs.+--+-- * 'Mergeable'+-- * 'Mergeable1'+-- * 'Mergeable2'+-- * 'Mergeable3'+-- * 'EvalSym'+-- * 'EvalSym1'+-- * 'EvalSym2'+-- * 'ExtractSym'+-- * 'ExtractSym1'+-- * 'ExtractSym2'+-- * 'SubstSym'+-- * 'SubstSym1'+-- * 'SubstSym2'+-- * 'NFData'+-- * 'NFData1'+-- * 'NFData2'+-- * 'Hashable' (will fail to derive if the type contains any symbolic variables)+-- * 'Hashable1' (will fail to derive if the type contains any symbolic variables)+-- * 'Hashable2' (will fail to derive if the type contains any symbolic variables)+-- * 'Show'+-- * 'Show1'+-- * 'Show2'+-- * 'PPrint'+-- * 'PPrint1'+-- * 'PPrint2'+-- * 'AllSyms'+-- * 'AllSyms1'+-- * 'AllSyms2'+-- * 'Eq'+-- * 'Eq1'+-- * 'Eq2'+-- * 'Ord' (will fail to derive if the type contains any symbolic variables)+-- * 'Ord1' (will fail to derive if the type contains any symbolic variables)+-- * 'Ord2' (will fail to derive if the type contains any symbolic variables)+-- * 'SymOrd'+-- * 'SymOrd1'+-- * 'SymOrd2'+-- * 'SymEq'+-- * 'SymEq1'+-- * 'SymEq2'+-- * 'UnifiedSymEq'+-- * 'UnifiedSymEq1'+-- * 'UnifiedSymEq2'+-- * 'UnifiedSymOrd'+-- * 'UnifiedSymOrd1'+-- * 'UnifiedSymOrd2'+-- * 'ToSym'+-- * 'ToSym1'+-- * 'ToSym2'+-- * 'ToCon'+-- * 'ToCon1'+-- * 'ToCon2'+-- * 'Serial'+-- * 'Serial1'+-- * 'Serial2'+-- * 'SimpleMergeable'+-- * 'SimpleMergeable1'+-- * 'SimpleMergeable2'+-- * 'Binary'+-- * 'Serialize'+--+-- Note that the following type classes cannot be derived for GADTs with+-- existential type variables.+--+-- * 'ToCon'+-- * 'ToCon1'+-- * 'ToCon2'+-- * 'ToSym'+-- * 'ToSym1'+-- * 'ToSym2'+-- * 'Serial'+-- * 'Serial1'+-- * 'Serial2'+-- * 'Binary'+-- * 'Serialize'+deriveWith :: DeriveConfig -> [Name] -> [Name] -> Q [Dec]+deriveWith deriveConfig typeNameList classNameList = do+  let typeNames = S.toList $ S.fromList typeNameList+  concat+    <$> traverse+      (\typeName -> deriveWith' deriveConfig typeName classNameList)+      typeNames++-- | Derive the specified classes for a data type with the given name.+--+-- See 'deriveWith' for more details.+derive :: [Name] -> [Name] -> Q [Dec]+derive = deriveWith mempty++-- | All the classes that can be derived for GADTs.+--+-- This includes:+--+-- * 'Mergeable'+-- * 'EvalSym'+-- * 'ExtractSym'+-- * 'SubstSym'+-- * 'NFData'+-- * 'Hashable' (will fail to derive if the type contains any symbolic variables)+-- * 'Show'+-- * 'PPrint'+-- * 'AllSyms'+-- * 'Eq'+-- * 'SymEq'+-- * 'SymOrd'+-- * 'UnifiedSymEq'+-- * 'Ord' (will fail to derive if the type contains any symbolic variables)+-- * 'UnifiedSymOrd'+-- * 'Serial'+-- * 'ToCon'+-- * 'ToSym'+allClasses0 :: [Name]+allClasses0 = basicClasses0 ++ concreteOrdClasses0 ++ noExistentialClasses0 ++ hashableClasses0++-- | All the @*1@ classes that can be derived for GADT functors.+--+-- This includes:+--+-- * 'Mergeable1'+-- * 'EvalSym1'+-- * 'ExtractSym1'+-- * 'SubstSym1'+-- * 'NFData1'+-- * 'Hashable1' (will fail to derive if the type contains any symbolic variables)+-- * 'Show1'+-- * 'PPrint1'+-- * 'AllSyms1'+-- * 'Eq1'+-- * 'SymEq1'+-- * 'SymOrd1'+-- * 'UnifiedSymEq1'+-- * 'Ord1' (will fail to derive if the type contains any symbolic variables)+-- * 'UnifiedSymOrd1'+-- * 'Serial1'+-- * 'ToCon1'+-- * 'ToSym1'+allClasses1 :: [Name]+allClasses1 = basicClasses1 ++ concreteOrdClasses1 ++ noExistentialClasses1 ++ hashableClasses1++-- | All the classes that can be derived for GADT functors.+--+-- This includes all the classes in 'allClasses0' and 'allClasses1'.+allClasses01 :: [Name]+allClasses01 = allClasses0 ++ allClasses1++-- | All the @*2@ classes that can be derived for GADT functors.+--+-- This includes:+--+-- * 'Mergeable2'+-- * 'EvalSym2'+-- * 'ExtractSym2'+-- * 'SubstSym2'+-- * 'NFData2'+-- * 'Hashable2' (will fail to derive if the type contains any symbolic variables)+-- * 'Show2'+-- * 'PPrint2'+-- * 'AllSyms2'+-- * 'Eq2'+-- * 'SymEq2'+-- * 'SymOrd2'+-- * 'UnifiedSymEq2'+-- * 'Ord2' (will fail to derive if the type contains any symbolic variables)+-- * 'UnifiedSymOrd2'+-- * 'Serial2'+-- * 'ToCon2'+-- * 'ToSym2'+allClasses2 :: [Name]+allClasses2 = basicClasses2 ++ concreteOrdClasses2 ++ noExistentialClasses2 ++ hashableClasses2++-- | All the classes that can be derived for GADT functors.+--+-- This includes all the classes in 'allClasses0', 'allClasses1',+-- and 'allClasses2'.+allClasses012 :: [Name]+allClasses012 = allClasses0 ++ allClasses1 ++ allClasses2++-- | Basic classes for GADTs.+--+-- This includes:+--+-- * 'Mergeable'+-- * 'EvalSym'+-- * 'ExtractSym'+-- * 'SubstSym'+-- * 'NFData'+-- * 'Show'+-- * 'PPrint'+-- * 'AllSyms'+-- * 'Eq'+-- * 'SymEq'+-- * 'SymOrd'+-- * 'UnifiedSymEq'+--+-- These classes can be derived for most GADTs.+basicClasses0 :: [Name]+basicClasses0 =+  [ ''Mergeable,+    ''EvalSym,+    ''ExtractSym,+    ''SubstSym,+    ''NFData,+    ''Show,+    ''PPrint,+    ''AllSyms,+    ''Eq,+    ''SymEq,+    ''SymOrd,+    ''UnifiedSymEq+  ]++-- | Classes that can only be derived for GADTs without existential type+-- variables.+--+-- This includes:+--+-- * 'Serial'+-- * 'Serialize'+-- * 'Binary'+-- * 'ToCon'+-- * 'ToSym'+noExistentialClasses0 :: [Name]+noExistentialClasses0 = [''Serial, ''ToCon, ''ToSym, ''Serialize, ''Binary]++-- | Concrete ordered classes that can be derived for GADTs that+--+-- * uses unified evaluation mode, or+-- * does not contain any symbolic variables.+--+-- This includes:+--+-- * 'Ord' (will fail to derive if the type contains any symbolic variables)+-- * 'UnifiedSymOrd'+concreteOrdClasses0 :: [Name]+concreteOrdClasses0 = [''Ord, ''UnifiedSymOrd]++-- | Hashable classes that can be derived for GADTs.+--+-- This includes:+--+-- * 'Hashable' (will fail to derive if the type contains any symbolic variables)+hashableClasses0 :: [Name]+hashableClasses0 = [''Hashable]++-- | Basic classes for GADT functors.+--+-- This includes:+--+-- * 'Mergeable1'+-- * 'EvalSym1'+-- * 'ExtractSym1'+-- * 'SubstSym1'+-- * 'NFData1'+-- * 'Show1'+-- * 'PPrint1'+-- * 'AllSyms1'+-- * 'Eq1'+-- * 'SymEq1'+-- * 'SymOrd1'+-- * 'UnifiedSymEq1'+basicClasses1 :: [Name]+basicClasses1 =+  [ ''Mergeable1,+    ''EvalSym1,+    ''ExtractSym1,+    ''SubstSym1,+    ''NFData1,+    ''Show1,+    ''PPrint1,+    ''AllSyms1,+    ''Eq1,+    ''SymEq1,+    ''SymOrd1,+    ''UnifiedSymEq1+  ]++-- | Basic classes for GADT functors.+--+-- This includes all the classes in 'basicClasses0' and 'basicClasses1'.+basicClasses01 :: [Name]+basicClasses01 = basicClasses0 ++ basicClasses1++-- | @*1@ classes that can only be derived for GADT functors without existential+-- type variables.+--+-- This includes:+--+-- * 'Serial1'+-- * 'ToCon1'+-- * 'ToSym1'+noExistentialClasses1 :: [Name]+noExistentialClasses1 = [''Serial1, ''ToCon1, ''ToSym1]++-- | @*1@ concrete ordered classes that can be derived for GADT functors that+--+-- * uses unified evaluation mode, or+-- * does not contain any symbolic variables.+--+-- This includes:+--+-- * 'Ord1' (will fail to derive if the type contains any symbolic variables)+-- * 'UnifiedSymOrd1'+concreteOrdClasses1 :: [Name]+concreteOrdClasses1 = [''Ord1, ''UnifiedSymOrd1]++-- | Hashable classes that can be derived for GADT functors.+--+-- This includes:+--+-- * 'Hashable1' (will fail to derive if the type contains any symbolic variables)+hashableClasses1 :: [Name]+hashableClasses1 = [''Hashable1]++-- | Basic classes for GADT functors.+--+-- This includes:+--+-- * 'Mergeable2'+-- * 'EvalSym2'+-- * 'ExtractSym2'+-- * 'SubstSym2'+-- * 'NFData2'+-- * 'Show2'+-- * 'PPrint2'+-- * 'AllSyms2'+-- * 'Eq2'+-- * 'SymEq2'+-- * 'SymOrd2'+-- * 'UnifiedSymEq2'+basicClasses2 :: [Name]+basicClasses2 =+  [ ''Mergeable2,+    ''EvalSym2,+    ''ExtractSym2,+    ''SubstSym2,+    ''NFData2,+    ''Show2,+    ''PPrint2,+    ''AllSyms2,+    ''Eq2,+    ''SymEq2,+    ''SymOrd2,+    ''UnifiedSymEq2+  ]++-- | Basic classes for GADT functors.+--+-- This includes all the classes in 'basicClasses0' and 'basicClasses1' and+-- 'basicClasses2'.+basicClasses012 :: [Name]+basicClasses012 = basicClasses0 ++ basicClasses1 ++ basicClasses2++-- | @*2@ classes that can only be derived for GADT functors without existential+-- type variables.+--+-- This includes:+--+-- * 'Serial2'+-- * 'ToCon2'+-- * 'ToSym2'+noExistentialClasses2 :: [Name]+noExistentialClasses2 = [''Serial2, ''ToCon2, ''ToSym2]++-- | @*2@ concrete ordered classes that can be derived for GADT functors that+--+-- * uses unified evaluation mode, or+-- * does not contain any symbolic variables.+--+-- This includes:+--+-- * 'Ord2' (will fail to derive if the type contains any symbolic variables)+-- * 'UnifiedSymOrd2'+concreteOrdClasses2 :: [Name]+concreteOrdClasses2 = [''Ord2, ''UnifiedSymOrd2]++-- | Hashable classes that can be derived for GADT functors.+--+-- This includes:+--+-- * 'Hashable2' (will fail to derive if the type contains any symbolic variables)+hashableClasses2 :: [Name]+hashableClasses2 = [''Hashable2]++-- | 'Show' classes that can be derived for GADTs.+--+-- This includes:+--+-- * 'Show'+-- * 'Show1'+-- * 'Show2'+showClasses :: [Name]+showClasses = [''Show, ''Show1, ''Show2]++-- | 'PPrint' classes that can be derived for GADTs.+--+-- This includes:+--+-- * 'PPrint'+-- * 'PPrint1'+-- * 'PPrint2'+pprintClasses :: [Name]+pprintClasses = [''PPrint, ''PPrint1, ''PPrint2]++-- | 'EvalSym' classes that can be derived for GADTs.+--+-- This includes:+--+-- * 'EvalSym'+-- * 'EvalSym1'+-- * 'EvalSym2'+evalSymClasses :: [Name]+evalSymClasses = [''EvalSym, ''EvalSym1, ''EvalSym2]++-- | 'ExtractSym' classes that can be derived for GADTs.+--+-- This includes:+--+-- * 'ExtractSym'+-- * 'ExtractSym1'+-- * 'ExtractSym2'+extractSymClasses :: [Name]+extractSymClasses = [''ExtractSym, ''ExtractSym1, ''ExtractSym2]++-- | 'SubstSym' classes that can be derived for GADTs.+--+-- This includes:+--+-- * 'SubstSym'+-- * 'SubstSym1'+-- * 'SubstSym2'+substSymClasses :: [Name]+substSymClasses = [''SubstSym, ''SubstSym1, ''SubstSym2]++-- | 'AllSyms' classes that can be derived for GADTs.+--+-- This includes:+--+-- * 'AllSyms'+-- * 'AllSyms1'+-- * 'AllSyms2'+allSymsClasses :: [Name]+allSymsClasses = [''AllSyms, ''AllSyms1, ''AllSyms2]++-- | 'Eq' classes that can be derived for GADTs.+--+-- This includes:+--+-- * 'Eq'+-- * 'Eq1'+-- * 'Eq2'+eqClasses :: [Name]+eqClasses = [''Eq, ''Eq1, ''Eq2]++-- | 'SymEq' classes that can be derived for GADTs.+--+-- This includes:+--+-- * 'SymEq'+-- * 'SymEq1'+-- * 'SymEq2'+symEqClasses :: [Name]+symEqClasses = [''SymEq, ''SymEq1, ''SymEq2]++-- | 'UnifiedSymEq' classes that can be derived for GADTs.+--+-- This includes:+--+-- * 'UnifiedSymEq'+-- * 'UnifiedSymEq1'+-- * 'UnifiedSymEq2'+unifiedSymEqClasses :: [Name]+unifiedSymEqClasses = [''UnifiedSymEq, ''UnifiedSymEq1, ''UnifiedSymEq2]++-- | 'Ord' classes that can be derived for GADTs.+--+-- This includes:+--+-- * 'Ord' (will fail to derive if the type contains any symbolic variables)+-- * 'Ord1' (will fail to derive if the type contains any symbolic variables)+-- * 'Ord2' (will fail to derive if the type contains any symbolic variables)+ordClasses :: [Name]+ordClasses = [''Ord, ''Ord1, ''Ord2]++-- | 'SymOrd' classes that can be derived for GADTs.+--+-- This includes:+--+-- * 'SymOrd'+-- * 'SymOrd1'+-- * 'SymOrd2'+symOrdClasses :: [Name]+symOrdClasses = [''SymOrd, ''SymOrd1, ''SymOrd2]++-- | 'UnifiedSymOrd' classes that can be derived for GADTs.+--+-- This includes:+--+-- * 'UnifiedSymOrd'+-- * 'UnifiedSymOrd1'+-- * 'UnifiedSymOrd2'+unifiedSymOrdClasses :: [Name]+unifiedSymOrdClasses = [''UnifiedSymOrd, ''UnifiedSymOrd1, ''UnifiedSymOrd2]++-- | 'Mergeable' classes that can be derived for GADTs.+--+-- This includes:+--+-- * 'Mergeable'+-- * 'Mergeable1'+-- * 'Mergeable2'+-- * 'Mergeable3'+mergeableClasses :: [Name]+mergeableClasses = [''Mergeable, ''Mergeable1, ''Mergeable2, ''Mergeable3]++-- | 'NFData' classes that can be derived for GADTs.+--+-- This includes:+--+-- * 'NFData'+-- * 'NFData1'+-- * 'NFData2'+nfDataClasses :: [Name]+nfDataClasses = [''NFData, ''NFData1, ''NFData2]++-- | 'Hashable' classes that can be derived for GADTs.+--+-- This includes:+--+-- * 'Hashable' (will fail to derive if the type contains any symbolic variables)+-- * 'Hashable1' (will fail to derive if the type contains any symbolic variables)+-- * 'Hashable2' (will fail to derive if the type contains any symbolic variables)+hashableClasses :: [Name]+hashableClasses = [''Hashable, ''Hashable1, ''Hashable2]++-- | 'ToSym' classes that can be derived for GADTs.+--+-- This includes:+--+-- * 'ToSym'+-- * 'ToSym1'+-- * 'ToSym2'+toSymClasses :: [Name]+toSymClasses = [''ToSym, ''ToSym1, ''ToSym2]++-- | 'ToCon' classes that can be derived for GADTs.+--+-- This includes:+--+-- * 'ToCon'+-- * 'ToCon1'+-- * 'ToCon2'+toConClasses :: [Name]+toConClasses = [''ToCon, ''ToCon1, ''ToCon2]++-- | 'Serial' classes that can be derived for GADTs.+--+-- This includes:+--+-- * 'Serial'+-- * 'Serial1'+-- * 'Serial2'+serialClasses :: [Name]+serialClasses = [''Serial, ''Serial1, ''Serial2]++-- | 'SimpleMergeable' classes that can be derived for GADTs.+--+-- This includes:+--+-- * 'SimpleMergeable'+-- * 'SimpleMergeable1'+-- * 'SimpleMergeable2'+simpleMergeableClasses :: [Name]+simpleMergeableClasses =+  [''SimpleMergeable, ''SimpleMergeable1, ''SimpleMergeable2]++-- | 'UnifiedSimpleMergeable' classes that can be derived for GADTs.+--+-- This includes:+--+-- * 'UnifiedSimpleMergeable'+-- * 'UnifiedSimpleMergeable1'+-- * 'UnifiedSimpleMergeable2'+unifiedSimpleMergeableClasses :: [Name]+unifiedSimpleMergeableClasses =+  [ ''UnifiedSimpleMergeable,+    ''UnifiedSimpleMergeable1,+    ''UnifiedSimpleMergeable2+  ]++clsArgNumArgs :: Name -> Int+clsArgNumArgs cls =+  if+    | cls `elem` allClasses0 -> 0+    | cls `elem` allClasses1 -> 1+    | cls `elem` allClasses2 -> 2+    | cls == ''Mergeable3 -> 3+    | otherwise -> error $ "clsArgNumArgs: unknown class: " ++ show cls++-- | Filter classes that accepts type constructors with exactly @n@ arguments.+filterExactNumArgs :: Int -> [Name] -> [Name]+filterExactNumArgs n = filter (\cls -> clsArgNumArgs cls == n)++-- | Filter classes that accepts type constructors with at most @n@ arguments.+filterLeqNumArgs :: Int -> [Name] -> [Name]+filterLeqNumArgs n = filter (\cls -> clsArgNumArgs cls <= n)
+ src/Grisette/Internal/TH/Derivation/DeriveAllSyms.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Unused LANGUAGE pragma" #-}++-- |+-- Module      :   Grisette.Internal.TH.Derivation.DeriveAllSyms+-- 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.Derivation.DeriveAllSyms+  ( deriveAllSyms,+    deriveAllSyms1,+    deriveAllSyms2,+  )+where++import Grisette.Internal.Internal.Decl.SymPrim.AllSyms+  ( AllSyms (allSymsS),+    AllSyms1 (liftAllSymsS),+    AllSyms2 (liftAllSymsS2),+  )+import Grisette.Internal.TH.Derivation.Common (DeriveConfig)+import Grisette.Internal.TH.Derivation.UnaryOpCommon+  ( UnaryOpClassConfig+      ( UnaryOpClassConfig,+        unaryOpAllowExistential,+        unaryOpConfigs,+        unaryOpContextNames,+        unaryOpExtraVars,+        unaryOpInstanceNames,+        unaryOpInstanceTypeFromConfig+      ),+    UnaryOpConfig (UnaryOpConfig),+    UnaryOpFieldConfig+      ( UnaryOpFieldConfig,+        extraLiftedPatNames,+        extraPatNames,+        fieldCombineFun,+        fieldFunExp,+        fieldResFun+      ),+    defaultFieldFunExp,+    defaultFieldResFun,+    defaultUnaryOpInstanceTypeFromConfig,+    genUnaryOpClass,+  )+import Language.Haskell.TH (Dec, Exp (AppE, ListE, VarE), Name, Q)++allSymsConfig :: UnaryOpClassConfig+allSymsConfig =+  UnaryOpClassConfig+    { unaryOpConfigs =+        [ UnaryOpConfig+            UnaryOpFieldConfig+              { extraPatNames = [],+                extraLiftedPatNames = const [],+                fieldResFun = defaultFieldResFun,+                fieldCombineFun = \_ _ _ _ _ exp ->+                  return (AppE (VarE 'mconcat) $ ListE exp, False <$ exp),+                fieldFunExp =+                  defaultFieldFunExp+                    [ 'allSymsS,+                      'liftAllSymsS,+                      'liftAllSymsS2+                    ]+              }+            ['allSymsS, 'liftAllSymsS, 'liftAllSymsS2]+        ],+      unaryOpInstanceNames = [''AllSyms, ''AllSyms1, ''AllSyms2],+      unaryOpExtraVars = const $ return [],+      unaryOpInstanceTypeFromConfig = defaultUnaryOpInstanceTypeFromConfig,+      unaryOpAllowExistential = True,+      unaryOpContextNames = Nothing+    }++-- | Derive 'AllSyms' instance for a data type.+deriveAllSyms :: DeriveConfig -> Name -> Q [Dec]+deriveAllSyms deriveConfig = genUnaryOpClass deriveConfig allSymsConfig 0++-- | Derive 'AllSyms1' instance for a data type.+deriveAllSyms1 :: DeriveConfig -> Name -> Q [Dec]+deriveAllSyms1 deriveConfig = genUnaryOpClass deriveConfig allSymsConfig 1++-- | Derive 'AllSyms2' instance for a data type.+deriveAllSyms2 :: DeriveConfig -> Name -> Q [Dec]+deriveAllSyms2 deriveConfig = genUnaryOpClass deriveConfig allSymsConfig 2
+ src/Grisette/Internal/TH/Derivation/DeriveBinary.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Unused LANGUAGE pragma" #-}++-- |+-- Module      :   Grisette.Internal.TH.Derivation.DeriveBinary+-- 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.Derivation.DeriveBinary (deriveBinary) where++import Data.Binary (Binary (get, put))+import Grisette.Internal.TH.Derivation.Common+  ( DeriveConfig (useSerialForCerealAndBinary),+  )+import Grisette.Internal.TH.Derivation.SerializeCommon+  ( serializeConfig,+    serializeWithSerialConfig,+  )+import Grisette.Internal.TH.Derivation.UnaryOpCommon+  ( UnaryOpClassConfig,+    genUnaryOpClass,+  )+import Language.Haskell.TH (Dec, Name, Q)++binaryConfig :: UnaryOpClassConfig+binaryConfig = serializeConfig [''Binary] ['put] ['get]++binaryWithSerialConfig :: UnaryOpClassConfig+binaryWithSerialConfig =+  serializeWithSerialConfig [''Binary] ['put] ['get]++-- | Derive 'Binary' instance for a data type.+deriveBinary :: DeriveConfig -> Name -> Q [Dec]+deriveBinary deriveConfig =+  genUnaryOpClass+    deriveConfig+    ( if useSerialForCerealAndBinary deriveConfig+        then binaryWithSerialConfig+        else binaryConfig+    )+    0
+ src/Grisette/Internal/TH/Derivation/DeriveCereal.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Unused LANGUAGE pragma" #-}++-- |+-- Module      :   Grisette.Internal.TH.Derivation.DeriveCereal+-- 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.Derivation.DeriveCereal (deriveCereal) where++import Data.Serialize (Serialize (get, put))+import Grisette.Internal.TH.Derivation.Common+  ( DeriveConfig (useSerialForCerealAndBinary),+  )+import Grisette.Internal.TH.Derivation.SerializeCommon+  ( serializeConfig,+    serializeWithSerialConfig,+  )+import Grisette.Internal.TH.Derivation.UnaryOpCommon+  ( UnaryOpClassConfig,+    genUnaryOpClass,+  )+import Language.Haskell.TH (Dec, Name, Q)++cerealConfig :: UnaryOpClassConfig+cerealConfig = serializeConfig [''Serialize] ['put] ['get]++cerealWithSerialConfig :: UnaryOpClassConfig+cerealWithSerialConfig =+  serializeWithSerialConfig [''Serialize] ['put] ['get]++-- | Derive 'Serialize' instance for a data type.+deriveCereal :: DeriveConfig -> Name -> Q [Dec]+deriveCereal deriveConfig =+  genUnaryOpClass+    deriveConfig+    ( if useSerialForCerealAndBinary deriveConfig+        then cerealWithSerialConfig+        else cerealConfig+    )+    0
+ src/Grisette/Internal/TH/Derivation/DeriveEq.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}++-- |+-- Module      :   Grisette.Internal.TH.Derivation.DeriveEq+-- 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.Derivation.DeriveEq+  ( deriveEq,+    deriveEq1,+    deriveEq2,+  )+where++import Data.Functor.Classes (Eq1 (liftEq), Eq2 (liftEq2))+import Grisette.Internal.TH.Derivation.BinaryOpCommon+  ( BinaryOpClassConfig+      ( BinaryOpClassConfig,+        binaryOpAllowSumType,+        binaryOpFieldConfigs,+        binaryOpInstanceNames+      ),+    BinaryOpFieldConfig+      ( BinaryOpFieldConfig,+        extraPatNames,+        fieldCombineFun,+        fieldDifferentExistentialFun,+        fieldFunExp,+        fieldFunNames,+        fieldLMatchResult,+        fieldRMatchResult,+        fieldResFun+      ),+    binaryOpAllowExistential,+    defaultFieldFunExp,+    genBinaryOpClass,+  )+import Grisette.Internal.TH.Derivation.Common (DeriveConfig)+import Language.Haskell.TH (Dec, Exp (ListE), Q)+import Language.Haskell.TH.Syntax (Name)++eqConfig :: BinaryOpClassConfig+eqConfig =+  BinaryOpClassConfig+    { binaryOpFieldConfigs =+        [ BinaryOpFieldConfig+            { extraPatNames = [],+              fieldResFun = \_ (lhs, rhs) f ->+                (,[]) <$> [|$(return f) $(return lhs) $(return rhs)|],+              fieldCombineFun = \_ lst ->+                (,[]) <$> [|and $(return $ ListE lst)|],+              fieldDifferentExistentialFun = const [|False|],+              fieldFunExp = defaultFieldFunExp ['(==), 'liftEq, 'liftEq2],+              fieldFunNames = ['(==), 'liftEq, 'liftEq2],+              fieldLMatchResult = [|False|],+              fieldRMatchResult = [|False|]+            }+        ],+      binaryOpInstanceNames = [''Eq, ''Eq1, ''Eq2],+      binaryOpAllowSumType = True,+      binaryOpAllowExistential = True+    }++-- | Derive 'Eq' instance for a data type.+deriveEq :: DeriveConfig -> Name -> Q [Dec]+deriveEq deriveConfig = genBinaryOpClass deriveConfig eqConfig 0++-- | Derive 'Eq1' instance for a data type.+deriveEq1 :: DeriveConfig -> Name -> Q [Dec]+deriveEq1 deriveConfig = genBinaryOpClass deriveConfig eqConfig 1++-- | Derive 'Eq2' instance for a data type.+deriveEq2 :: DeriveConfig -> Name -> Q [Dec]+deriveEq2 deriveConfig = genBinaryOpClass deriveConfig eqConfig 2
+ src/Grisette/Internal/TH/Derivation/DeriveEvalSym.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Unused LANGUAGE pragma" #-}++-- |+-- Module      :   Grisette.Internal.TH.Derivation.DeriveEvalSym+-- 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.Derivation.DeriveEvalSym+  ( deriveEvalSym,+    deriveEvalSym1,+    deriveEvalSym2,+  )+where++import Grisette.Internal.Internal.Decl.Core.Data.Class.EvalSym+  ( EvalSym (evalSym),+    EvalSym1 (liftEvalSym),+    EvalSym2 (liftEvalSym2),+  )+import Grisette.Internal.TH.Derivation.Common (DeriveConfig)+import Grisette.Internal.TH.Derivation.UnaryOpCommon+  ( UnaryOpClassConfig+      ( UnaryOpClassConfig,+        unaryOpAllowExistential,+        unaryOpConfigs,+        unaryOpContextNames,+        unaryOpExtraVars,+        unaryOpInstanceNames,+        unaryOpInstanceTypeFromConfig+      ),+    UnaryOpConfig (UnaryOpConfig),+    UnaryOpFieldConfig+      ( UnaryOpFieldConfig,+        extraLiftedPatNames,+        extraPatNames,+        fieldCombineFun,+        fieldFunExp,+        fieldResFun+      ),+    defaultFieldFunExp,+    defaultFieldResFun,+    defaultUnaryOpInstanceTypeFromConfig,+    genUnaryOpClass,+  )+import Language.Haskell.TH+  ( Dec,+    Exp (AppE, ConE),+    Name,+    Q,+  )++evalSymConfig :: UnaryOpClassConfig+evalSymConfig =+  UnaryOpClassConfig+    { unaryOpConfigs =+        [ UnaryOpConfig+            UnaryOpFieldConfig+              { extraPatNames = ["fillDefault", "model"],+                extraLiftedPatNames = const [],+                fieldResFun = defaultFieldResFun,+                fieldCombineFun = \_ _ _ con extraPat exp -> do+                  return (foldl AppE (ConE con) exp, False <$ extraPat),+                fieldFunExp =+                  defaultFieldFunExp ['evalSym, 'liftEvalSym, 'liftEvalSym2]+              }+            ['evalSym, 'liftEvalSym, 'liftEvalSym2]+        ],+      unaryOpInstanceNames =+        [''EvalSym, ''EvalSym1, ''EvalSym2],+      unaryOpExtraVars = const $ return [],+      unaryOpInstanceTypeFromConfig = defaultUnaryOpInstanceTypeFromConfig,+      unaryOpAllowExistential = True,+      unaryOpContextNames = Nothing+    }++-- | Derive 'EvalSym' instance for a data type.+deriveEvalSym :: DeriveConfig -> Name -> Q [Dec]+deriveEvalSym deriveConfig = genUnaryOpClass deriveConfig evalSymConfig 0++-- | Derive 'EvalSym1' instance for a data type.+deriveEvalSym1 :: DeriveConfig -> Name -> Q [Dec]+deriveEvalSym1 deriveConfig = genUnaryOpClass deriveConfig evalSymConfig 1++-- | Derive 'EvalSym2' instance for a data type.+deriveEvalSym2 :: DeriveConfig -> Name -> Q [Dec]+deriveEvalSym2 deriveConfig = genUnaryOpClass deriveConfig evalSymConfig 2
+ src/Grisette/Internal/TH/Derivation/DeriveExtractSym.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE TemplateHaskell #-}+{-# HLINT ignore "Unused LANGUAGE pragma" #-}+{-# LANGUAGE TupleSections #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++-- |+-- Module      :   Grisette.Internal.TH.Derivation.DeriveExtractSym+-- 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.Derivation.DeriveExtractSym+  ( deriveExtractSym,+    deriveExtractSym1,+    deriveExtractSym2,+  )+where++import Grisette.Internal.Internal.Decl.Core.Data.Class.ExtractSym+  ( ExtractSym (extractSymMaybe),+    ExtractSym1 (liftExtractSymMaybe),+    ExtractSym2 (liftExtractSymMaybe2),+  )+import Grisette.Internal.TH.Derivation.Common (DeriveConfig)+import Grisette.Internal.TH.Derivation.UnaryOpCommon+  ( UnaryOpClassConfig+      ( UnaryOpClassConfig,+        unaryOpAllowExistential,+        unaryOpConfigs,+        unaryOpContextNames,+        unaryOpExtraVars,+        unaryOpInstanceNames,+        unaryOpInstanceTypeFromConfig+      ),+    UnaryOpConfig (UnaryOpConfig),+    UnaryOpFieldConfig+      ( UnaryOpFieldConfig,+        extraLiftedPatNames,+        extraPatNames,+        fieldCombineFun,+        fieldFunExp,+        fieldResFun+      ),+    defaultFieldFunExp,+    defaultFieldResFun,+    defaultUnaryOpInstanceTypeFromConfig,+    genUnaryOpClass,+  )+import Language.Haskell.TH+  ( Dec,+    Exp (AppE, ListE, VarE),+    Name,+    Q,+  )++extractSymConfig :: UnaryOpClassConfig+extractSymConfig =+  UnaryOpClassConfig+    { unaryOpConfigs =+        [ UnaryOpConfig+            UnaryOpFieldConfig+              { extraPatNames = [],+                extraLiftedPatNames = const [],+                fieldResFun = defaultFieldResFun,+                fieldCombineFun = \_ _ _ _ _ exp ->+                  if null exp+                    then (,[]) <$> [|return mempty|]+                    else return (AppE (VarE 'mconcat) $ ListE exp, False <$ exp),+                fieldFunExp =+                  defaultFieldFunExp+                    [ 'extractSymMaybe,+                      'liftExtractSymMaybe,+                      'liftExtractSymMaybe2+                    ]+              }+            [ 'extractSymMaybe,+              'liftExtractSymMaybe,+              'liftExtractSymMaybe2+            ]+        ],+      unaryOpInstanceNames =+        [''ExtractSym, ''ExtractSym1, ''ExtractSym2],+      unaryOpExtraVars = const $ return [],+      unaryOpInstanceTypeFromConfig = defaultUnaryOpInstanceTypeFromConfig,+      unaryOpAllowExistential = True,+      unaryOpContextNames = Nothing+    }++-- | Derive 'ExtractSym' instance for a data type.+deriveExtractSym :: DeriveConfig -> Name -> Q [Dec]+deriveExtractSym deriveConfig = genUnaryOpClass deriveConfig extractSymConfig 0++-- | Derive 'ExtractSym1' instance for a data type.+deriveExtractSym1 :: DeriveConfig -> Name -> Q [Dec]+deriveExtractSym1 deriveConfig = genUnaryOpClass deriveConfig extractSymConfig 1++-- | Derive 'ExtractSym2' instance for a data type.+deriveExtractSym2 :: DeriveConfig -> Name -> Q [Dec]+deriveExtractSym2 deriveConfig = genUnaryOpClass deriveConfig extractSymConfig 2
+ src/Grisette/Internal/TH/Derivation/DeriveHashable.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE TemplateHaskell #-}++-- |+-- Module      :   Grisette.Internal.TH.Derivation.DeriveHashable+-- 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.Derivation.DeriveHashable+  ( deriveHashable,+    deriveHashable1,+    deriveHashable2,+  )+where++import Data.Hashable (Hashable (hashWithSalt))+import Data.Hashable.Lifted+  ( Hashable1 (liftHashWithSalt),+    Hashable2 (liftHashWithSalt2),+  )+import Grisette.Internal.TH.Derivation.Common (DeriveConfig)+import Grisette.Internal.TH.Derivation.UnaryOpCommon+  ( UnaryOpClassConfig+      ( UnaryOpClassConfig,+        unaryOpAllowExistential,+        unaryOpConfigs,+        unaryOpContextNames,+        unaryOpExtraVars,+        unaryOpInstanceNames,+        unaryOpInstanceTypeFromConfig+      ),+    UnaryOpConfig (UnaryOpConfig),+    UnaryOpFieldConfig+      ( UnaryOpFieldConfig,+        extraLiftedPatNames,+        extraPatNames,+        fieldCombineFun,+        fieldFunExp,+        fieldResFun+      ),+    defaultFieldFunExp,+    defaultUnaryOpInstanceTypeFromConfig,+    genUnaryOpClass,+  )+import Language.Haskell.TH (Dec, Name, Q)++hashableConfig :: UnaryOpClassConfig+hashableConfig =+  UnaryOpClassConfig+    { unaryOpConfigs =+        [ UnaryOpConfig+            UnaryOpFieldConfig+              { extraPatNames = ["salt"],+                extraLiftedPatNames = const [],+                fieldCombineFun =+                  \_ _ _ _ [salt] exp -> do+                    r <-+                      foldl+                        (\salt exp -> [|$(return exp) $salt|])+                        (return salt)+                        exp+                    return (r, [True]),+                fieldResFun = \_ _ _ _ fieldPat fieldFun -> do+                  r <- [|\salt -> $(return fieldFun) salt $(return fieldPat)|]+                  return (r, [False]),+                fieldFunExp =+                  defaultFieldFunExp+                    ['hashWithSalt, 'liftHashWithSalt, 'liftHashWithSalt2]+              }+            ['hashWithSalt, 'liftHashWithSalt, 'liftHashWithSalt2]+        ],+      unaryOpInstanceNames =+        [''Hashable, ''Hashable1, ''Hashable2],+      unaryOpExtraVars = const $ return [],+      unaryOpInstanceTypeFromConfig = defaultUnaryOpInstanceTypeFromConfig,+      unaryOpAllowExistential = True,+      unaryOpContextNames = Nothing+    }++-- | Derive 'Hashable' instance for a data type.+deriveHashable :: DeriveConfig -> Name -> Q [Dec]+deriveHashable deriveConfig = genUnaryOpClass deriveConfig hashableConfig 0++-- | Derive 'Hashable1' instance for a data type.+deriveHashable1 :: DeriveConfig -> Name -> Q [Dec]+deriveHashable1 deriveConfig = genUnaryOpClass deriveConfig hashableConfig 1++-- | Derive 'Hashable2' instance for a data type.+deriveHashable2 :: DeriveConfig -> Name -> Q [Dec]+deriveHashable2 deriveConfig = genUnaryOpClass deriveConfig hashableConfig 2
+ src/Grisette/Internal/TH/Derivation/DeriveMergeable.hs view
@@ -0,0 +1,857 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}++-- |+-- Module      :   Grisette.Internal.TH.Derivation.DeriveMergeable+-- 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.Derivation.DeriveMergeable+  ( deriveMergeable,+    deriveMergeable1,+    deriveMergeable2,+    deriveMergeable3,+    genMergeableAndGetMergingInfoResult,+    genMergeable,+    genMergeable',+    genMergeableNoExistential,+    genMergeableNoStrategy,+    genMergeableList,+  )+where++import Control.Monad (foldM, replicateM, zipWithM)+import qualified Data.Map as M+import Data.Maybe (catMaybes, isJust, mapMaybe)+import qualified Data.Set as S+import Data.Word (Word16, Word32, Word64, Word8)+import Grisette.Internal.Internal.Decl.Core.Data.Class.Mergeable+  ( Mergeable (rootStrategy),+    Mergeable1 (liftRootStrategy),+    Mergeable2 (liftRootStrategy2),+    Mergeable3 (liftRootStrategy3),+    MergingStrategy (NoStrategy, SimpleStrategy, SortedStrategy),+    product2Strategy,+    wrapStrategy,+  )+import Grisette.Internal.TH.Derivation.Common+  ( CheckArgsResult+      ( CheckArgsResult,+        argVars,+        constructors,+        keptVars+      ),+    DeriveConfig (unconstrainedPositions, useNoStrategy),+    checkArgs,+    evalModeSpecializeList,+    extraConstraint,+    isVarUsedInFields,+    specializeResult,+  )+import Grisette.Internal.TH.Derivation.UnaryOpCommon+  ( FieldFunExp,+    UnaryOpClassConfig+      ( UnaryOpClassConfig,+        unaryOpAllowExistential,+        unaryOpConfigs,+        unaryOpContextNames,+        unaryOpExtraVars,+        unaryOpInstanceNames,+        unaryOpInstanceTypeFromConfig+      ),+    UnaryOpConfig (UnaryOpConfig),+    UnaryOpFunConfig (genUnaryOpFun),+    defaultUnaryOpInstanceTypeFromConfig,+    genUnaryOpClass,+  )+import Grisette.Internal.TH.Util (dataTypeHasExistential, integerE, mangleName)+import Language.Haskell.TH+  ( Bang (Bang),+    Body (NormalB),+    Clause (Clause),+    Con (ForallC, GadtC),+    Dec (DataD, FunD, InstanceD, PragmaD, SigD),+    Exp (AppE, ConE, VarE),+    Inline (Inline),+    Kind,+    Name,+    Pat (SigP, VarP, WildP),+    Phases (AllPhases),+    Pragma (InlineP),+    Pred,+    Q,+    RuleMatch (FunLike),+    SourceStrictness (NoSourceStrictness),+    SourceUnpackedness (NoSourceUnpackedness),+    Type (AppT, ArrowT, ConT, ForallT, StarT, VarT),+    appE,+    caseE,+    conE,+    conT,+    integerL,+    lamE,+    litP,+    lookupTypeName,+    mkName,+    nameBase,+    newName,+    normalB,+    recP,+    sigP,+    tupP,+    varE,+    varP,+    varT,+    wildP,+  )+import Language.Haskell.TH.Datatype+  ( ConstructorInfo+      ( constructorContext,+        constructorFields,+        constructorName,+        constructorVars+      ),+    DatatypeInfo (datatypeCons, datatypeName, datatypeVars),+    TypeSubstitution (applySubstitution, freeVariables),+    reifyDatatype,+    resolveTypeSynonyms,+    tvName,+  )+import Language.Haskell.TH.Datatype.TyVarBndr+  ( TyVarBndrUnit,+    kindedTVSpecified,+    plainTVFlag,+    specifiedSpec,+  )+import Language.Haskell.TH.Lib (clause, conP, litE, match, stringL)+import Type.Reflection (SomeTypeRep (SomeTypeRep), TypeRep, typeRep)+import Unsafe.Coerce (unsafeCoerce)++genMergingInfoCon ::+  [TyVarBndrUnit] ->+  Name ->+  Bool ->+  ConstructorInfo ->+  Q (Con, Name, [Clause], [Clause], [Clause])+genMergingInfoCon dataTypeVars tyName isLast con = do+  let conName = mangleName $ constructorName con+  let newConName = mkName $ conName <> "MergingInfo"+  let oriVars = dataTypeVars ++ constructorVars con+  newDataTypeVars <- traverse (newName . nameBase . tvName) dataTypeVars+  newConstructorVars <-+    traverse (newName . nameBase . tvName) $ constructorVars con+  let newNames = newDataTypeVars ++ newConstructorVars+  -- newNames <- traverse (newName . nameBase . tvName) oriVars+  let newVars = fmap VarT newNames+  let substMap = M.fromList $ zip (tvName <$> oriVars) newVars+  let fields =+        zip [0 ..] $+          applySubstitution substMap $+            constructorFields con+  let tyFields =+        AppT (ConT ''TypeRep)+          <$> applySubstitution+            substMap+            ((VarT . tvName) <$> constructorVars con)+  let strategyFields = fmap (AppT (ConT ''MergingStrategy) . snd) fields+  tyFieldNamesL <- traverse (const $ newName "p") tyFields+  tyFieldNamesR <- traverse (const $ newName "p") tyFields+  let tyFieldPatsL = fmap varP tyFieldNamesL+  let tyFieldPatsR = fmap varP tyFieldNamesR+  let tyFieldVarsL = fmap varE tyFieldNamesL+  let tyFieldVarsR = fmap varE tyFieldNamesR+  let strategyFieldPats = replicate (length strategyFields) wildP+  let patsL = tyFieldPatsL ++ strategyFieldPats+  let patsR = tyFieldPatsR ++ strategyFieldPats+  let allWildcards = fmap (const wildP) $ tyFieldPatsL ++ strategyFieldPats+  let eqCont l r cont =+        [|+          SomeTypeRep $l == SomeTypeRep $r+            && $cont+          |]+  let eqExp =+        foldl (\cont (l, r) -> eqCont l r cont) (conE 'True) $+          zip tyFieldVarsL tyFieldVarsR+  eqClause <-+    clause+      [conP newConName patsL, conP newConName patsR]+      (normalB eqExp)+      []+  let cmpCont l r cont =+        [|+          case SomeTypeRep $l `compare` SomeTypeRep $r of+            EQ -> $cont+            x -> x+          |]+  let cmpExp =+        foldl (\cont (l, r) -> cmpCont l r cont) (conE 'EQ) $+          zip tyFieldVarsL tyFieldVarsR+  cmpClause0 <-+    clause+      [conP newConName patsL, conP newConName patsR]+      (normalB cmpExp)+      []+  cmpClause1 <-+    clause+      [conP newConName allWildcards, wildP]+      (normalB $ conE 'LT)+      []+  cmpClause2 <-+    clause+      [wildP, conP newConName allWildcards]+      (normalB $ conE 'GT)+      []+  let cmpClauses =+        if isLast+          then [cmpClause0]+          else [cmpClause0, cmpClause1, cmpClause2]+  let showCont t cont =+        [|$cont <> " " <> show $t|]+  let showExp = foldl (flip showCont) (litE $ stringL conName) tyFieldVarsL+  showClause <-+    clause+      [conP newConName patsL]+      (normalB showExp)+      []+  let ctx = applySubstitution substMap $ constructorContext con+  let ctxAndGadtUsedVars =+        S.fromList (freeVariables ctx)+          <> S.fromList (freeVariables tyFields)+          <> S.fromList (freeVariables strategyFields)+  let isCtxAndGadtUsedVar nm = S.member nm ctxAndGadtUsedVars+  return+    ( ForallC+        ( (`plainTVFlag` specifiedSpec)+            <$> filter isCtxAndGadtUsedVar newDataTypeVars ++ newConstructorVars+        )+        ctx+        $ GadtC+          [newConName]+          ( (Bang NoSourceUnpackedness NoSourceStrictness,)+              <$> tyFields ++ strategyFields+          )+          (ConT tyName),+      newConName,+      [eqClause],+      cmpClauses,+      [showClause]+    )++data MergingInfoResult = MergingInfoResult+  { _infoName :: Name,+    _conInfoNames :: [Name]+  }++genMergingInfo :: Name -> Q (MergingInfoResult, [Dec])+genMergingInfo typName = do+  d <- reifyDatatype typName+  let originalName = mangleName $ datatypeName d+  let newName = originalName <> "MergingInfo"+  found <- lookupTypeName newName+  let constructors = datatypeCons d+  let name = mkName newName+  r <-+    if null constructors+      then return []+      else do+        cons0 <-+          traverse (genMergingInfoCon (datatypeVars d) name False) $+            init constructors+        consLast <-+          genMergingInfoCon (datatypeVars d) name True $+            last constructors+        return $ cons0 ++ [consLast]+  let cons = fmap (\(a, _, _, _, _) -> a) r+  let eqClauses =+        concatMap (\(_, _, a, _, _) -> a) r+          ++ [ Clause [WildP, WildP] (NormalB $ ConE 'False) []+             | length constructors > 1+             ]+  let cmpClauses = concatMap (\(_, _, _, a, _) -> a) r+  let showClauses = concatMap (\(_, _, _, _, a) -> a) r+  return+    ( MergingInfoResult+        name+        (fmap (\(_, a, _, _, _) -> a) r),+      if isJust found+        then []+        else+          [ DataD [] name [] Nothing cons [],+            InstanceD+              Nothing+              []+              (ConT ''Eq `AppT` ConT name)+              [FunD '(==) eqClauses],+            InstanceD+              Nothing+              []+              (ConT ''Ord `AppT` ConT name)+              [FunD 'compare cmpClauses],+            InstanceD+              Nothing+              []+              (ConT ''Show `AppT` ConT name)+              [FunD 'show showClauses]+          ]+    )++-- | Generate 'Mergeable' instance and merging information for a data type.+genMergeableAndGetMergingInfoResult ::+  DeriveConfig -> Name -> Int -> Q (MergingInfoResult, [Dec])+genMergeableAndGetMergingInfoResult deriveConfig typName n = do+  (infoResult, infoDec) <- genMergingInfo typName+  (_, decs) <- genMergeable' deriveConfig infoResult typName n+  return (infoResult, infoDec ++ decs)++constructMergingStrategyExp :: ConstructorInfo -> [Exp] -> Q Exp+constructMergingStrategyExp _ [] = [|SimpleStrategy $ \_ t _ -> t|]+constructMergingStrategyExp conInfo [x] = do+  upname <- newName "a"+  let unwrapPat = conP (constructorName conInfo) [varP upname]+  let unwrapFun = lamE [unwrapPat] $ appE (varE 'unsafeCoerce) (varE upname)+  [|+    wrapStrategy+      $(return x)+      (unsafeCoerce . $(conE $ constructorName conInfo))+      $unwrapFun+    |]+constructMergingStrategyExp conInfo l = do+  let takeHalf l = take (length l `div` 2) l+  let dropHalf l = drop (length l `div` 2) l+  let num = length l+  upnames <- replicateM num $ newName "a"+  let wrapPat1 [] = error "Should not happen"+      wrapPat1 [x] = varP x+      wrapPat1 l = tupP [wrapPat1 (takeHalf l), wrapPat1 (dropHalf l)]+  let wrapped = foldl AppE (ConE $ constructorName conInfo) $ fmap VarE upnames+  let wrapFun =+        lamE+          [wrapPat1 (takeHalf upnames), wrapPat1 (dropHalf upnames)]+          [|unsafeCoerce ($(return wrapped))|]+  let unwrapPat = conP (constructorName conInfo) $ fmap varP upnames+  let unwrapExp1 [] = error "Should not happen"+      unwrapExp1 [x] = [|(unsafeCoerce $(varE x))|]+      unwrapExp1 l = [|($(unwrapExp1 (takeHalf l)), $(unwrapExp1 (dropHalf l)))|]+  let unwrapFun = lamE [unwrapPat] (unwrapExp1 upnames)+  let strategyx [] = error "Should not happen"+      strategyx [x] = return x+      strategyx l =+        [|product2Strategy (,) id $(strategyx (takeHalf l)) $(strategyx (dropHalf l))|]+  [|+    product2Strategy+      $wrapFun+      $unwrapFun+      $(strategyx $ takeHalf l)+      $(strategyx $ dropHalf l)+    |]++genMergeFunClause' :: Name -> ConstructorInfo -> Q Clause+genMergeFunClause' conInfoName con = do+  let numExistential = length $ constructorVars con+  let numFields = length $ constructorFields con+  let argWildCards = replicate numExistential wildP :: [Q Pat]++  pnames <- replicateM numFields $ newName "s"+  clause+    ([conP conInfoName $ argWildCards ++ fmap varP pnames])+    (normalB (constructMergingStrategyExp con (map VarE pnames)))+    []++constructVarPats :: ConstructorInfo -> Q Pat+constructVarPats conInfo = do+  let fields = constructorFields conInfo+      capture n = return $ SigP WildP $ fields !! n+  conP (constructorName conInfo) $ capture <$> [0 .. length fields - 1]++genMergingInfoFunClause' ::+  [(Type, Kind)] -> Name -> ConstructorInfo -> Q Clause+genMergingInfoFunClause' argTypes conInfoName con = do+  let conVars = constructorVars con+  capturedVarTyReps <-+    traverse (\bndr -> [|typeRep @($(varT $ tvName bndr))|]) conVars+  varPat <- constructVarPats con+  let infoExpWithTypeReps = foldl AppE (ConE conInfoName) capturedVarTyReps++  let fields = constructorFields con+  let usedArgs = S.fromList $ freeVariables fields++  strategyNames <-+    traverse+      ( \(ty, _) ->+          case ty of+            VarT nm ->+              if S.member nm usedArgs+                then do+                  pname <- newName "p"+                  return (nm, Just pname)+                else return ('undefined, Nothing)+            _ -> return ('undefined, Nothing)+      )+      argTypes+  let argToStrategyPat =+        mapMaybe (\(nm, mpat) -> fmap (nm,) mpat) strategyNames+  let strategyPats = fmap (maybe WildP VarP . snd) strategyNames++  let argNameSet =+        S.fromList $+          mapMaybe+            ( \(ty, _) -> case ty of+                VarT nm -> Just nm+                _ -> Nothing+            )+            argTypes+  let containsArg :: Type -> Bool+      containsArg ty =+        S.intersection argNameSet (S.fromList (freeVariables [ty])) /= S.empty+  let typeHasNoArg = not . containsArg++  let fieldStrategyExp ty =+        if not (containsArg ty)+          then [|rootStrategy :: MergingStrategy $(return ty)|]+          else case ty of+            _+              | typeHasNoArg ty ->+                  [|rootStrategy :: MergingStrategy $(return ty)|]+            AppT a b+              | typeHasNoArg a ->+                  [|+                    liftRootStrategy+                      $(fieldStrategyExp b) ::+                      MergingStrategy $(return ty)+                    |]+            AppT (AppT a b) c+              | typeHasNoArg a ->+                  [|+                    liftRootStrategy2+                      $(fieldStrategyExp b)+                      $(fieldStrategyExp c) ::+                      MergingStrategy $(return ty)+                    |]+            AppT (AppT (AppT a b) c) d+              | typeHasNoArg a ->+                  [|+                    liftRootStrategy3+                      $(fieldStrategyExp b)+                      $(fieldStrategyExp c)+                      $(fieldStrategyExp d) ::+                      MergingStrategy $(return ty)+                    |]+            VarT nm -> do+              case lookup nm argToStrategyPat of+                Just pname -> varE pname+                _ -> fail "BUG: fieldStrategyExp"+            _ -> fail $ "fieldStrategyExp: unsupported type: " <> show ty+  fieldStrategyExps <- traverse fieldStrategyExp fields+  let infoExp = foldl AppE infoExpWithTypeReps fieldStrategyExps+  -- fail $ show infoExp+  return $ Clause (strategyPats ++ [varPat]) (NormalB infoExp) []++mergeableFieldFunExp :: [Name] -> FieldFunExp+mergeableFieldFunExp unaryOpFunNames argToFunPat _ = go+  where+    go ty = do+      let allArgNames = M.keysSet argToFunPat+      let typeHasNoArg ty =+            S.fromList (freeVariables [ty])+              `S.intersection` allArgNames+              == S.empty+      let fun0a a = [|$(varE $ head unaryOpFunNames) @($(return a))|]+          fun1a a b = [|$(varE $ unaryOpFunNames !! 1) @($(return a)) $(go b)|]+          fun2a a b c =+            [|+              $(varE $ unaryOpFunNames !! 2)+                @($(return a))+                $(go b)+                $(go c)+              |]+          fun3a a b c d =+            [|+              $(varE $ unaryOpFunNames !! 3)+                @($(return a))+                $(go b)+                $(go c)+                $(go d)+              |]++      case ty of+        AppT (AppT (AppT a@(VarT _) b) c) d -> fun3a a b c d+        AppT (AppT a@(VarT _) b) c -> fun2a a b c+        AppT a@(VarT _) b -> fun1a a b+        _ | typeHasNoArg ty -> fun0a ty+        AppT a b | typeHasNoArg a -> fun1a a b+        AppT (AppT a b) c | typeHasNoArg a -> fun2a a b c+        AppT (AppT (AppT a b) c) d | typeHasNoArg a -> fun3a a b c d+        VarT nm -> case M.lookup nm argToFunPat of+          Just pname -> varE pname+          _ -> fail $ "defaultFieldFunExp: unsupported type: " <> show ty+        _ -> fail $ "defaultFieldFunExp: unsupported type: " <> show ty++mergeableInstanceNames :: [Name]+mergeableInstanceNames =+  [ ''Mergeable,+    ''Mergeable1,+    ''Mergeable2,+    ''Mergeable3+  ]++getMergeableInstanceName :: Int -> Name+getMergeableInstanceName n = mergeableInstanceNames !! n++rootStrategyFunNames :: [Name]+rootStrategyFunNames =+  [ 'rootStrategy,+    'liftRootStrategy,+    'liftRootStrategy2,+    'liftRootStrategy3+  ]++getMergeableFunName :: Int -> Name+getMergeableFunName n = rootStrategyFunNames !! n++mergeableNoExistentialConfig :: UnaryOpClassConfig+mergeableNoExistentialConfig =+  UnaryOpClassConfig+    { unaryOpConfigs =+        [ UnaryOpConfig+            MergeableNoExistentialConfig+              { mergeableNoExistentialFun =+                  mergeableFieldFunExp rootStrategyFunNames+              }+            rootStrategyFunNames+        ],+      unaryOpInstanceNames =+        [''Mergeable, ''Mergeable1, ''Mergeable2, ''Mergeable3],+      unaryOpExtraVars = const $ return [],+      unaryOpInstanceTypeFromConfig = defaultUnaryOpInstanceTypeFromConfig,+      unaryOpAllowExistential = False,+      unaryOpContextNames = Nothing+    }++newtype MergeableNoExistentialConfig = MergeableNoExistentialConfig+  { mergeableNoExistentialFun :: FieldFunExp+  }++instance UnaryOpFunConfig MergeableNoExistentialConfig where+  genUnaryOpFun+    _+    MergeableNoExistentialConfig {..}+    funNames+    n+    _+    _+    argTypes+    _+    constructors = do+      allFields <-+        mapM resolveTypeSynonyms $+          concatMap constructorFields constructors+      let usedArgs = S.fromList $ freeVariables allFields+      args <-+        traverse+          ( \(ty, _) -> do+              case ty of+                VarT nm ->+                  if S.member nm usedArgs+                    then do+                      pname <- newName "p"+                      return (nm, Just pname)+                    else return ('undefined, Nothing)+                _ -> return ('undefined, Nothing)+          )+          argTypes+      let argToFunPat =+            M.fromList $ mapMaybe (\(nm, mpat) -> fmap (nm,) mpat) args+      let funPats = fmap (maybe WildP VarP . snd) args+      let genAuxFunExp conInfo = do+            fields <- mapM resolveTypeSynonyms $ constructorFields conInfo+            defaultFieldFunExps <-+              traverse+                (mergeableNoExistentialFun argToFunPat M.empty)+                fields+            constructMergingStrategyExp conInfo defaultFieldFunExps+      auxExps <- mapM genAuxFunExp constructors+      funExp <- case auxExps of+        [] -> [|NoStrategy|]+        [singleExp] -> return singleExp+        _ -> do+          p <- newName "p"+          let numConstructors = length constructors+          let getIdx i =+                if numConstructors <= 2+                  then if i == 0 then [|False|] else [|True|]+                  else integerE i+          let getIdxPat i =+                if numConstructors <= 2+                  then conP (if i == 0 then 'False else 'True) []+                  else do+                    let w8Bound = fromIntegral (maxBound @Word8)+                    let w16Bound = fromIntegral (maxBound @Word16)+                    let w32Bound = fromIntegral (maxBound @Word32)+                    let w64Bound = fromIntegral (maxBound @Word64)+                    sigP+                      (litP (integerL i))+                      ( conT $+                          if+                            | numConstructors <= w8Bound + 1 -> ''Word8+                            | numConstructors <= w16Bound + 1 -> ''Word16+                            | numConstructors <= w32Bound + 1 -> ''Word32+                            | numConstructors <= w64Bound + 1 -> ''Word64+                            | otherwise -> ''Integer+                      )+          let idxFun =+                lamE [varP p] $+                  caseE+                    (varE p)+                    ( zipWith+                        ( \conIdx conInfo -> do+                            match+                              (recP (constructorName conInfo) [])+                              (normalB (getIdx conIdx))+                              []+                        )+                        [0 ..]+                        constructors+                    )+          let auxFun =+                lamE [varP p] $+                  caseE+                    (varE p)+                    ( zipWith+                        ( \conIdx exp -> do+                            match+                              (getIdxPat conIdx)+                              (normalB (return exp))+                              []+                        )+                        [0 ..]+                        auxExps+                        ++ [match wildP (normalB [|undefined|]) []]+                    )+          [|+            SortedStrategy $idxFun $auxFun+            |]+      let instanceFunName = funNames !! n+      return $+        FunD+          instanceFunName+          [ Clause+              funPats+              (NormalB funExp)+              []+          ]++-- | Generate 'Mergeable' instance for a data type, using a given merging info+-- result.+genMergeable' ::+  DeriveConfig -> MergingInfoResult -> Name -> Int -> Q (Name, [Dec])+genMergeable' deriveConfig (MergingInfoResult infoName conInfoNames) typName n = do+  result@CheckArgsResult {..} <-+    specializeResult (evalModeSpecializeList deriveConfig)+      =<< checkArgs "Mergeable" 3 typName True n++  d <- reifyDatatype typName+  let ctxForVar :: (Type, Kind) -> Q (Maybe Pred)+      ctxForVar (ty, kind) = case kind of+        StarT -> Just <$> [t|Mergeable $(return ty)|]+        AppT (AppT ArrowT StarT) StarT ->+          Just <$> [t|Mergeable1 $(return ty)|]+        AppT (AppT (AppT ArrowT StarT) StarT) StarT ->+          Just <$> [t|Mergeable2 $(return ty)|]+        AppT (AppT (AppT (AppT ArrowT StarT) StarT) StarT) StarT ->+          Just <$> [t|Mergeable3 $(return ty)|]+        AppT (AppT (AppT (AppT ArrowT StarT) StarT) StarT) _ ->+          fail $ "Unsupported kind: " <> show kind+        _ -> return Nothing+  let isTypeUsedInFields (VarT nm) = isVarUsedInFields result nm+      isTypeUsedInFields _ = False+  mergeableContexts <-+    traverse ctxForVar $+      filter (isTypeUsedInFields . fst) $+        fmap snd $+          filter (not . (`elem` unconstrainedPositions deriveConfig) . fst) $+            zip [0 ..] keptVars++  let instanceName = getMergeableInstanceName n+  let instanceHead = ConT instanceName+  extraPreds <-+    extraConstraint+      deriveConfig+      typName+      instanceName+      []+      keptVars+      constructors++  let targetType =+        foldl+          (\ty (var, _) -> AppT ty var)+          (ConT typName)+          (keptVars ++ argVars)+  let infoType = ConT infoName+  let mergingInfoFunFinalType = AppT (AppT ArrowT targetType) infoType++  let mergingInfoFunTypeWithoutCtx =+        foldr+          (((AppT . AppT ArrowT) . AppT (ConT ''MergingStrategy)) . fst)+          mergingInfoFunFinalType+          argVars++  let mergingInfoFunType =+        ForallT+          ( mapMaybe+              ( \(ty, knd) -> case ty of+                  VarT nm -> Just $ kindedTVSpecified nm knd+                  _ -> Nothing+              )+              $ keptVars ++ argVars+          )+          (extraPreds ++ catMaybes mergeableContexts)+          mergingInfoFunTypeWithoutCtx+  let mangledName = mangleName (datatypeName d)+  let mergingInfoFunName =+        mkName $+          "mergingInfo"+            <> (if n /= 0 then show n else "")+            <> mangledName+  let mergingInfoFunSigD = SigD mergingInfoFunName mergingInfoFunType+  clauses <-+    traverse (uncurry (genMergingInfoFunClause' argVars)) $+      zip conInfoNames constructors+  let mergingInfoFunDec = FunD mergingInfoFunName clauses++  let mergeFunType =+        AppT (AppT ArrowT infoType) (AppT (ConT ''MergingStrategy) targetType)+  let mergeFunName =+        mkName $+          "merge"+            <> (if n /= 0 then show n else "")+            <> mangledName+  let mergeFunSigD = SigD mergeFunName mergeFunType+  mergeFunClauses <- zipWithM genMergeFunClause' conInfoNames constructors+  let mergeFunDec = FunD mergeFunName mergeFunClauses++  let instanceType =+        AppT+          instanceHead+          (foldl AppT (ConT typName) $ fmap fst keptVars)++  let mergeInstanceFunName = getMergeableFunName n+  mergeInstanceFunPatNames <- replicateM n $ newName "rootStrategy"+  let mergeInstanceFunPats = VarP <$> mergeInstanceFunPatNames++  mergeInstanceFunBody <-+    [|+      SortedStrategy+        $( foldM+             (\exp name -> appE (return exp) $ varE name)+             (VarE mergingInfoFunName)+             mergeInstanceFunPatNames+         )+        $(varE mergeFunName)+      |]++  let mergeInstanceFunClause =+        Clause mergeInstanceFunPats (NormalB mergeInstanceFunBody) []++  return+    ( mergingInfoFunName,+      [ PragmaD (InlineP mergingInfoFunName Inline FunLike AllPhases),+        mergingInfoFunSigD,+        mergingInfoFunDec,+        PragmaD (InlineP mergeFunName Inline FunLike AllPhases),+        mergeFunSigD,+        mergeFunDec,+        InstanceD+          Nothing+          (extraPreds ++ catMaybes mergeableContexts)+          instanceType+          [FunD mergeInstanceFunName [mergeInstanceFunClause]]+      ]+    )++-- | Generate 'Mergeable' instance for a data type without existential variables.+genMergeableNoExistential :: DeriveConfig -> Name -> Int -> Q [Dec]+genMergeableNoExistential deriveConfig typName n = do+  genUnaryOpClass deriveConfig mergeableNoExistentialConfig n typName++-- | Generate 'Mergeable' instance for a data type, using 'NoStrategy'.+genMergeableNoStrategy :: DeriveConfig -> Name -> Int -> Q [Dec]+genMergeableNoStrategy deriveConfig typName n = do+  CheckArgsResult {..} <-+    specializeResult (evalModeSpecializeList deriveConfig)+      =<< checkArgs "Mergeable" 3 typName True n+  let instanceName = getMergeableInstanceName n+  let instanceHead = ConT instanceName+  let instanceType =+        AppT+          instanceHead+          (foldl AppT (ConT typName) $ fmap fst keptVars)+  let mergeInstanceFunName = getMergeableFunName n++  let mergeInstanceFunClause =+        Clause (replicate n WildP) (NormalB (ConE 'NoStrategy)) []+  return+    [ InstanceD+        Nothing+        []+        instanceType+        [FunD mergeInstanceFunName [mergeInstanceFunClause]]+    ]++-- | Generate 'Mergeable' instance for a data type.+genMergeable :: DeriveConfig -> Name -> Int -> Q [Dec]+genMergeable deriveConfig typName n = do+  hasExistential <- dataTypeHasExistential typName+  if+    | useNoStrategy deriveConfig ->+        genMergeableNoStrategy deriveConfig typName n+    | hasExistential -> do+        (infoResult, infoDec) <- genMergingInfo typName+        (_, decs) <- genMergeable' deriveConfig infoResult typName n+        return $ infoDec ++ decs+    | otherwise -> genMergeableNoExistential deriveConfig typName n++-- | Generate multiple 'Mergeable' instances for a data type.+genMergeableList :: DeriveConfig -> Name -> [Int] -> Q [Dec]+genMergeableList _ _ [] = return []+genMergeableList deriveConfig typName [n] = genMergeable deriveConfig typName n+genMergeableList deriveConfig typName l@(n : ns) = do+  hasExistential <- dataTypeHasExistential typName+  if+    | useNoStrategy deriveConfig ->+        concat <$> traverse (genMergeableNoStrategy deriveConfig typName) l+    | hasExistential -> do+        (info, dn) <-+          genMergeableAndGetMergingInfoResult+            deriveConfig+            typName+            n+        dns <-+          traverse (genMergeable' deriveConfig info typName) ns+        return $ dn ++ concatMap snd dns+    | otherwise ->+        concat <$> traverse (genMergeableNoExistential deriveConfig typName) l++-- | Derive 'Mergeable' instance for GADT.+deriveMergeable :: DeriveConfig -> Name -> Q [Dec]+deriveMergeable deriveConfig nm = genMergeable deriveConfig nm 0++-- | Derive 'Mergeable1' instance for GADT.+deriveMergeable1 :: DeriveConfig -> Name -> Q [Dec]+deriveMergeable1 deriveConfig nm = genMergeable deriveConfig nm 1++-- | Derive 'Mergeable2' instance for GADT.+deriveMergeable2 :: DeriveConfig -> Name -> Q [Dec]+deriveMergeable2 deriveConfig nm = genMergeable deriveConfig nm 2++-- | Derive 'Mergeable3' instance for GADT.+deriveMergeable3 :: DeriveConfig -> Name -> Q [Dec]+deriveMergeable3 deriveConfig nm = genMergeable deriveConfig nm 3
+ src/Grisette/Internal/TH/Derivation/DeriveNFData.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE TemplateHaskell #-}++-- |+-- Module      :   Grisette.Internal.TH.Derivation.DeriveNFData+-- 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.Derivation.DeriveNFData+  ( deriveNFData,+    deriveNFData1,+    deriveNFData2,+  )+where++import Control.DeepSeq (NFData (rnf), NFData1 (liftRnf), NFData2 (liftRnf2))+import Grisette.Internal.TH.Derivation.Common (DeriveConfig)+import Grisette.Internal.TH.Derivation.UnaryOpCommon+  ( UnaryOpClassConfig+      ( UnaryOpClassConfig,+        unaryOpAllowExistential,+        unaryOpConfigs,+        unaryOpContextNames,+        unaryOpExtraVars,+        unaryOpInstanceNames,+        unaryOpInstanceTypeFromConfig+      ),+    UnaryOpConfig (UnaryOpConfig),+    UnaryOpFieldConfig+      ( UnaryOpFieldConfig,+        extraLiftedPatNames,+        extraPatNames,+        fieldCombineFun,+        fieldFunExp,+        fieldResFun+      ),+    defaultFieldFunExp,+    defaultFieldResFun,+    defaultUnaryOpInstanceTypeFromConfig,+    genUnaryOpClass,+  )+import Language.Haskell.TH (Dec, Name)+import Language.Haskell.TH.Syntax (Q)++nfdataConfig :: UnaryOpClassConfig+nfdataConfig =+  UnaryOpClassConfig+    { unaryOpConfigs =+        [ UnaryOpConfig+            UnaryOpFieldConfig+              { extraPatNames = [],+                extraLiftedPatNames = const [],+                fieldCombineFun = \_ _ _ _ _ exps -> do+                  r <-+                    foldl+                      (\acc exp -> [|$acc `seq` $(return exp)|])+                      ([|()|])+                      exps+                  return (r, []),+                fieldResFun = defaultFieldResFun,+                fieldFunExp = defaultFieldFunExp ['rnf, 'liftRnf, 'liftRnf2]+              }+            ['rnf, 'liftRnf, 'liftRnf2]+        ],+      unaryOpInstanceNames = [''NFData, ''NFData1, ''NFData2],+      unaryOpExtraVars = const $ return [],+      unaryOpInstanceTypeFromConfig = defaultUnaryOpInstanceTypeFromConfig,+      unaryOpAllowExistential = True,+      unaryOpContextNames = Nothing+    }++-- | Derive 'NFData' instance for a data type.+deriveNFData :: DeriveConfig -> Name -> Q [Dec]+deriveNFData deriveConfig = genUnaryOpClass deriveConfig nfdataConfig 0++-- | Derive 'NFData1' instance for a data type.+deriveNFData1 :: DeriveConfig -> Name -> Q [Dec]+deriveNFData1 deriveConfig = genUnaryOpClass deriveConfig nfdataConfig 1++-- | Derive 'NFData2' instance for a data type.+deriveNFData2 :: DeriveConfig -> Name -> Q [Dec]+deriveNFData2 deriveConfig = genUnaryOpClass deriveConfig nfdataConfig 2
+ src/Grisette/Internal/TH/Derivation/DeriveOrd.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}++-- |+-- Module      :   Grisette.Internal.TH.Derivation.DeriveOrd+-- 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.Derivation.DeriveOrd+  ( deriveOrd,+    deriveOrd1,+    deriveOrd2,+  )+where++import Data.Functor.Classes (Ord1 (liftCompare), Ord2 (liftCompare2))+import Grisette.Internal.TH.Derivation.BinaryOpCommon+  ( BinaryOpClassConfig+      ( BinaryOpClassConfig,+        binaryOpAllowSumType,+        binaryOpFieldConfigs,+        binaryOpInstanceNames+      ),+    BinaryOpFieldConfig+      ( BinaryOpFieldConfig,+        extraPatNames,+        fieldCombineFun,+        fieldDifferentExistentialFun,+        fieldFunExp,+        fieldFunNames,+        fieldLMatchResult,+        fieldRMatchResult,+        fieldResFun+      ),+    binaryOpAllowExistential,+    defaultFieldFunExp,+    genBinaryOpClass,+  )+import Grisette.Internal.TH.Derivation.Common (DeriveConfig)+import Language.Haskell.TH (Dec, Exp (ListE), Name, Q)++ordConfig :: BinaryOpClassConfig+ordConfig =+  BinaryOpClassConfig+    { binaryOpFieldConfigs =+        [ BinaryOpFieldConfig+            { extraPatNames = [],+              fieldResFun = \_ (lhs, rhs) f ->+                (,[]) <$> [|$(return f) $(return lhs) $(return rhs)|],+              fieldCombineFun = \_ lst ->+                (,[]) <$> [|mconcat $(return $ ListE lst)|],+              fieldDifferentExistentialFun = return,+              fieldFunExp =+                defaultFieldFunExp ['compare, 'liftCompare, 'liftCompare2],+              fieldFunNames = ['compare, 'liftCompare, 'liftCompare2],+              fieldLMatchResult = [|LT|],+              fieldRMatchResult = [|GT|]+            }+        ],+      binaryOpInstanceNames = [''Ord, ''Ord1, ''Ord2],+      binaryOpAllowSumType = True,+      binaryOpAllowExistential = True+    }++-- | Derive 'Ord' instance for a data type.+deriveOrd :: DeriveConfig -> Name -> Q [Dec]+deriveOrd deriveConfig = genBinaryOpClass deriveConfig ordConfig 0++-- | Derive 'Ord1' instance for a data type.+deriveOrd1 :: DeriveConfig -> Name -> Q [Dec]+deriveOrd1 deriveConfig = genBinaryOpClass deriveConfig ordConfig 1++-- | Derive 'Ord2' instance for a data type.+deriveOrd2 :: DeriveConfig -> Name -> Q [Dec]+deriveOrd2 deriveConfig = genBinaryOpClass deriveConfig ordConfig 2
+ src/Grisette/Internal/TH/Derivation/DerivePPrint.hs view
@@ -0,0 +1,211 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}++-- |+-- Module      :   Grisette.Internal.TH.Derivation.DerivePPrint+-- 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.Derivation.DerivePPrint+  ( derivePPrint,+    derivePPrint1,+    derivePPrint2,+  )+where++import Data.Maybe (fromMaybe)+import Data.String (IsString (fromString))+import GHC.Show (appPrec1)+import Grisette.Internal.Internal.Decl.Core.Data.Class.PPrint+  ( PPrint (pformatList, pformatPrec),+    PPrint1 (liftPFormatList, liftPFormatPrec),+    PPrint2 (liftPFormatList2, liftPFormatPrec2),+    align,+    condEnclose,+    flatAlt,+    group,+    groupedEnclose,+    nest,+    pformatWithConstructorNoAlign,+    vcat,+    vsep,+    (<+>),+  )+import Grisette.Internal.TH.Derivation.Common (DeriveConfig)+import Grisette.Internal.TH.Derivation.ShowPPrintCommon (showPrintFieldFunExp)+import Grisette.Internal.TH.Derivation.UnaryOpCommon+  ( UnaryOpClassConfig+      ( UnaryOpClassConfig,+        unaryOpAllowExistential,+        unaryOpConfigs,+        unaryOpContextNames,+        unaryOpExtraVars,+        unaryOpInstanceNames,+        unaryOpInstanceTypeFromConfig+      ),+    UnaryOpConfig (UnaryOpConfig),+    UnaryOpFieldConfig+      ( UnaryOpFieldConfig,+        extraLiftedPatNames,+        extraPatNames,+        fieldCombineFun,+        fieldFunExp,+        fieldResFun+      ),+    defaultUnaryOpInstanceTypeFromConfig,+    genUnaryOpClass,+  )+import Grisette.Internal.TH.Util (integerE, isNonUnitTuple)+import Language.Haskell.TH+  ( Dec,+    Exp (ListE),+    Fixity (Fixity),+    Name,+    defaultFixity,+    listE,+    nameBase,+    stringE,+  )+import Language.Haskell.TH.Datatype+  ( ConstructorVariant (InfixConstructor, NormalConstructor, RecordConstructor),+    reifyFixityCompat,+  )+import Language.Haskell.TH.Syntax (Q)++pprintConfig :: UnaryOpClassConfig+pprintConfig =+  UnaryOpClassConfig+    { unaryOpConfigs =+        [ UnaryOpConfig+            UnaryOpFieldConfig+              { extraPatNames = ["prec"],+                extraLiftedPatNames = \i -> (["pl" | i /= 0]),+                fieldCombineFun = \_ _ variant conName [prec] exps -> do+                  let initExps =+                        ( \e ->+                            [|+                              $(return e)+                                <> (fromString ",")+                                <> flatAlt (fromString "") (fromString " ")+                              |]+                        )+                          <$> init exps+                      lastExp = [|$(return $ last exps)|]+                      commaSeped = initExps ++ [lastExp]+                  case (variant, exps) of+                    (NormalConstructor, []) -> do+                      r <- [|fromString $(stringE $ nameBase conName)|]+                      return (r, [False])+                    (NormalConstructor, [exp]) -> do+                      r <-+                        [|+                          pformatWithConstructorNoAlign+                            $(return prec)+                            (fromString $(stringE $ nameBase conName))+                            [$(return exp)]+                          |]+                      return (r, [True])+                    (NormalConstructor, _) | isNonUnitTuple conName -> do+                      r <-+                        [|+                          groupedEnclose (fromString "(") (fromString ")") $+                            vcat $+                              $(listE commaSeped)+                          |]+                      return (r, [False])+                    (NormalConstructor, _) -> do+                      r <-+                        [|+                          pformatWithConstructorNoAlign+                            $(return prec)+                            (fromString $(stringE $ nameBase conName))+                            [vsep $(return $ ListE exps)]+                          |]+                      return (r, [True])+                    (RecordConstructor _, _) -> do+                      r <-+                        [|+                          pformatWithConstructorNoAlign+                            $(return prec)+                            (fromString $(stringE $ nameBase conName))+                            [ groupedEnclose (fromString "{") (fromString "}") $+                                vcat $+                                  $(listE commaSeped)+                            ]+                          |]+                      return (r, [True])+                    (InfixConstructor, [l, r]) -> do+                      fi <-+                        fromMaybe defaultFixity `fmap` reifyFixityCompat conName+                      let conPrec = case fi of Fixity prec _ -> prec+                      r <-+                        [|+                          group+                            $ condEnclose+                              ($(return prec) > $(integerE conPrec))+                              (fromString "(")+                              (fromString ")")+                            $ nest 2+                            $ vsep+                              [ align $ $(return l),+                                fromString $(stringE $ nameBase conName)+                                  <+> $(return r)+                              ]+                          |]+                      return (r, [True])+                    _ ->+                      fail "derivePPrint: unexpected constructor variant",+                fieldResFun = \variant conName _ pos fieldPat fieldFun -> do+                  let makePPrintField p =+                        [|+                          $(return fieldFun)+                            $(integerE p)+                            $(return fieldPat)+                          |]+                  let attachUsedInfo = ((,[False]) <$>)+                  case variant of+                    NormalConstructor+                      | isNonUnitTuple conName ->+                          attachUsedInfo $ makePPrintField 0+                    NormalConstructor ->+                      attachUsedInfo $ makePPrintField appPrec1+                    RecordConstructor names ->+                      attachUsedInfo+                        [|+                          fromString $(stringE $ nameBase (names !! pos) ++ " = ")+                            <> $(makePPrintField 0)+                          |]+                    InfixConstructor -> do+                      fi <-+                        fromMaybe defaultFixity `fmap` reifyFixityCompat conName+                      let conPrec = case fi of Fixity prec _ -> prec+                      attachUsedInfo $ makePPrintField (conPrec + 1),+                fieldFunExp =+                  showPrintFieldFunExp+                    ['pformatPrec, 'liftPFormatPrec, 'liftPFormatPrec2]+                    ['pformatList, 'liftPFormatList, 'liftPFormatList2]+              }+            ['pformatPrec, 'liftPFormatPrec, 'liftPFormatPrec2]+        ],+      unaryOpExtraVars = const $ return [],+      unaryOpInstanceNames = [''PPrint, ''PPrint1, ''PPrint2],+      unaryOpInstanceTypeFromConfig = defaultUnaryOpInstanceTypeFromConfig,+      unaryOpAllowExistential = True,+      unaryOpContextNames = Nothing+    }++-- | Derive 'PPrint' instance for a data type.+derivePPrint :: DeriveConfig -> Name -> Q [Dec]+derivePPrint deriveConfig = genUnaryOpClass deriveConfig pprintConfig 0++-- | Derive 'PPrint1' instance for a data type.+derivePPrint1 :: DeriveConfig -> Name -> Q [Dec]+derivePPrint1 deriveConfig = genUnaryOpClass deriveConfig pprintConfig 1++-- | Derive 'PPrint2' instance for a data type.+derivePPrint2 :: DeriveConfig -> Name -> Q [Dec]+derivePPrint2 deriveConfig = genUnaryOpClass deriveConfig pprintConfig 2
+ src/Grisette/Internal/TH/Derivation/DeriveSerial.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Unused LANGUAGE pragma" #-}++-- |+-- Module      :   Grisette.Internal.TH.Derivation.DeriveSerial+-- 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.Derivation.DeriveSerial+  ( deriveSerial,+    deriveSerial1,+    deriveSerial2,+  )+where++import Data.Bytes.Serial+  ( Serial (deserialize, serialize),+    Serial1 (deserializeWith, serializeWith),+    Serial2 (deserializeWith2, serializeWith2),+  )+import Grisette.Internal.TH.Derivation.Common (DeriveConfig)+import Grisette.Internal.TH.Derivation.SerializeCommon (serializeConfig)+import Grisette.Internal.TH.Derivation.UnaryOpCommon+  ( UnaryOpClassConfig,+    genUnaryOpClass,+  )+import Language.Haskell.TH (Dec, Name, Q)++serialConfig :: UnaryOpClassConfig+serialConfig =+  serializeConfig+    [''Serial, ''Serial1, ''Serial2]+    ['serialize, 'serializeWith, 'serializeWith2]+    ['deserialize, 'deserializeWith, 'deserializeWith2]++-- | Derive 'Serial' instance for a data type.+deriveSerial :: DeriveConfig -> Name -> Q [Dec]+deriveSerial deriveConfig = genUnaryOpClass deriveConfig serialConfig 0++-- | Derive 'Serial1' instance for a data type.+deriveSerial1 :: DeriveConfig -> Name -> Q [Dec]+deriveSerial1 deriveConfig = genUnaryOpClass deriveConfig serialConfig 1++-- | Derive 'Serial2' instance for a data type.+deriveSerial2 :: DeriveConfig -> Name -> Q [Dec]+deriveSerial2 deriveConfig = genUnaryOpClass deriveConfig serialConfig 2
+ src/Grisette/Internal/TH/Derivation/DeriveShow.hs view
@@ -0,0 +1,197 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}++-- |+-- Module      :   Grisette.Internal.TH.Derivation.DeriveShow+-- 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.Derivation.DeriveShow+  ( deriveShow,+    deriveShow1,+    deriveShow2,+  )+where++import Data.Functor.Classes+  ( Show1 (liftShowList, liftShowsPrec),+    Show2 (liftShowList2, liftShowsPrec2),+  )+import qualified Data.List as List+import Data.Maybe (fromMaybe)+import GHC.Show (appPrec, appPrec1)+import Grisette.Internal.TH.Derivation.Common (DeriveConfig)+import Grisette.Internal.TH.Derivation.ShowPPrintCommon (showPrintFieldFunExp)+import Grisette.Internal.TH.Derivation.UnaryOpCommon+  ( UnaryOpClassConfig+      ( UnaryOpClassConfig,+        unaryOpAllowExistential,+        unaryOpConfigs,+        unaryOpContextNames,+        unaryOpExtraVars,+        unaryOpInstanceNames,+        unaryOpInstanceTypeFromConfig+      ),+    UnaryOpConfig (UnaryOpConfig),+    UnaryOpFieldConfig+      ( UnaryOpFieldConfig,+        extraLiftedPatNames,+        extraPatNames,+        fieldCombineFun,+        fieldFunExp,+        fieldResFun+      ),+    defaultUnaryOpInstanceTypeFromConfig,+    genUnaryOpClass,+  )+import Grisette.Internal.TH.Util (integerE, isNonUnitTuple)+import Language.Haskell.TH+  ( Dec,+    Fixity (Fixity),+    Name,+    Q,+    defaultFixity,+    integerL,+    listE,+    litE,+    nameBase,+    stringE,+  )+import Language.Haskell.TH.Datatype+  ( ConstructorVariant (InfixConstructor, NormalConstructor, RecordConstructor),+    reifyFixityCompat,+  )++showConfig :: UnaryOpClassConfig+showConfig =+  UnaryOpClassConfig+    { unaryOpConfigs =+        [ UnaryOpConfig+            UnaryOpFieldConfig+              { extraPatNames = ["prec"],+                extraLiftedPatNames = \i -> (["sl" | i /= 0]),+                fieldCombineFun =+                  \_ _ variant conName [prec] exps -> do+                    case (variant, exps) of+                      (NormalConstructor, []) -> do+                        r <- [|showString $(stringE $ nameBase conName)|]+                        return (r, [False])+                      (NormalConstructor, [exp]) -> do+                        r <-+                          [|+                            showParen+                              ($(return prec) > $(integerE appPrec))+                              ( showString $(stringE $ nameBase conName)+                                  . showChar ' '+                                  . $(return exp)+                              )+                            |]+                        return (r, [True])+                      (NormalConstructor, _) | isNonUnitTuple conName -> do+                        let commaSeped =+                              List.intersperse [|showChar ','|] $+                                return <$> exps+                        r <-+                          [|+                            showChar '('+                              . foldr1 (.) $(listE commaSeped)+                              . showChar ')'+                            |]+                        return (r, [False])+                      (NormalConstructor, _) -> do+                        let spaceSeped =+                              List.intersperse [|showChar ' '|] $+                                return <$> exps+                        r <-+                          [|+                            showParen+                              ($(return prec) > $(integerE appPrec))+                              ( showString $(stringE $ nameBase conName)+                                  . showChar ' '+                                  . (foldr1 (.) $(listE spaceSeped))+                              )+                            |]+                        return (r, [True])+                      (RecordConstructor _, _) -> do+                        let commaSpaceSeped =+                              List.intersperse [|showString ", "|] $+                                return <$> exps+                        r <-+                          [|+                            showString $(stringE $ nameBase conName)+                              . showString " {"+                              . foldr1 (.) $(listE commaSpaceSeped)+                              . showString "}"+                            |]+                        return (r, [False])+                      (InfixConstructor, [l, r]) -> do+                        fi <-+                          fromMaybe defaultFixity `fmap` reifyFixityCompat conName+                        let conPrec = case fi of Fixity prec _ -> prec+                        r <-+                          [|+                            showParen+                              ($(return prec) > $(integerE conPrec))+                              ( $(return l)+                                  . showChar ' '+                                  . showString $(stringE $ nameBase conName)+                                  . showChar ' '+                                  . $(return r)+                              )+                            |]+                        return (r, [True])+                      _ ->+                        fail "deriveShow: unexpected constructor variant",+                fieldResFun = \variant conName _ pos fieldPat fieldFun -> do+                  let makeShowField p =+                        [|+                          $(return fieldFun)+                            $(litE $ integerL $ fromIntegral p)+                            $(return fieldPat)+                          |]+                  let attachUsedInfo = ((,[False]) <$>)+                  case variant of+                    NormalConstructor+                      | isNonUnitTuple conName ->+                          attachUsedInfo $ makeShowField 0+                    NormalConstructor ->+                      attachUsedInfo $ makeShowField appPrec1+                    RecordConstructor names ->+                      attachUsedInfo+                        [|+                          showString $(stringE $ nameBase (names !! pos) ++ " = ")+                            . $(makeShowField 0)+                          |]+                    InfixConstructor -> do+                      fi <-+                        fromMaybe defaultFixity `fmap` reifyFixityCompat conName+                      let conPrec = case fi of Fixity prec _ -> prec+                      attachUsedInfo $ makeShowField (conPrec + 1),+                fieldFunExp =+                  showPrintFieldFunExp+                    ['showsPrec, 'liftShowsPrec, 'liftShowsPrec2]+                    ['showList, 'liftShowList, 'liftShowList2]+              }+            ['showsPrec, 'liftShowsPrec, 'liftShowsPrec2]+        ],+      unaryOpInstanceNames = [''Show, ''Show1, ''Show2],+      unaryOpExtraVars = const $ return [],+      unaryOpInstanceTypeFromConfig = defaultUnaryOpInstanceTypeFromConfig,+      unaryOpAllowExistential = True,+      unaryOpContextNames = Nothing+    }++-- | Derive 'Show' instance for a data type.+deriveShow :: DeriveConfig -> Name -> Q [Dec]+deriveShow deriveConfig = genUnaryOpClass deriveConfig showConfig 0++-- | Derive 'Show1' instance for a data type.+deriveShow1 :: DeriveConfig -> Name -> Q [Dec]+deriveShow1 deriveConfig = genUnaryOpClass deriveConfig showConfig 1++-- | Derive 'Show2' instance for a data type.+deriveShow2 :: DeriveConfig -> Name -> Q [Dec]+deriveShow2 deriveConfig = genUnaryOpClass deriveConfig showConfig 2
+ src/Grisette/Internal/TH/Derivation/DeriveSimpleMergeable.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}++-- |+-- Module      :   Grisette.Internal.TH.Derivation.DeriveSimpleMergeable+-- 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.Derivation.DeriveSimpleMergeable+  ( deriveSimpleMergeable,+    deriveSimpleMergeable1,+    deriveSimpleMergeable2,+  )+where++import Grisette.Internal.Internal.Decl.Core.Data.Class.SimpleMergeable+  ( SimpleMergeable (mrgIte),+    SimpleMergeable1 (liftMrgIte),+    SimpleMergeable2 (liftMrgIte2),+  )+import Grisette.Internal.TH.Derivation.BinaryOpCommon+  ( BinaryOpClassConfig+      ( BinaryOpClassConfig,+        binaryOpAllowSumType,+        binaryOpFieldConfigs,+        binaryOpInstanceNames+      ),+    BinaryOpFieldConfig+      ( BinaryOpFieldConfig,+        extraPatNames,+        fieldCombineFun,+        fieldDifferentExistentialFun,+        fieldFunExp,+        fieldFunNames,+        fieldLMatchResult,+        fieldRMatchResult,+        fieldResFun+      ),+    binaryOpAllowExistential,+    defaultFieldFunExp,+    genBinaryOpClass,+  )+import Grisette.Internal.TH.Derivation.Common (DeriveConfig)+import Language.Haskell.TH (Dec, Exp (AppE, ConE), Name, Q)++simpleMergeableConfig :: BinaryOpClassConfig+simpleMergeableConfig =+  BinaryOpClassConfig+    { binaryOpFieldConfigs =+        [ BinaryOpFieldConfig+            { extraPatNames = ["c"],+              fieldResFun = \[c] (lhs, rhs) f ->+                (,[True])+                  <$> [|$(return f) $(return c) $(return lhs) $(return rhs)|],+              fieldCombineFun =+                \con lst -> return (foldl AppE (ConE con) lst, [False]),+              fieldDifferentExistentialFun = const [|undefined|],+              fieldFunExp =+                defaultFieldFunExp ['mrgIte, 'liftMrgIte, 'liftMrgIte2],+              fieldFunNames = ['mrgIte, 'liftMrgIte, 'liftMrgIte2],+              fieldLMatchResult = [|undefined|],+              fieldRMatchResult = [|undefined|]+            }+        ],+      binaryOpInstanceNames =+        [''SimpleMergeable, ''SimpleMergeable1, ''SimpleMergeable2],+      binaryOpAllowSumType = False,+      binaryOpAllowExistential = True+    }++-- | Derive 'SimpleMergeable' instance for a data type.+deriveSimpleMergeable :: DeriveConfig -> Name -> Q [Dec]+deriveSimpleMergeable deriveConfig =+  genBinaryOpClass deriveConfig simpleMergeableConfig 0++-- | Derive 'SimpleMergeable1' instance for a data type.+deriveSimpleMergeable1 :: DeriveConfig -> Name -> Q [Dec]+deriveSimpleMergeable1 deriveConfig =+  genBinaryOpClass deriveConfig simpleMergeableConfig 1++-- | Derive 'SimpleMergeable2' instance for a data type.+deriveSimpleMergeable2 :: DeriveConfig -> Name -> Q [Dec]+deriveSimpleMergeable2 deriveConfig =+  genBinaryOpClass deriveConfig simpleMergeableConfig 2
+ src/Grisette/Internal/TH/Derivation/DeriveSubstSym.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Unused LANGUAGE pragma" #-}++-- |+-- Module      :   Grisette.Internal.TH.Derivation.DeriveSubstSym+-- 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.Derivation.DeriveSubstSym+  ( deriveSubstSym,+    deriveSubstSym1,+    deriveSubstSym2,+  )+where++import Grisette.Internal.Internal.Decl.Core.Data.Class.SubstSym+  ( SubstSym (substSym),+    SubstSym1 (liftSubstSym),+    SubstSym2 (liftSubstSym2),+  )+import Grisette.Internal.TH.Derivation.Common (DeriveConfig)+import Grisette.Internal.TH.Derivation.UnaryOpCommon+  ( UnaryOpClassConfig+      ( UnaryOpClassConfig,+        unaryOpAllowExistential,+        unaryOpConfigs,+        unaryOpContextNames,+        unaryOpExtraVars,+        unaryOpInstanceNames,+        unaryOpInstanceTypeFromConfig+      ),+    UnaryOpConfig (UnaryOpConfig),+    UnaryOpFieldConfig+      ( UnaryOpFieldConfig,+        extraLiftedPatNames,+        extraPatNames,+        fieldCombineFun,+        fieldFunExp,+        fieldResFun+      ),+    defaultFieldFunExp,+    defaultFieldResFun,+    defaultUnaryOpInstanceTypeFromConfig,+    genUnaryOpClass,+  )+import Language.Haskell.TH (Dec, Exp (AppE, ConE), Name)+import Language.Haskell.TH.Syntax (Q)++substSymConfig :: UnaryOpClassConfig+substSymConfig =+  UnaryOpClassConfig+    { unaryOpConfigs =+        [ UnaryOpConfig+            UnaryOpFieldConfig+              { extraPatNames = ["symbol", "newVal"],+                extraLiftedPatNames = const [],+                fieldResFun = defaultFieldResFun,+                fieldCombineFun = \_ _ _ con extraPat exp ->+                  return (foldl AppE (ConE con) exp, False <$ extraPat),+                fieldFunExp =+                  defaultFieldFunExp+                    ['substSym, 'liftSubstSym, 'liftSubstSym2]+              }+            ['substSym, 'liftSubstSym, 'liftSubstSym2]+        ],+      unaryOpInstanceNames =+        [''SubstSym, ''SubstSym1, ''SubstSym2],+      unaryOpExtraVars = const $ return [],+      unaryOpInstanceTypeFromConfig = defaultUnaryOpInstanceTypeFromConfig,+      unaryOpAllowExistential = True,+      unaryOpContextNames = Nothing+    }++-- | Derive 'SubstSym' instance for a data type.+deriveSubstSym :: DeriveConfig -> Name -> Q [Dec]+deriveSubstSym deriveConfig = genUnaryOpClass deriveConfig substSymConfig 0++-- | Derive 'SubstSym1' instance for a data type.+deriveSubstSym1 :: DeriveConfig -> Name -> Q [Dec]+deriveSubstSym1 deriveConfig = genUnaryOpClass deriveConfig substSymConfig 1++-- | Derive 'SubstSym2' instance for a data type.+deriveSubstSym2 :: DeriveConfig -> Name -> Q [Dec]+deriveSubstSym2 deriveConfig = genUnaryOpClass deriveConfig substSymConfig 2
+ src/Grisette/Internal/TH/Derivation/DeriveSymEq.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}++-- |+-- Module      :   Grisette.Internal.TH.Derivation.DeriveSymEq+-- 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.Derivation.DeriveSymEq+  ( deriveSymEq,+    deriveSymEq1,+    deriveSymEq2,+  )+where++import Grisette.Internal.Core.Data.Class.LogicalOp+  ( LogicalOp (false, true, (.&&)),+  )+import Grisette.Internal.Internal.Decl.Core.Data.Class.SymEq+  ( SymEq ((.==)),+    SymEq1 (liftSymEq),+    SymEq2 (liftSymEq2),+  )+import Grisette.Internal.TH.Derivation.BinaryOpCommon+  ( BinaryOpClassConfig+      ( BinaryOpClassConfig,+        binaryOpAllowSumType,+        binaryOpFieldConfigs,+        binaryOpInstanceNames+      ),+    BinaryOpFieldConfig+      ( BinaryOpFieldConfig,+        extraPatNames,+        fieldCombineFun,+        fieldDifferentExistentialFun,+        fieldFunExp,+        fieldFunNames,+        fieldLMatchResult,+        fieldRMatchResult,+        fieldResFun+      ),+    binaryOpAllowExistential,+    defaultFieldFunExp,+    genBinaryOpClass,+  )+import Grisette.Internal.TH.Derivation.Common (DeriveConfig)+import Language.Haskell.TH (Dec, Exp (ListE), Name, Q)++symEqConfig :: BinaryOpClassConfig+symEqConfig =+  BinaryOpClassConfig+    { binaryOpFieldConfigs =+        [ BinaryOpFieldConfig+            { extraPatNames = [],+              fieldResFun = \_ (lhs, rhs) f ->+                (,[]) <$> [|$(return f) $(return lhs) $(return rhs)|],+              fieldCombineFun =+                \_ lst -> (,[]) <$> [|foldl (.&&) true $(return $ ListE lst)|],+              fieldDifferentExistentialFun = const [|false|],+              fieldFunExp =+                defaultFieldFunExp ['(.==), 'liftSymEq, 'liftSymEq2],+              fieldFunNames = ['(.==), 'liftSymEq, 'liftSymEq2],+              fieldLMatchResult = [|false|],+              fieldRMatchResult = [|false|]+            }+        ],+      binaryOpInstanceNames = [''SymEq, ''SymEq1, ''SymEq2],+      binaryOpAllowSumType = True,+      binaryOpAllowExistential = True+    }++-- | Derive 'SymEq' instance for a data type.+deriveSymEq :: DeriveConfig -> Name -> Q [Dec]+deriveSymEq deriveConfig = genBinaryOpClass deriveConfig symEqConfig 0++-- | Derive 'SymEq1' instance for a data type.+deriveSymEq1 :: DeriveConfig -> Name -> Q [Dec]+deriveSymEq1 deriveConfig = genBinaryOpClass deriveConfig symEqConfig 1++-- | Derive 'SymEq2' instance for a data type.+deriveSymEq2 :: DeriveConfig -> Name -> Q [Dec]+deriveSymEq2 deriveConfig = genBinaryOpClass deriveConfig symEqConfig 2
+ src/Grisette/Internal/TH/Derivation/DeriveSymOrd.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}++-- |+-- Module      :   Grisette.Internal.TH.Derivation.DeriveSymOrd+-- 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.Derivation.DeriveSymOrd+  ( deriveSymOrd,+    deriveSymOrd1,+    deriveSymOrd2,+  )+where++import Grisette.Internal.Internal.Decl.Core.Data.Class.SymOrd+  ( SymOrd (symCompare),+    SymOrd1 (liftSymCompare),+    SymOrd2 (liftSymCompare2),+  )+import Grisette.Internal.Internal.Decl.Core.Data.Class.TryMerge+  ( mrgSingle,+  )+import Grisette.Internal.TH.Derivation.BinaryOpCommon+  ( BinaryOpClassConfig+      ( BinaryOpClassConfig,+        binaryOpAllowSumType,+        binaryOpFieldConfigs,+        binaryOpInstanceNames+      ),+    BinaryOpFieldConfig+      ( BinaryOpFieldConfig,+        extraPatNames,+        fieldCombineFun,+        fieldDifferentExistentialFun,+        fieldFunExp,+        fieldFunNames,+        fieldLMatchResult,+        fieldRMatchResult,+        fieldResFun+      ),+    binaryOpAllowExistential,+    defaultFieldFunExp,+    genBinaryOpClass,+  )+import Grisette.Internal.TH.Derivation.Common (DeriveConfig)+import Language.Haskell.TH (Dec, Name, Q)++symOrdConfig :: BinaryOpClassConfig+symOrdConfig =+  BinaryOpClassConfig+    { binaryOpFieldConfigs =+        [ BinaryOpFieldConfig+            { extraPatNames = [],+              fieldResFun =+                \_ (lhs, rhs) f ->+                  (,[]) <$> [|$(return f) $(return lhs) $(return rhs)|],+              fieldCombineFun =+                \_ lst -> do+                  let go [] = [|mrgSingle EQ|]+                      go [x] = [|$(return x)|]+                      go (x : xs) =+                        [|+                          do+                            a <- $(return x)+                            case a of+                              EQ -> $(go xs)+                              _ -> mrgSingle a+                          |]+                  (,[]) <$> go lst,+              fieldDifferentExistentialFun =+                \exp -> [|mrgSingle $(return exp)|],+              fieldFunExp =+                defaultFieldFunExp+                  ['symCompare, 'liftSymCompare, 'liftSymCompare2],+              fieldFunNames = ['symCompare, 'liftSymCompare, 'liftSymCompare2],+              fieldLMatchResult = [|mrgSingle LT|],+              fieldRMatchResult = [|mrgSingle GT|]+            }+        ],+      binaryOpInstanceNames = [''SymOrd, ''SymOrd1, ''SymOrd2],+      binaryOpAllowSumType = True,+      binaryOpAllowExistential = True+    }++-- | Derive 'SymOrd' instance for a data type.+deriveSymOrd :: DeriveConfig -> Name -> Q [Dec]+deriveSymOrd deriveConfig = genBinaryOpClass deriveConfig symOrdConfig 0++-- | Derive 'SymOrd1' instance for a data type.+deriveSymOrd1 :: DeriveConfig -> Name -> Q [Dec]+deriveSymOrd1 deriveConfig = genBinaryOpClass deriveConfig symOrdConfig 1++-- | Derive 'SymOrd2' instance for a data type.+deriveSymOrd2 :: DeriveConfig -> Name -> Q [Dec]+deriveSymOrd2 deriveConfig = genBinaryOpClass deriveConfig symOrdConfig 2
+ src/Grisette/Internal/TH/Derivation/DeriveToCon.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE TemplateHaskell #-}++-- |+-- Module      :   Grisette.Internal.TH.Derivation.DeriveToCon+-- 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.Derivation.DeriveToCon+  ( deriveToCon,+    deriveToCon1,+    deriveToCon2,+  )+where++import Grisette.Internal.Internal.Decl.Core.Data.Class.ToCon+  ( ToCon (toCon),+    ToCon1 (liftToCon),+    ToCon2 (liftToCon2),+  )+import Grisette.Internal.TH.Derivation.Common (DeriveConfig)+import Grisette.Internal.TH.Derivation.ConvertOpCommon+  ( ConvertOpClassConfig+      ( ConvertOpClassConfig,+        convertFieldCombineFun,+        convertFieldFunExp,+        convertFieldResFun,+        convertOpFunNames,+        convertOpInstanceNames,+        convertOpTarget+      ),+    defaultFieldFunExp,+    genConvertOpClass,+  )+import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C))+import Language.Haskell.TH (Dec, Name, Q, conE)++toConClassConfig :: ConvertOpClassConfig+toConClassConfig =+  ConvertOpClassConfig+    { convertFieldResFun = \v f -> [|$(return f) $(return v)|],+      convertFieldCombineFun = \f args ->+        foldl+          (\acc arg -> [|$(acc) <*> $arg|])+          [|return $(conE f)|]+          $ fmap return args,+      convertFieldFunExp = defaultFieldFunExp ['toCon, 'liftToCon, 'liftToCon2],+      convertOpTarget = C,+      convertOpInstanceNames = [''ToCon, ''ToCon1, ''ToCon2],+      convertOpFunNames = ['toCon, 'liftToCon, 'liftToCon2]+    }++-- | Derive 'ToCon' instance for a data type.+deriveToCon :: DeriveConfig -> Name -> Q [Dec]+deriveToCon deriveConfig = genConvertOpClass deriveConfig toConClassConfig 0++-- | Derive 'ToCon1' instance for a data type.+deriveToCon1 :: DeriveConfig -> Name -> Q [Dec]+deriveToCon1 deriveConfig =+  genConvertOpClass deriveConfig toConClassConfig 1++-- | Derive 'ToCon2' instance for a data type.+deriveToCon2 :: DeriveConfig -> Name -> Q [Dec]+deriveToCon2 deriveConfig =+  genConvertOpClass deriveConfig toConClassConfig 2
+ src/Grisette/Internal/TH/Derivation/DeriveToSym.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Unused LANGUAGE pragma" #-}++-- |+-- Module      :   Grisette.Internal.TH.Derivation.DeriveToSym+-- 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.Derivation.DeriveToSym+  ( deriveToSym,+    deriveToSym1,+    deriveToSym2,+  )+where++import Grisette.Internal.Internal.Decl.Core.Data.Class.ToSym+  ( ToSym (toSym),+    ToSym1 (liftToSym),+    ToSym2 (liftToSym2),+  )+import Grisette.Internal.TH.Derivation.Common (DeriveConfig)+import Grisette.Internal.TH.Derivation.ConvertOpCommon+  ( ConvertOpClassConfig+      ( ConvertOpClassConfig,+        convertFieldCombineFun,+        convertFieldFunExp,+        convertFieldResFun,+        convertOpInstanceNames,+        convertOpTarget+      ),+    convertOpFunNames,+    defaultFieldFunExp,+    genConvertOpClass,+  )+import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (S))+import Language.Haskell.TH (Dec, Name, Q, appE, conE)++toSymClassConfig :: ConvertOpClassConfig+toSymClassConfig =+  ConvertOpClassConfig+    { convertFieldResFun = \v f -> [|$(return f) $(return v)|],+      convertFieldCombineFun =+        \f args -> foldl appE (conE f) $ fmap return args,+      convertFieldFunExp = defaultFieldFunExp ['toSym, 'liftToSym, 'liftToSym2],+      convertOpTarget = S,+      convertOpInstanceNames = [''ToSym, ''ToSym1, ''ToSym2],+      convertOpFunNames = ['toSym, 'liftToSym, 'liftToSym2]+    }++-- | Derive 'ToSym' instance for a data type.+deriveToSym :: DeriveConfig -> Name -> Q [Dec]+deriveToSym deriveConfig = genConvertOpClass deriveConfig toSymClassConfig 0++-- | Derive 'ToSym1' instance for a data type.+deriveToSym1 :: DeriveConfig -> Name -> Q [Dec]+deriveToSym1 deriveConfig =+  genConvertOpClass deriveConfig toSymClassConfig 1++-- | Derive 'ToSym2' instance for a data type.+deriveToSym2 :: DeriveConfig -> Name -> Q [Dec]+deriveToSym2 deriveConfig =+  genConvertOpClass deriveConfig toSymClassConfig 2
+ src/Grisette/Internal/TH/Derivation/DeriveUnifiedSimpleMergeable.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Unused LANGUAGE pragma" #-}++-- |+-- Module      :   Grisette.Internal.TH.Derivation.DeriveUnifiedSimpleMergeable+-- 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.Derivation.DeriveUnifiedSimpleMergeable+  ( deriveUnifiedSimpleMergeable,+    deriveUnifiedSimpleMergeable1,+    deriveUnifiedSimpleMergeable2,+  )+where++import Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSimpleMergeable+  ( UnifiedSimpleMergeable (withBaseSimpleMergeable),+    UnifiedSimpleMergeable1 (withBaseSimpleMergeable1),+    UnifiedSimpleMergeable2 (withBaseSimpleMergeable2),+  )+import Grisette.Internal.TH.Derivation.Common (DeriveConfig (evalModeConfig))+import Grisette.Internal.TH.Derivation.UnaryOpCommon+  ( UnaryOpClassConfig+      ( UnaryOpClassConfig,+        unaryOpAllowExistential,+        unaryOpConfigs,+        unaryOpContextNames,+        unaryOpExtraVars,+        unaryOpInstanceNames,+        unaryOpInstanceTypeFromConfig+      ),+    UnaryOpConfig (UnaryOpConfig),+    genUnaryOpClass,+  )+import Grisette.Internal.TH.Derivation.UnifiedOpCommon+  ( UnaryOpUnifiedConfig (UnaryOpUnifiedConfig, unifiedFun),+    defaultUnaryOpUnifiedFun,+  )+import Grisette.Internal.Unified.EvalModeTag (EvalModeTag)+import Language.Haskell.TH+  ( Dec,+    Name,+    Q,+    Type (ConT, VarT),+    appT,+    conT,+    newName,+  )++unifiedSimpleMergeableConfig :: UnaryOpClassConfig+unifiedSimpleMergeableConfig =+  UnaryOpClassConfig+    { unaryOpConfigs =+        [ UnaryOpConfig+            UnaryOpUnifiedConfig+              { unifiedFun =+                  defaultUnaryOpUnifiedFun+                    [ 'withBaseSimpleMergeable,+                      'withBaseSimpleMergeable1,+                      'withBaseSimpleMergeable2+                    ]+              }+            [ 'withBaseSimpleMergeable,+              'withBaseSimpleMergeable1,+              'withBaseSimpleMergeable2+            ]+        ],+      unaryOpInstanceNames =+        [ ''UnifiedSimpleMergeable,+          ''UnifiedSimpleMergeable1,+          ''UnifiedSimpleMergeable2+        ],+      unaryOpExtraVars = \config -> do+        let modeConfigs = evalModeConfig config+        case modeConfigs of+          [] -> do+            nm <- newName "mode"+            return [(VarT nm, ConT ''EvalModeTag)]+          [_] -> return []+          _ -> fail "UnifiedSimpleMergeable does not support multiple evaluation modes",+      unaryOpInstanceTypeFromConfig =+        \config newModeVars keptNewVars con -> do+          let modeConfigs = evalModeConfig config+          modeVar <- case modeConfigs of+            [] -> return $ head newModeVars+            [(i, _)] -> do+              if i >= length keptNewVars+                then fail "UnifiedSimpleMergeable reference to a non-existent mode variable"+                else return $ keptNewVars !! i+            _ -> fail "UnifiedSimpleMergeable does not support multiple evaluation modes"+          appT (conT con) (return $ fst modeVar),+      unaryOpAllowExistential = True,+      unaryOpContextNames = Nothing+    }++-- | Derive 'UnifiedSimpleMergeable' instance for a data type.+deriveUnifiedSimpleMergeable :: DeriveConfig -> Name -> Q [Dec]+deriveUnifiedSimpleMergeable deriveConfig =+  genUnaryOpClass deriveConfig unifiedSimpleMergeableConfig 0++-- | Derive 'UnifiedSimpleMergeable1' instance for a data type.+deriveUnifiedSimpleMergeable1 :: DeriveConfig -> Name -> Q [Dec]+deriveUnifiedSimpleMergeable1 deriveConfig =+  genUnaryOpClass deriveConfig unifiedSimpleMergeableConfig 1++-- | Derive 'UnifiedSimpleMergeable2' instance for a data type.+deriveUnifiedSimpleMergeable2 :: DeriveConfig -> Name -> Q [Dec]+deriveUnifiedSimpleMergeable2 deriveConfig =+  genUnaryOpClass deriveConfig unifiedSimpleMergeableConfig 2
+ src/Grisette/Internal/TH/Derivation/DeriveUnifiedSymEq.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Unused LANGUAGE pragma" #-}++-- |+-- Module      :   Grisette.Internal.TH.Derivation.DeriveUnifiedSymEq+-- 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.Derivation.DeriveUnifiedSymEq+  ( deriveUnifiedSymEq,+    deriveUnifiedSymEq1,+    deriveUnifiedSymEq2,+  )+where++import Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSymEq+  ( UnifiedSymEq (withBaseSymEq),+    UnifiedSymEq1 (withBaseSymEq1),+    UnifiedSymEq2 (withBaseSymEq2),+  )+import Grisette.Internal.TH.Derivation.Common (DeriveConfig (evalModeConfig))+import Grisette.Internal.TH.Derivation.UnaryOpCommon+  ( UnaryOpClassConfig+      ( UnaryOpClassConfig,+        unaryOpAllowExistential,+        unaryOpConfigs,+        unaryOpContextNames,+        unaryOpExtraVars,+        unaryOpInstanceNames,+        unaryOpInstanceTypeFromConfig+      ),+    UnaryOpConfig (UnaryOpConfig),+    genUnaryOpClass,+  )+import Grisette.Internal.TH.Derivation.UnifiedOpCommon+  ( UnaryOpUnifiedConfig (UnaryOpUnifiedConfig, unifiedFun),+    defaultUnaryOpUnifiedFun,+  )+import Grisette.Internal.Unified.EvalModeTag (EvalModeTag)+import Language.Haskell.TH+  ( Dec,+    Name,+    Q,+    Type (ConT, VarT),+    appT,+    conT,+    newName,+  )++unifiedSymEqConfig :: UnaryOpClassConfig+unifiedSymEqConfig =+  UnaryOpClassConfig+    { unaryOpConfigs =+        [ UnaryOpConfig+            UnaryOpUnifiedConfig+              { unifiedFun =+                  defaultUnaryOpUnifiedFun+                    ['withBaseSymEq, 'withBaseSymEq1, 'withBaseSymEq2]+              }+            ['withBaseSymEq, 'withBaseSymEq1, 'withBaseSymEq2]+        ],+      unaryOpInstanceNames = [''UnifiedSymEq, ''UnifiedSymEq1, ''UnifiedSymEq2],+      unaryOpExtraVars = \config -> do+        let modeConfigs = evalModeConfig config+        case modeConfigs of+          [] -> do+            nm <- newName "mode"+            return [(VarT nm, ConT ''EvalModeTag)]+          [_] -> return []+          _ -> fail "UnifiedSymEq does not support multiple evaluation modes",+      unaryOpInstanceTypeFromConfig =+        \config newModeVars keptNewVars con -> do+          let modeConfigs = evalModeConfig config+          modeVar <- case modeConfigs of+            [] -> return $ head newModeVars+            [(i, _)] -> do+              if i >= length keptNewVars+                then fail "UnifiedSymEq reference to a non-existent mode variable"+                else return $ keptNewVars !! i+            _ -> fail "UnifiedSymEq does not support multiple evaluation modes"+          appT (conT con) (return $ fst modeVar),+      unaryOpAllowExistential = True,+      unaryOpContextNames = Nothing+    }++-- | Derive 'UnifiedSymEq' instance for a data type.+deriveUnifiedSymEq :: DeriveConfig -> Name -> Q [Dec]+deriveUnifiedSymEq deriveConfig =+  genUnaryOpClass deriveConfig unifiedSymEqConfig 0++-- | Derive 'UnifiedSymEq1' instance for a data type.+deriveUnifiedSymEq1 :: DeriveConfig -> Name -> Q [Dec]+deriveUnifiedSymEq1 deriveConfig =+  genUnaryOpClass deriveConfig unifiedSymEqConfig 1++-- | Derive 'UnifiedSymEq2' instance for a data type.+deriveUnifiedSymEq2 :: DeriveConfig -> Name -> Q [Dec]+deriveUnifiedSymEq2 deriveConfig =+  genUnaryOpClass deriveConfig unifiedSymEqConfig 2
+ src/Grisette/Internal/TH/Derivation/DeriveUnifiedSymOrd.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Unused LANGUAGE pragma" #-}++-- |+-- Module      :   Grisette.Internal.TH.Derivation.DeriveUnifiedSymOrd+-- 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.Derivation.DeriveUnifiedSymOrd+  ( deriveUnifiedSymOrd,+    deriveUnifiedSymOrd1,+    deriveUnifiedSymOrd2,+  )+where++import Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSymOrd+  ( UnifiedSymOrd (withBaseSymOrd),+    UnifiedSymOrd1 (withBaseSymOrd1),+    UnifiedSymOrd2 (withBaseSymOrd2),+  )+import Grisette.Internal.TH.Derivation.Common (DeriveConfig (evalModeConfig))+import Grisette.Internal.TH.Derivation.UnaryOpCommon+  ( UnaryOpClassConfig+      ( UnaryOpClassConfig,+        unaryOpAllowExistential,+        unaryOpConfigs,+        unaryOpContextNames,+        unaryOpExtraVars,+        unaryOpInstanceNames,+        unaryOpInstanceTypeFromConfig+      ),+    UnaryOpConfig (UnaryOpConfig),+    genUnaryOpClass,+  )+import Grisette.Internal.TH.Derivation.UnifiedOpCommon+  ( UnaryOpUnifiedConfig (UnaryOpUnifiedConfig, unifiedFun),+    defaultUnaryOpUnifiedFun,+  )+import Grisette.Internal.Unified.EvalModeTag (EvalModeTag)+import Language.Haskell.TH+  ( Dec,+    Name,+    Q,+    Type (ConT, VarT),+    appT,+    conT,+    newName,+  )++unifiedSymOrdConfig :: UnaryOpClassConfig+unifiedSymOrdConfig =+  UnaryOpClassConfig+    { unaryOpConfigs =+        [ UnaryOpConfig+            UnaryOpUnifiedConfig+              { unifiedFun =+                  defaultUnaryOpUnifiedFun+                    ['withBaseSymOrd, 'withBaseSymOrd1, 'withBaseSymOrd2]+              }+            ['withBaseSymOrd, 'withBaseSymOrd1, 'withBaseSymOrd2]+        ],+      unaryOpInstanceNames = [''UnifiedSymOrd, ''UnifiedSymOrd1, ''UnifiedSymOrd2],+      unaryOpExtraVars = \config -> do+        let modeConfigs = evalModeConfig config+        case modeConfigs of+          [] -> do+            nm <- newName "mode"+            return [(VarT nm, ConT ''EvalModeTag)]+          [_] -> return []+          _ -> fail "UnifiedSymOrd does not support multiple evaluation modes",+      unaryOpInstanceTypeFromConfig =+        \config newModeVars keptNewVars con -> do+          let modeConfigs = evalModeConfig config+          modeVar <- case modeConfigs of+            [] -> return $ head newModeVars+            [(i, _)] -> do+              if i >= length keptNewVars+                then fail "UnifiedSymOrd reference to a non-existent mode variable"+                else return $ keptNewVars !! i+            _ -> fail "UnifiedSymOrd does not support multiple evaluation modes"+          appT (conT con) (return $ fst modeVar),+      unaryOpAllowExistential = True,+      unaryOpContextNames = Nothing+    }++-- | Derive 'UnifiedSymOrd' instance for a data type.+deriveUnifiedSymOrd :: DeriveConfig -> Name -> Q [Dec]+deriveUnifiedSymOrd deriveConfig =+  genUnaryOpClass deriveConfig unifiedSymOrdConfig 0++-- | Derive 'UnifiedSymOrd1' instance for a data type.+deriveUnifiedSymOrd1 :: DeriveConfig -> Name -> Q [Dec]+deriveUnifiedSymOrd1 deriveConfig =+  genUnaryOpClass deriveConfig unifiedSymOrdConfig 1++-- | Derive 'UnifiedSymOrd2' instance for a data type.+deriveUnifiedSymOrd2 :: DeriveConfig -> Name -> Q [Dec]+deriveUnifiedSymOrd2 deriveConfig =+  genUnaryOpClass deriveConfig unifiedSymOrdConfig 2
+ src/Grisette/Internal/TH/Derivation/SerializeCommon.hs view
@@ -0,0 +1,243 @@+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}++-- |+-- Module      :   Grisette.Internal.TH.Derivation.SerializeCommon+-- 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.Derivation.SerializeCommon+  ( serializeConfig,+    serializeWithSerialConfig,+  )+where++import Control.Monad (zipWithM)+import Data.Bytes.Serial (Serial (deserialize, serialize), Serial1, Serial2)+import qualified Data.Map as M+import Data.Maybe (mapMaybe)+import qualified Data.Set as S+import GHC.Word (Word16, Word32, Word64, Word8)+import Grisette.Internal.TH.Derivation.UnaryOpCommon+  ( UnaryOpClassConfig+      ( UnaryOpClassConfig,+        unaryOpAllowExistential,+        unaryOpConfigs,+        unaryOpContextNames,+        unaryOpExtraVars,+        unaryOpInstanceNames,+        unaryOpInstanceTypeFromConfig+      ),+    UnaryOpConfig (UnaryOpConfig),+    UnaryOpFieldConfig+      ( UnaryOpFieldConfig,+        extraLiftedPatNames,+        extraPatNames,+        fieldCombineFun,+        fieldFunExp,+        fieldResFun+      ),+    UnaryOpFunConfig (genUnaryOpFun),+    defaultFieldFunExp,+    defaultUnaryOpInstanceTypeFromConfig,+  )+import Grisette.Internal.TH.Util (integerE)+import Language.Haskell.TH+  ( Body (NormalB),+    Clause (Clause),+    Dec (FunD),+    Lit (IntegerL),+    Match (Match),+    Name,+    Pat (LitP, VarP, WildP),+    Type (VarT),+    bindS,+    caseE,+    clause,+    conE,+    conT,+    doE,+    funD,+    match,+    mkName,+    newName,+    noBindS,+    normalB,+    sigP,+    varE,+    varP,+    wildP,+  )+import Language.Haskell.TH.Datatype+  ( ConstructorInfo (constructorFields, constructorName),+    TypeSubstitution (freeVariables),+    resolveTypeSynonyms,+  )++data UnaryOpSerializeWithSerialConfig = UnaryOpSerializeWithSerialConfig++instance UnaryOpFunConfig UnaryOpSerializeWithSerialConfig where+  genUnaryOpFun _ UnaryOpSerializeWithSerialConfig funNames n _ _ _ _ _ =+    funD (funNames !! n) [clause [] (normalB [|serialize|]) []]++data UnaryOpDeserializeWithSerialConfig = UnaryOpDeserializeWithSerialConfig++instance UnaryOpFunConfig UnaryOpDeserializeWithSerialConfig where+  genUnaryOpFun _ UnaryOpDeserializeWithSerialConfig funNames n _ _ _ _ _ =+    funD (funNames !! n) [clause [] (normalB [|deserialize|]) []]++-- | Configuration for deserialization function, generate the function from+-- scratch.+data UnaryOpDeserializeConfig = UnaryOpDeserializeConfig++getSerializedType :: Int -> Name+getSerializedType numConstructors =+  if+    | numConstructors <= fromIntegral (maxBound @Word8) + 1 -> ''Word8+    | numConstructors <= fromIntegral (maxBound @Word16) + 1 -> ''Word16+    | numConstructors <= fromIntegral (maxBound @Word32) + 1 -> ''Word32+    | numConstructors <= fromIntegral (maxBound @Word64) + 1 -> ''Word64+    | otherwise -> ''Integer++instance UnaryOpFunConfig UnaryOpDeserializeConfig where+  genUnaryOpFun _ UnaryOpDeserializeConfig funNames n _ _ _ _ [] = do+    let instanceFunName = funNames !! n+    funD+      instanceFunName+      [ clause+          []+          (normalB [|error "deserializing a type without constructors"|])+          []+      ]+  genUnaryOpFun+    _+    UnaryOpDeserializeConfig+    funNames+    n+    _+    _+    argTypes+    _+    constructors = do+      allFields <-+        mapM resolveTypeSynonyms $+          concatMap constructorFields constructors+      let usedArgs = S.fromList $ freeVariables allFields+      args <-+        traverse+          ( \(ty, _) -> do+              case ty of+                VarT nm ->+                  if S.member nm usedArgs+                    then do+                      pname <- newName "p"+                      return (nm, Just pname)+                    else return ('undefined, Nothing)+                _ -> return ('undefined, Nothing)+          )+          argTypes+      let argToFunPat =+            M.fromList $ mapMaybe (\(nm, mpat) -> fmap (nm,) mpat) args+      let funPats = fmap (maybe WildP VarP . snd) args+      let genAuxFunMatch conIdx conInfo = do+            fields <- mapM resolveTypeSynonyms $ constructorFields conInfo+            defaultFieldFunExps <-+              traverse+                ( defaultFieldFunExp+                    funNames+                    argToFunPat+                    M.empty+                )+                fields+            let conName = constructorName conInfo+            exp <-+              foldl+                (\exp fieldFun -> [|$exp <*> $(return fieldFun)|])+                [|return $(conE conName)|]+                defaultFieldFunExps+            return $ Match (LitP (IntegerL conIdx)) (NormalB exp) []+      auxMatches <- zipWithM genAuxFunMatch [0 ..] constructors+      auxFallbackMatch <- match wildP (normalB [|undefined|]) []+      let instanceFunName = funNames !! n+      -- let auxFunName = mkName "go"+      let selName = mkName "sel"+      exp <-+        doE+          [ bindS+              ( sigP+                  (varP selName)+                  (conT (getSerializedType $ length constructors))+              )+              (varE (head funNames)),+            noBindS $+              caseE (varE selName) $+                return <$> auxMatches ++ [auxFallbackMatch]+          ]+      return $+        FunD+          instanceFunName+          [ Clause+              funPats+              (NormalB exp)+              []+          ]++-- | Configuration for serialization function, generate the function from+-- scratch.+serializeConfig :: [Name] -> [Name] -> [Name] -> UnaryOpClassConfig+serializeConfig instanceNames serializeFunNames deserializeFunNames =+  UnaryOpClassConfig+    { unaryOpConfigs =+        [ UnaryOpConfig+            UnaryOpFieldConfig+              { extraPatNames = [],+                extraLiftedPatNames = const [],+                fieldCombineFun = \totalConNumber conIdx _ _ [] exp -> do+                  let ty = getSerializedType totalConNumber+                  r <-+                    foldl+                      (\r exp -> [|$r >> $(return exp)|])+                      ( [|+                          $(varE $ head serializeFunNames)+                            ($(integerE conIdx) :: $(conT ty))+                          |]+                      )+                      exp+                  return (r, [True]),+                fieldResFun = \_ _ _ _ fieldPat fieldFun -> do+                  r <- [|$(return fieldFun) $(return fieldPat)|]+                  return (r, [True]),+                fieldFunExp = defaultFieldFunExp serializeFunNames+              }+            serializeFunNames,+          UnaryOpConfig+            UnaryOpDeserializeConfig+            deserializeFunNames+        ],+      unaryOpInstanceNames = instanceNames,+      unaryOpExtraVars = const $ return [],+      unaryOpInstanceTypeFromConfig = defaultUnaryOpInstanceTypeFromConfig,+      unaryOpAllowExistential = False,+      unaryOpContextNames = Nothing+    }++-- | Configuration for serialization function, reuse the 'Serial' instance.+serializeWithSerialConfig :: [Name] -> [Name] -> [Name] -> UnaryOpClassConfig+serializeWithSerialConfig instanceNames serializeFunNames deserializeFunNames =+  UnaryOpClassConfig+    { unaryOpConfigs =+        [ UnaryOpConfig UnaryOpSerializeWithSerialConfig serializeFunNames,+          UnaryOpConfig UnaryOpDeserializeWithSerialConfig deserializeFunNames+        ],+      unaryOpInstanceNames = instanceNames,+      unaryOpExtraVars = const $ return [],+      unaryOpInstanceTypeFromConfig = defaultUnaryOpInstanceTypeFromConfig,+      unaryOpAllowExistential = False,+      unaryOpContextNames =+        Just $ take (length instanceNames) [''Serial, ''Serial1, ''Serial2]+    }
+ src/Grisette/Internal/TH/Derivation/ShowPPrintCommon.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE TemplateHaskell #-}++-- |+-- Module      :   Grisette.Internal.TH.Derivation.ShowPPrintCommon+-- 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.Derivation.ShowPPrintCommon (showPrintFieldFunExp) where++import qualified Data.Map as M+import qualified Data.Set as S+import Grisette.Internal.TH.Derivation.UnaryOpCommon (FieldFunExp)+import Language.Haskell.TH (Name, Type (AppT, VarT), varE)+import Language.Haskell.TH.Datatype (TypeSubstitution (freeVariables))++-- | Common 'FieldFunExp' for 'Show' and 'Grisette.Core.PPrint' on a GADT.+showPrintFieldFunExp :: [Name] -> [Name] -> FieldFunExp+showPrintFieldFunExp precNames listNames argToFunPat liftedExps = go+  where+    allArgNames = M.keysSet argToFunPat+    typeHasNoArg ty =+      S.fromList (freeVariables [ty])+        `S.intersection` allArgNames+        == S.empty+    goLst ty = do+      let fun0 = varE (head listNames)+          fun1 b = [|$(varE $ listNames !! 1) $(go b) $(goLst b)|]+          fun2 b c =+            [|$(varE $ listNames !! 2) $(go b) $(goLst b) $(go c) $(goLst c)|]+      case ty of+        AppT (AppT (VarT _) b) c -> fun2 b c+        AppT (VarT _) b -> fun1 b+        _ | typeHasNoArg ty -> fun0+        AppT a b | typeHasNoArg a -> fun1 b+        AppT (AppT a b) c | typeHasNoArg a -> fun2 b c+        VarT nm -> case M.lookup nm liftedExps of+          Just [p] -> varE p+          _ -> fail $ "defaultFieldFunExp: unsupported type: " <> show ty+        _ -> fail $ "defaultFieldFunExp: unsupported type: " <> show ty+    go ty = do+      let fun0 = varE (head precNames)+          fun1 b = [|$(varE $ precNames !! 1) $(go b) $(goLst b)|]+          fun2 b c =+            [|$(varE $ precNames !! 2) $(go b) $(goLst b) $(go c) $(goLst c)|]+      case ty of+        AppT (AppT (VarT _) b) c -> fun2 b c+        AppT (VarT _) b -> fun1 b+        _ | typeHasNoArg ty -> fun0+        AppT a b | typeHasNoArg a -> fun1 b+        AppT (AppT a b) c | typeHasNoArg a -> fun2 b c+        VarT nm -> case M.lookup nm argToFunPat of+          Just pname -> varE pname+          _ -> fail $ "defaultFieldFunExp: unsupported type: " <> show ty+        _ -> fail $ "defaultFieldFunExp: unsupported type: " <> show ty
+ src/Grisette/Internal/TH/Derivation/UnaryOpCommon.hs view
@@ -0,0 +1,400 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}++-- |+-- Module      :   Grisette.Internal.TH.Derivation.UnaryOpCommon+-- 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.Derivation.UnaryOpCommon+  ( UnaryOpClassConfig (..),+    UnaryOpFieldConfig (..),+    UnaryOpConfig (..),+    UnaryOpFunConfig (..),+    FieldFunExp,+    defaultFieldResFun,+    defaultFieldFunExp,+    genUnaryOpClass,+    defaultUnaryOpInstanceTypeFromConfig,+  )+where++import Control.Monad (replicateM, zipWithM)+import qualified Data.List as List+import qualified Data.Map as M+import Data.Maybe (catMaybes, fromMaybe, mapMaybe)+import qualified Data.Set as S+import Grisette.Internal.TH.Derivation.Common+  ( CheckArgsResult+      ( CheckArgsResult,+        argVars,+        constructors,+        keptVars+      ),+    DeriveConfig (unconstrainedPositions),+    checkArgs,+    ctxForVar,+    evalModeSpecializeList,+    extraConstraint,+    freshenCheckArgsResult,+    isVarUsedInFields,+    specializeResult,+  )+import Grisette.Internal.TH.Util (allUsedNames)+import Language.Haskell.TH+  ( Body (NormalB),+    Clause (Clause),+    Dec (FunD, InstanceD),+    Exp (VarE),+    Kind,+    Name,+    Pat (VarP, WildP),+    Q,+    Type (AppT, ConT, VarT),+    appE,+    clause,+    conP,+    conT,+    funD,+    nameBase,+    newName,+    normalB,+    varE,+    varP,+  )+import Language.Haskell.TH.Datatype+  ( ConstructorInfo (constructorFields, constructorName, constructorVariant),+    ConstructorVariant,+    TypeSubstitution (freeVariables),+    resolveTypeSynonyms,+  )++-- | Type of field function expression generator.+type FieldFunExp = M.Map Name Name -> M.Map Name [Name] -> Type -> Q Exp++-- | Default field function expression generator.+defaultFieldFunExp :: [Name] -> FieldFunExp+defaultFieldFunExp unaryOpFunNames argToFunPat _ = go+  where+    go ty = do+      let allArgNames = M.keysSet argToFunPat+      let typeHasNoArg ty =+            S.fromList (freeVariables [ty])+              `S.intersection` allArgNames+              == S.empty+      let fun0 = varE $ head unaryOpFunNames+          fun1 b = [|$(varE $ unaryOpFunNames !! 1) $(go b)|]+          fun2 b c = [|$(varE $ unaryOpFunNames !! 2) $(go b) $(go c)|]+          fun3 b c d =+            [|$(varE $ unaryOpFunNames !! 3) $(go b) $(go c) $(go d)|]+      case ty of+        AppT (AppT (AppT (VarT _) b) c) d -> fun3 b c d+        AppT (AppT (VarT _) b) c -> fun2 b c+        AppT (VarT _) b -> fun1 b+        _ | typeHasNoArg ty -> fun0+        AppT a b | typeHasNoArg a -> fun1 b+        AppT (AppT a b) c | typeHasNoArg a -> fun2 b c+        AppT (AppT (AppT a b) c) d | typeHasNoArg a -> fun3 b c d+        VarT nm -> case M.lookup nm argToFunPat of+          Just pname -> varE pname+          _ -> fail $ "defaultFieldFunExp: unsupported type: " <> show ty+        _ -> fail $ "defaultFieldFunExp: unsupported type: " <> show ty++-- | Configuration for a unary function field expression generation on a GADT.+data UnaryOpConfig where+  UnaryOpConfig ::+    (UnaryOpFunConfig config) => config -> [Name] -> UnaryOpConfig++-- | Default field result function.+defaultFieldResFun ::+  ConstructorVariant -> Name -> [Exp] -> Int -> Exp -> Exp -> Q (Exp, [Bool])+defaultFieldResFun _ _ extraPatExps _ fieldPatExp defaultFieldFunExp = do+  res <-+    appE+      ( foldl+          (\exp name -> appE exp (return name))+          (return defaultFieldFunExp)+          extraPatExps+      )+      (return fieldPatExp)+  return (res, (True <$ extraPatExps))++funPatAndExps ::+  FieldFunExp ->+  (Int -> [String]) ->+  [(Type, Kind)] ->+  [Type] ->+  Q ([Pat], [[Pat]], [Exp])+funPatAndExps fieldFunExpGen extraLiftedPatNames argTypes fields = do+  let usedArgs = S.fromList $ freeVariables fields+  let liftedNames = extraLiftedPatNames (length argTypes)+  args <-+    traverse+      ( \(ty, _) -> do+          case ty of+            VarT nm ->+              if S.member nm usedArgs+                then do+                  pname <- newName "p"+                  epname <- traverse newName liftedNames+                  return (nm, Just (pname, epname))+                else return ('undefined, Nothing)+            _ -> return ('undefined, Nothing)+      )+      argTypes+  let argToFunPat =+        M.fromList $ mapMaybe (\(nm, mpat) -> fmap ((nm,) . fst) mpat) args+  let argToLiftedPat =+        M.fromList $ mapMaybe (\(nm, mpat) -> fmap ((nm,) . snd) mpat) args+  let funPats = fmap (maybe WildP (VarP . fst) . snd) args+  let extraLiftedPats =+        fmap+          ( maybe+              (replicate (length liftedNames) WildP)+              (fmap VarP . snd)+              . snd+          )+          args+  defaultFieldFunExps <-+    traverse+      (fieldFunExpGen argToFunPat argToLiftedPat)+      fields+  return (funPats, extraLiftedPats, defaultFieldFunExps)++-- | Generate a clause for a unary function on a GADT.+genUnaryOpFieldClause ::+  UnaryOpFieldConfig ->+  [(Type, Kind)] ->+  Int ->+  Int ->+  ConstructorInfo ->+  Q Clause+genUnaryOpFieldClause+  (UnaryOpFieldConfig {..})+  argTypes+  totalConNumber+  conIdx+  conInfo = do+    fields <- mapM resolveTypeSynonyms $ constructorFields conInfo+    (funPats, funLiftedPats, defaultFieldFunExps) <-+      funPatAndExps fieldFunExp extraLiftedPatNames argTypes fields+    extraPatNames <- traverse newName extraPatNames+    let extraPatExps = fmap VarE extraPatNames+    fieldsPatNames <- replicateM (length fields) $ newName "field"+    let extraPats = fmap VarP extraPatNames+    fieldPats <- conP (constructorName conInfo) (fmap varP fieldsPatNames)+    let fieldPatExps = fmap VarE fieldsPatNames++    fieldResExpsAndArgsUsed <-+      sequence $+        zipWith3+          ( fieldResFun+              (constructorVariant conInfo)+              (constructorName conInfo)+              extraPatExps+          )+          [0 ..]+          fieldPatExps+          defaultFieldFunExps+    let fieldResExps = fst <$> fieldResExpsAndArgsUsed+    let extraArgsUsedByFields = snd <$> fieldResExpsAndArgsUsed++    (resExp, extraArgsUsedByResult) <-+      fieldCombineFun+        totalConNumber+        conIdx+        (constructorVariant conInfo)+        (constructorName conInfo)+        extraPatExps+        fieldResExps+    let resUsedNames = allUsedNames resExp+    let extraArgsUsed =+          fmap or $+            List.transpose $+              extraArgsUsedByResult : extraArgsUsedByFields+    let extraArgsPats =+          zipWith+            (\pat used -> if used then pat else WildP)+            extraPats+            extraArgsUsed+    let transformPat (VarP nm) =+          if S.member nm resUsedNames then VarP nm else WildP+        transformPat p = p+    return $+      Clause+        ( fmap transformPat $+            concat (zipWith (:) funPats funLiftedPats)+              ++ extraArgsPats+              ++ [fieldPats]+        )+        (NormalB resExp)+        []++-- | Configuration for a unary operation type class generation on a GADT.+data UnaryOpClassConfig = UnaryOpClassConfig+  { unaryOpConfigs :: [UnaryOpConfig],+    unaryOpInstanceNames :: [Name],+    unaryOpContextNames :: Maybe [Name],+    unaryOpExtraVars :: DeriveConfig -> Q [(Type, Kind)],+    unaryOpInstanceTypeFromConfig ::+      DeriveConfig ->+      [(Type, Kind)] ->+      [(Type, Kind)] ->+      Name ->+      Q Type,+    unaryOpAllowExistential :: Bool+  }++-- | Default unary operation instance type generator.+defaultUnaryOpInstanceTypeFromConfig ::+  DeriveConfig -> [(Type, Kind)] -> [(Type, Kind)] -> Name -> Q Type+defaultUnaryOpInstanceTypeFromConfig _ _ _ = conT++-- | Configuration for the derivation rules for a unary operation that can be+-- derived by transforming each field and then combining the results.+data UnaryOpFieldConfig = UnaryOpFieldConfig+  { extraPatNames :: [String],+    extraLiftedPatNames :: Int -> [String],+    fieldResFun ::+      ConstructorVariant ->+      Name ->+      [Exp] ->+      Int ->+      Exp ->+      Exp ->+      Q (Exp, [Bool]),+    fieldCombineFun ::+      -- \| Total number of constructors+      Int ->+      -- \| Constructor index+      Int ->+      -- \| Constructor variant+      ConstructorVariant ->+      -- \| Constructor name+      Name ->+      -- \| Extra pattern expressions+      [Exp] ->+      -- \| Field result expressions+      [Exp] ->+      Q (Exp, [Bool]),+    fieldFunExp :: FieldFunExp+  }++-- | Configuration for the derivation rules for a unary operation.+class UnaryOpFunConfig config where+  genUnaryOpFun ::+    -- | Derive configuration+    DeriveConfig ->+    -- | Configuration+    config ->+    -- | Function names+    [Name] ->+    -- | Number of functor arguments to the class+    Int ->+    -- | Extra variables+    [(Type, Kind)] ->+    -- | Kept variables+    [(Type, Kind)] ->+    -- | Argument variables+    [(Type, Kind)] ->+    -- | Whether the variable is used in fields+    (Name -> Bool) ->+    -- | Constructor infos+    [ConstructorInfo] ->+    Q Dec++instance UnaryOpFunConfig UnaryOpFieldConfig where+  genUnaryOpFun _ _ funNames n _ _ _ _ [] =+    funD (funNames !! n) [clause [] (normalB [|error "impossible"|]) []]+  genUnaryOpFun _ config funNames n _ _ argTypes _ constructors = do+    clauses <-+      zipWithM+        ( genUnaryOpFieldClause+            config+            argTypes+            (length constructors)+        )+        [0 ..]+        constructors+    let instanceFunName = funNames !! n+    return $ FunD instanceFunName clauses++-- | Generate a unary operation type class instance for a data type.+genUnaryOpClass ::+  DeriveConfig ->+  UnaryOpClassConfig ->+  Int ->+  Name ->+  Q [Dec]+genUnaryOpClass deriveConfig (UnaryOpClassConfig {..}) n typName = do+  result@CheckArgsResult {..} <-+    specializeResult (evalModeSpecializeList deriveConfig)+      =<< freshenCheckArgsResult True+      =<< checkArgs+        (nameBase $ head unaryOpInstanceNames)+        (length unaryOpInstanceNames - 1)+        typName+        unaryOpAllowExistential+        n+  extraVars <- unaryOpExtraVars deriveConfig++  let isTypeUsedInFields (VarT nm) = isVarUsedInFields result nm+      isTypeUsedInFields _ = False+  contextInstanceTypes <-+    traverse+      (unaryOpInstanceTypeFromConfig deriveConfig extraVars keptVars)+      (fromMaybe unaryOpInstanceNames unaryOpContextNames)+  ctxs <-+    traverse (uncurry $ ctxForVar contextInstanceTypes) $+      filter (isTypeUsedInFields . fst) $+        fmap snd $+          filter (not . (`elem` unconstrainedPositions deriveConfig) . fst) $+            zip [0 ..] keptVars+  let keptType = foldl AppT (ConT typName) $ fmap fst keptVars+  instanceFuns <-+    traverse+      ( \(UnaryOpConfig config funNames) ->+          genUnaryOpFun+            deriveConfig+            config+            funNames+            n+            extraVars+            keptVars+            argVars+            (isVarUsedInFields result)+            constructors+      )+      unaryOpConfigs+  let instanceName = unaryOpInstanceNames !! n+  instanceTypes <-+    traverse+      (unaryOpInstanceTypeFromConfig deriveConfig extraVars keptVars)+      unaryOpInstanceNames+  let instanceType = AppT (instanceTypes !! n) keptType+  extraPreds <-+    extraConstraint+      deriveConfig+      typName+      instanceName+      extraVars+      keptVars+      constructors+  return+    [ InstanceD+        Nothing+        ( extraPreds+            ++ if null constructors+              then []+              else catMaybes ctxs+        )+        instanceType+        instanceFuns+    ]
+ src/Grisette/Internal/TH/Derivation/UnifiedOpCommon.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}++-- |+-- Module      :   Grisette.Internal.TH.Derivation.UnifiedOpCommon+-- 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.Derivation.UnifiedOpCommon+  ( UnaryOpUnifiedConfig (..),+    defaultUnaryOpUnifiedFun,+  )+where++import Grisette.Internal.TH.Derivation.Common (DeriveConfig (evalModeConfig))+import Grisette.Internal.TH.Derivation.UnaryOpCommon+  ( UnaryOpFunConfig (genUnaryOpFun),+  )+import Grisette.Internal.Unified.Util (withMode)+import Language.Haskell.TH+  ( Exp (VarE),+    Kind,+    Name,+    Q,+    Type (AppT, ArrowT, StarT, VarT),+    appE,+    clause,+    funD,+    newName,+    normalB,+    varE,+    varP,+  )++-- | Default implementation for the derivation rules for a unified operation.+defaultUnaryOpUnifiedFun :: [Name] -> Type -> (Type, Kind) -> Q (Maybe Exp)+defaultUnaryOpUnifiedFun funNames modeTy (ty, kind) =+  case kind of+    StarT ->+      Just+        <$> [|+          $(varE $ head funNames) @($(return modeTy))+            @($(return ty))+          |]+    AppT (AppT ArrowT StarT) StarT ->+      Just+        <$> [|+          $(varE $ funNames !! 1) @($(return modeTy))+            @($(return ty))+          |]+    AppT (AppT (AppT ArrowT StarT) StarT) StarT ->+      Just+        <$> [|+          $(varE $ funNames !! 2) @($(return modeTy))+            @($(return ty))+          |]+    _ -> return Nothing++-- | Configuration for the derivation rules for a unified operation.+newtype UnaryOpUnifiedConfig = UnaryOpUnifiedConfig+  {unifiedFun :: Type -> (Type, Kind) -> Q (Maybe Exp)}++instance UnaryOpFunConfig UnaryOpUnifiedConfig where+  genUnaryOpFun+    deriveConfig+    (UnaryOpUnifiedConfig {..})+    funNames+    n+    extraVars+    keptTypes+    _+    isVarUsedInFields+    _ = do+      modeTy <- case evalModeConfig deriveConfig of+        [] -> return $ fst $ head extraVars+        [(i, _)] -> return $ fst $ keptTypes !! i+        _ -> fail "Unified classes does not support multiple evaluation modes"+      let isTypeUsedInFields (VarT nm) = isVarUsedInFields nm+          isTypeUsedInFields _ = False+      exprs <-+        traverse (unifiedFun modeTy) $+          filter (isTypeUsedInFields . fst) keptTypes+      rVar <- newName "r"+      let rf =+            foldl+              ( \exp nextFun -> case nextFun of+                  Nothing -> exp+                  Just fun -> appE (return fun) exp+              )+              (return $ VarE rVar)+              exprs+      let instanceFunName = funNames !! n+      funD+        instanceFunName+        [ clause+            [varP rVar]+            ( normalB+                [|+                  withMode @($(return modeTy)) $(rf) $(rf)+                  |]+            )+            []+        ]
+ src/Grisette/Internal/TH/Util.hs view
@@ -0,0 +1,337 @@+{-# 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+  ( constructorInfoToType,+    tvIsMode,+    tvIsNat,+    tvIsStar,+    tvIsStarToStar,+    substDataType,+    reifyDatatypeWithFreshNames,+    singleParamClassParamKind,+    binaryClassParamKind,+    getTypeWithMaybeSubst,+    dropLastTypeParam,+    dropNTypeParam,+    classParamKinds,+    allSameKind,+    classNumParam,+    kindNumParam,+    concatPreds,+    putHaddock,+    allUsedNamesMaybe,+    allUsedNames,+    isNonUnitTupleString,+    isNonUnitTuple,+    integerE,+    mangleName,+    dataTypeHasExistential,+  )+where++#if MIN_VERSION_template_haskell(2,18,0)+import Language.Haskell.TH.Syntax+  ( DocLoc (DeclDoc),+    ModName (ModName),+    Name (Name),+    NameFlavour (NameG, NameQ, NameS),+    addModFinalizer,+    putDoc,+  )+#else+import Language.Haskell.TH.Syntax+  ( ModName (ModName),+    Name (Name),+    NameFlavour (NameG, NameQ, NameS),+  )+#endif++import Control.Monad (when)+import Data.Char (isAlphaNum, ord)+import qualified Data.Map as M+import qualified Data.Set as S+import GHC.TypeNats (Nat)+import Grisette.Internal.Unified.EvalModeTag (EvalModeTag)+import Language.Haskell.TH+  ( Dec (ClassD),+    Exp+      ( AppE,+        AppTypeE,+        ConE,+        CondE,+        InfixE,+        LamE,+        ListE,+        LitE,+        ParensE,+        SigE,+        TupE,+        UInfixE,+        VarE+      ),+    Info (ClassI),+    Kind,+    Pred,+    Q,+    Type (AppT, ArrowT, ConT, ForallT, StarT, VarT),+    integerL,+    litE,+    nameBase,+    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,+  )++-- | 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++-- | Get the names used in an expression.+allUsedNamesMaybe :: Maybe Exp -> S.Set Name+allUsedNamesMaybe Nothing = S.empty+allUsedNamesMaybe (Just exp) = allUsedNames exp++-- | Get the names used in an expression.+allUsedNames :: Exp -> S.Set Name+allUsedNames (VarE nm) = S.singleton nm+allUsedNames (ConE n) = S.singleton n+allUsedNames (LitE _) = S.empty+allUsedNames (AppE e1 e2) = allUsedNames e1 `S.union` allUsedNames e2+allUsedNames (AppTypeE e1 _) = allUsedNames e1+allUsedNames (InfixE l e r) =+  allUsedNamesMaybe l `S.union` allUsedNames e `S.union` allUsedNamesMaybe r+allUsedNames (UInfixE l e r) =+  allUsedNames l `S.union` allUsedNames e `S.union` allUsedNames r+allUsedNames (ParensE e) = allUsedNames e+allUsedNames (LamE _ e) = allUsedNames e+allUsedNames (TupE es) = mconcat $ allUsedNamesMaybe <$> es+allUsedNames (CondE e1 e2 e3) =+  allUsedNames e1 `S.union` allUsedNames e2 `S.union` allUsedNames e3+allUsedNames (ListE es) = mconcat $ allUsedNames <$> es+allUsedNames (SigE e _) = allUsedNames e+allUsedNames exp = error $ "allUsedNames: unsupported expression: " <> show exp++-- | Check if a string is the data constructor name of a non-unit tuple.+isNonUnitTupleString :: String -> Bool+isNonUnitTupleString ('(' : ',' : _) = True+isNonUnitTupleString _ = False++-- | Check if a name is the data constructor name of a non-unit tuple.+isNonUnitTuple :: Name -> Bool+isNonUnitTuple nm =+  isNonUnitTupleString $ nameBase nm++-- | Convert an integer to an 'Exp'.+integerE :: (Integral a) => a -> Q Exp+integerE = litE . integerL . fromIntegral++-- | Mangle a name string to contain only alphanumeric characters and+-- underscores.+mangleName :: Name -> String+mangleName nm@(Name _ flavor) =+  case flavor of+    NameS -> mangleBaseName $ nameBase nm+    NameQ mod -> mangleModName mod <> "_" <> mangleBaseName (nameBase nm)+    NameG _ _ mod -> mangleModName mod <> "_" <> mangleBaseName (nameBase nm)+    _ -> error $ "mangleName: unsupported name flavor: " <> show flavor+  where+    mangleModName (ModName m) = mangleBaseName m+    mangleBaseName l = "Mangled" ++ go l+    go [] = []+    go (c : cs)+      | isAlphaNum c || c == '_' = c : go cs+      | otherwise = "_" <> show (ord c) <> go cs++-- | Check if a data type has existential variables in constructors.+dataTypeHasExistential :: Name -> Q Bool+dataTypeHasExistential typName = do+  d <- reifyDatatype typName+  return $ not $ all (null . constructorVars) $ datatypeCons d
+ src/Grisette/Internal/Unified/BVBVConversion.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.Unified.BVBVConversion+-- 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.Unified.BVBVConversion+  ( UnifiedBVBVConversion,+    AllUnifiedBVBVConversion,+  )+where++import GHC.TypeNats (KnownNat, Nat, type (<=))+import Grisette.Internal.SymPrim.BV (IntN, WordN)+import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN)+import Grisette.Internal.Unified.Class.UnifiedFromIntegral (UnifiedFromIntegral)+import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C, S))+import Grisette.Internal.Unified.UnifiedBV (UnifiedBVImpl (GetIntN, GetWordN))++class+  ( bv0 ~ bvn0 n0,+    bv1 ~ bvn1 n1,+    UnifiedFromIntegral mode bv0 bv1+  ) =>+  UnifiedBVBVConversionImpl+    (mode :: EvalModeTag)+    bvn0+    bvn1+    (n0 :: Nat)+    (n1 :: Nat)+    bv0+    bv1+    | bvn0 n0 -> bv0,+      bvn1 n1 -> bv1,+      bv0 -> bvn0 n0,+      bv1 -> bvn1 n1++#define QUOTE() '++#define CONINSTANCE(ty0, ty1) \+instance \+  (KnownNat n0, 1 <= n0, KnownNat n1, 1 <= n1) => \+  UnifiedBVBVConversionImpl QUOTE()C ty0 ty1 n0 n1 (ty0 n0) (ty1 n1)++#define SYMINSTANCE(ty0, ty1) \+instance \+  (KnownNat n0, 1 <= n0, KnownNat n1, 1 <= n1) => \+  UnifiedBVBVConversionImpl QUOTE()S ty0 ty1 n0 n1 (ty0 n0) (ty1 n1)++#if 1+CONINSTANCE(WordN, WordN)+CONINSTANCE(WordN, IntN)+CONINSTANCE(IntN, WordN)+CONINSTANCE(IntN, IntN)+SYMINSTANCE(SymWordN, SymWordN)+SYMINSTANCE(SymWordN, SymIntN)+SYMINSTANCE(SymIntN, SymWordN)+SYMINSTANCE(SymIntN, SymIntN)+#endif++-- | Unified constraints for conversion between bit-vectors.+class+  ( UnifiedBVBVConversionImpl+      mode+      (GetWordN mode)+      (GetWordN mode)+      n0+      n1+      (GetWordN mode n0)+      (GetWordN mode n1),+    UnifiedBVBVConversionImpl+      mode+      (GetWordN mode)+      (GetIntN mode)+      n0+      n1+      (GetWordN mode n0)+      (GetIntN mode n1),+    UnifiedBVBVConversionImpl+      mode+      (GetIntN mode)+      (GetWordN mode)+      n0+      n1+      (GetIntN mode n0)+      (GetWordN mode n1),+    UnifiedBVBVConversionImpl+      mode+      (GetIntN mode)+      (GetIntN mode)+      n0+      n1+      (GetIntN mode n0)+      (GetIntN mode n1)+  ) =>+  UnifiedBVBVConversion (mode :: EvalModeTag) n0 n1++instance+  ( UnifiedBVBVConversionImpl+      mode+      (GetWordN mode)+      (GetWordN mode)+      n0+      n1+      (GetWordN mode n0)+      (GetWordN mode n1),+    UnifiedBVBVConversionImpl+      mode+      (GetWordN mode)+      (GetIntN mode)+      n0+      n1+      (GetWordN mode n0)+      (GetIntN mode n1),+    UnifiedBVBVConversionImpl+      mode+      (GetIntN mode)+      (GetWordN mode)+      n0+      n1+      (GetIntN mode n0)+      (GetWordN mode n1),+    UnifiedBVBVConversionImpl+      mode+      (GetIntN mode)+      (GetIntN mode)+      n0+      n1+      (GetIntN mode n0)+      (GetIntN mode n1)+  ) =>+  UnifiedBVBVConversion (mode :: EvalModeTag) n0 n1++-- | Evaluation mode with unified conversion from bit-vectors to bit-vectors.+class+  ( forall n0 n1.+    (KnownNat n0, KnownNat n1, 1 <= n0, 1 <= n1) =>+    UnifiedBVBVConversion mode n0 n1+  ) =>+  AllUnifiedBVBVConversion mode++instance+  ( forall n0 n1.+    (KnownNat n0, KnownNat n1, 1 <= n0, 1 <= n1) =>+    UnifiedBVBVConversion mode n0 n1+  ) =>+  AllUnifiedBVBVConversion mode
+ src/Grisette/Internal/Unified/BVFPConversion.hs view
@@ -0,0 +1,19 @@+{-# OPTIONS_GHC -Wno-missing-import-lists #-}++-- |+-- Module      :   Grisette.Internal.Unified.BVFPConversion+-- 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.Unified.BVFPConversion+  ( UnifiedBVFPConversion,+    SafeUnifiedBVFPConversion,+    AllUnifiedBVFPConversion,+  )+where++import Grisette.Internal.Internal.Decl.Unified.BVFPConversion+import Grisette.Internal.Internal.Impl.Unified.BVFPConversion ()
+ src/Grisette/Internal/Unified/BaseConstraint.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE ConstraintKinds #-}++-- |+-- Module      :   Grisette.Internal.Unified.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.Internal.Unified.BaseConstraint+  ( ConSymConversion,+  )+where++import Grisette.Internal.Core.Data.Class.ToCon (ToCon)+import Grisette.Internal.Core.Data.Class.ToSym (ToSym)++-- | 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+  )
+ src/Grisette/Internal/Unified/Class/UnifiedFiniteBits.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.Unified.Class.UnifiedFiniteBits+-- 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.Unified.Class.UnifiedFiniteBits+  ( UnifiedFiniteBits (..),+    symTestBit,+    symSetBitTo,+    symFromBits,+    symBitBlast,+    symLsb,+    symMsb,+    symPopCount,+    symCountLeadingZeros,+    symCountTrailingZeros,+  )+where++import Data.Bits+  ( Bits (popCount, testBit),+    FiniteBits (countLeadingZeros, countTrailingZeros),+  )+import Data.Type.Bool (If)+import GHC.TypeLits (KnownNat, type (<=))+import Grisette.Internal.Core.Data.Class.SymFiniteBits+  ( FromBits,+    SymFiniteBits,+    setBitTo,+  )+import qualified Grisette.Internal.Core.Data.Class.SymFiniteBits as SymFiniteBits+import Grisette.Internal.SymPrim.BV (IntN, WordN)+import Grisette.Internal.SymPrim.SomeBV+  ( SomeIntN,+    SomeSymIntN,+    SomeSymWordN,+    SomeWordN,+  )+import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN)+import Grisette.Internal.Unified.Class.UnifiedITEOp+  ( UnifiedITEOp (withBaseITEOp),+  )+import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C, S), IsConMode)+import Grisette.Internal.Unified.UnifiedBool (UnifiedBool (GetBool))+import Grisette.Internal.Unified.Util (DecideEvalMode, withMode)++-- | Unified `Grisette.Internal.Core.Data.Class.SymFiniteBits.symTestBit`.+symTestBit ::+  forall mode a.+  (DecideEvalMode mode, UnifiedFiniteBits mode a) =>+  a ->+  Int ->+  GetBool mode+symTestBit a i =+  withMode @mode+    (withBaseFiniteBits @mode @a (testBit a i))+    (withBaseFiniteBits @mode @a (SymFiniteBits.symTestBit a i))++-- | Unified `Grisette.Internal.Core.Data.Class.SymFiniteBits.symSetBitTo`.+symSetBitTo ::+  forall mode a.+  (DecideEvalMode mode, UnifiedFiniteBits mode a) =>+  a ->+  Int ->+  GetBool mode ->+  a+symSetBitTo a i b =+  withMode @mode+    (withBaseFiniteBits @mode @a (setBitTo a i b))+    (withBaseFiniteBits @mode @a (SymFiniteBits.symSetBitTo a i b))++-- | Unified `Grisette.Internal.Core.Data.Class.SymFiniteBits.symFromBits`.+symFromBits ::+  forall mode a.+  (DecideEvalMode mode, UnifiedFiniteBits mode a) =>+  [GetBool mode] ->+  a+symFromBits bits =+  withMode @mode+    (withBaseFiniteBits @mode @a (SymFiniteBits.fromBits bits))+    (withBaseFiniteBits @mode @a (SymFiniteBits.symFromBits bits))++-- | Unified `Grisette.Internal.Core.Data.Class.SymFiniteBits.symBitBlast`.+symBitBlast ::+  forall mode a.+  (DecideEvalMode mode, UnifiedFiniteBits mode a) =>+  a ->+  [GetBool mode]+symBitBlast a =+  withMode @mode+    (withBaseFiniteBits @mode @a (SymFiniteBits.bitBlast a))+    (withBaseFiniteBits @mode @a (SymFiniteBits.symBitBlast a))++-- | Unified `Grisette.Internal.Core.Data.Class.SymFiniteBits.symLsb`.+symLsb ::+  forall mode a.+  (DecideEvalMode mode, UnifiedFiniteBits mode a) =>+  a ->+  GetBool mode+symLsb a =+  withMode @mode+    (withBaseFiniteBits @mode @a (SymFiniteBits.lsb a))+    (withBaseFiniteBits @mode @a (SymFiniteBits.symLsb a))++-- | Unified `Grisette.Internal.Core.Data.Class.SymFiniteBits.symMsb`.+symMsb ::+  forall mode a.+  (DecideEvalMode mode, UnifiedFiniteBits mode a) =>+  a ->+  GetBool mode+symMsb a =+  withMode @mode+    (withBaseFiniteBits @mode @a (SymFiniteBits.msb a))+    (withBaseFiniteBits @mode @a (SymFiniteBits.symMsb a))++-- | Unified `Grisette.Internal.Core.Data.Class.SymFiniteBits.symPopCount`.+symPopCount ::+  forall mode a.+  (DecideEvalMode mode, UnifiedFiniteBits mode a, Num a, UnifiedITEOp mode a) =>+  a ->+  a+symPopCount a =+  withMode @mode+    (withBaseFiniteBits @mode @a (0 * a + fromIntegral (popCount a)))+    ( withBaseFiniteBits @mode @a $+        withBaseITEOp @mode @a (SymFiniteBits.symPopCount a)+    )++-- | Unified+-- `Grisette.Internal.Core.Data.Class.SymFiniteBits.symCountLeadingZeros`.+symCountLeadingZeros ::+  forall mode a.+  (DecideEvalMode mode, UnifiedFiniteBits mode a, Num a, UnifiedITEOp mode a) =>+  a ->+  a+symCountLeadingZeros a =+  withMode @mode+    (withBaseFiniteBits @mode @a (0 * a + fromIntegral (countLeadingZeros a)))+    ( withBaseFiniteBits @mode @a $+        withBaseITEOp @mode @a (SymFiniteBits.symCountLeadingZeros a)+    )++-- | Unified+-- `Grisette.Internal.Core.Data.Class.SymFiniteBits.symCountTrailingZeros`.+symCountTrailingZeros ::+  forall mode a.+  (DecideEvalMode mode, UnifiedFiniteBits mode a, Num a, UnifiedITEOp mode a) =>+  a ->+  a+symCountTrailingZeros a =+  withMode @mode+    (withBaseFiniteBits @mode @a (0 * a + fromIntegral (countTrailingZeros a)))+    ( withBaseFiniteBits @mode @a $+        withBaseITEOp @mode @a (SymFiniteBits.symCountTrailingZeros a)+    )++-- | A class that provides unified equality comparison.+--+-- We use this type class to help resolve the constraints for `FiniteBits`,+-- `FromBits` and `SymFiniteBits`.+class UnifiedFiniteBits mode a where+  withBaseFiniteBits ::+    ((If (IsConMode mode) (FiniteBits a, FromBits a) (SymFiniteBits a)) => r) ->+    r++instance (KnownNat n, 1 <= n) => UnifiedFiniteBits 'C (WordN n) where+  withBaseFiniteBits r = r++instance (KnownNat n, 1 <= n) => UnifiedFiniteBits 'C (IntN n) where+  withBaseFiniteBits r = r++instance UnifiedFiniteBits 'C SomeWordN where+  withBaseFiniteBits r = r++instance UnifiedFiniteBits 'C SomeIntN where+  withBaseFiniteBits r = r++instance (KnownNat n, 1 <= n) => UnifiedFiniteBits 'S (SymWordN n) where+  withBaseFiniteBits r = r++instance (KnownNat n, 1 <= n) => UnifiedFiniteBits 'S (SymIntN n) where+  withBaseFiniteBits r = r++instance UnifiedFiniteBits 'S SomeSymWordN where+  withBaseFiniteBits r = r++instance UnifiedFiniteBits 'S SomeSymIntN where+  withBaseFiniteBits r = r
+ src/Grisette/Internal/Unified/Class/UnifiedFromIntegral.hs view
@@ -0,0 +1,225 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.Unified.Class.UnifiedFromIntegral+-- 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.Unified.Class.UnifiedFromIntegral+  ( UnifiedFromIntegral (..),+    symFromIntegral,+  )+where++import Data.Type.Bool (If)+import GHC.TypeNats (KnownNat, type (<=))+import Grisette.Internal.Core.Data.Class.SymFromIntegral (SymFromIntegral)+import qualified Grisette.Internal.Core.Data.Class.SymFromIntegral as SymFromIntegral+import Grisette.Internal.SymPrim.AlgReal (AlgReal)+import Grisette.Internal.SymPrim.BV (IntN, WordN)+import Grisette.Internal.SymPrim.FP (FP, ValidFP)+import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal)+import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN)+import Grisette.Internal.SymPrim.SymFP (SymFP)+import Grisette.Internal.SymPrim.SymInteger (SymInteger)+import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C, S), IsConMode)+import Grisette.Internal.Unified.Util (DecideEvalMode, withMode)++-- | Unified `Grisette.Internal.Core.Data.Class.SymFromIntegral.symFromIntegral`+-- operation.+--+-- This function isn't able to infer the mode, so you need to provide the mode+-- explicitly. For example:+--+-- > symFromIntegral @mode a+symFromIntegral ::+  forall mode a b. (DecideEvalMode mode, UnifiedFromIntegral mode a b) => a -> b+symFromIntegral a =+  withMode @mode+    (withBaseFromIntegral @mode @a @b $ fromIntegral a)+    (withBaseFromIntegral @mode @a @b $ SymFromIntegral.symFromIntegral a)++-- | A class that provides unified conversion from integral types.+--+-- We use this type class to help resolve the constraints for `SymFromIntegral`.+class UnifiedFromIntegral (mode :: EvalModeTag) a b where+  withBaseFromIntegral ::+    ((If (IsConMode mode) (Integral a, Num b) (SymFromIntegral a b)) => r) -> r++instance+  {-# INCOHERENT #-}+  ( DecideEvalMode mode,+    (If (IsConMode mode) (Integral a, Num b) (SymFromIntegral a b))+  ) =>+  UnifiedFromIntegral mode a b+  where+  withBaseFromIntegral r = r++instance UnifiedFromIntegral 'C Integer AlgReal where+  withBaseFromIntegral r = r++instance UnifiedFromIntegral 'C Integer Integer where+  withBaseFromIntegral r = r++instance (KnownNat n, 1 <= n) => UnifiedFromIntegral 'C Integer (IntN n) where+  withBaseFromIntegral r = r++instance+  (KnownNat n, 1 <= n) =>+  UnifiedFromIntegral 'C Integer (WordN n)+  where+  withBaseFromIntegral r = r++instance (ValidFP eb sb) => UnifiedFromIntegral 'C Integer (FP eb sb) where+  withBaseFromIntegral r = r++instance+  (KnownNat n', 1 <= n') =>+  UnifiedFromIntegral 'C (IntN n') AlgReal+  where+  withBaseFromIntegral r = r++instance+  (KnownNat n', 1 <= n') =>+  UnifiedFromIntegral 'C (IntN n') Integer+  where+  withBaseFromIntegral r = r++instance+  (KnownNat n', 1 <= n', KnownNat n, 1 <= n) =>+  UnifiedFromIntegral 'C (IntN n') (IntN n)+  where+  withBaseFromIntegral r = r++instance+  (KnownNat n', 1 <= n', KnownNat n, 1 <= n) =>+  UnifiedFromIntegral 'C (IntN n') (WordN n)+  where+  withBaseFromIntegral r = r++instance+  (KnownNat n', 1 <= n', ValidFP eb sb) =>+  UnifiedFromIntegral 'C (IntN n') (FP eb sb)+  where+  withBaseFromIntegral r = r++instance+  (KnownNat n', 1 <= n') =>+  UnifiedFromIntegral 'C (WordN n') AlgReal+  where+  withBaseFromIntegral r = r++instance+  (KnownNat n', 1 <= n') =>+  UnifiedFromIntegral 'C (WordN n') Integer+  where+  withBaseFromIntegral r = r++instance+  (KnownNat n', 1 <= n', KnownNat n, 1 <= n) =>+  UnifiedFromIntegral 'C (WordN n') (IntN n)+  where+  withBaseFromIntegral r = r++instance+  (KnownNat n', 1 <= n', KnownNat n, 1 <= n) =>+  UnifiedFromIntegral 'C (WordN n') (WordN n)+  where+  withBaseFromIntegral r = r++instance+  (KnownNat n', 1 <= n', ValidFP eb sb) =>+  UnifiedFromIntegral 'C (WordN n') (FP eb sb)+  where+  withBaseFromIntegral r = r++instance UnifiedFromIntegral 'S SymInteger SymAlgReal where+  withBaseFromIntegral r = r++instance UnifiedFromIntegral 'S SymInteger SymInteger where+  withBaseFromIntegral r = r++instance (KnownNat n, 1 <= n) => UnifiedFromIntegral 'S SymInteger (SymIntN n) where+  withBaseFromIntegral r = r++instance+  (KnownNat n, 1 <= n) =>+  UnifiedFromIntegral 'S SymInteger (SymWordN n)+  where+  withBaseFromIntegral r = r++instance (ValidFP eb sb) => UnifiedFromIntegral 'S SymInteger (SymFP eb sb) where+  withBaseFromIntegral r = r++instance+  (KnownNat n', 1 <= n') =>+  UnifiedFromIntegral 'S (SymIntN n') SymAlgReal+  where+  withBaseFromIntegral r = r++instance+  (KnownNat n', 1 <= n') =>+  UnifiedFromIntegral 'S (SymIntN n') SymInteger+  where+  withBaseFromIntegral r = r++instance+  (KnownNat n', 1 <= n', KnownNat n, 1 <= n) =>+  UnifiedFromIntegral 'S (SymIntN n') (SymIntN n)+  where+  withBaseFromIntegral r = r++instance+  (KnownNat n', 1 <= n', KnownNat n, 1 <= n) =>+  UnifiedFromIntegral 'S (SymIntN n') (SymWordN n)+  where+  withBaseFromIntegral r = r++instance+  (KnownNat n', 1 <= n', ValidFP eb sb) =>+  UnifiedFromIntegral 'S (SymIntN n') (SymFP eb sb)+  where+  withBaseFromIntegral r = r++instance+  (KnownNat n', 1 <= n') =>+  UnifiedFromIntegral 'S (SymWordN n') SymAlgReal+  where+  withBaseFromIntegral r = r++instance+  (KnownNat n', 1 <= n') =>+  UnifiedFromIntegral 'S (SymWordN n') SymInteger+  where+  withBaseFromIntegral r = r++instance+  (KnownNat n', 1 <= n', KnownNat n, 1 <= n) =>+  UnifiedFromIntegral 'S (SymWordN n') (SymIntN n)+  where+  withBaseFromIntegral r = r++instance+  (KnownNat n', 1 <= n', KnownNat n, 1 <= n) =>+  UnifiedFromIntegral 'S (SymWordN n') (SymWordN n)+  where+  withBaseFromIntegral r = r++instance+  (KnownNat n', 1 <= n', ValidFP eb sb) =>+  UnifiedFromIntegral 'S (SymWordN n') (SymFP eb sb)+  where+  withBaseFromIntegral r = r
+ src/Grisette/Internal/Unified/Class/UnifiedITEOp.hs view
@@ -0,0 +1,19 @@+{-# OPTIONS_GHC -Wno-missing-import-lists #-}++-- |+-- Module      :   Grisette.Internal.Unified.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.Internal.Unified.Class.UnifiedITEOp+  ( symIte,+    symIteMerge,+    UnifiedITEOp (..),+  )+where++import Grisette.Internal.Internal.Decl.Unified.Class.UnifiedITEOp+import Grisette.Internal.Internal.Impl.Unified.Class.UnifiedITEOp
+ src/Grisette/Internal/Unified/Class/UnifiedRep.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.Unified.Class.UnifiedRep+-- 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.Unified.Class.UnifiedRep+  ( UnifiedConRep (..),+    UnifiedSymRep (..),+  )+where++import GHC.TypeLits (KnownNat, type (<=))+import Grisette.Internal.SymPrim.AlgReal (AlgReal)+import Grisette.Internal.SymPrim.BV (IntN, WordN)+import Grisette.Internal.SymPrim.FP (FP, ValidFP)+import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal)+import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN)+import Grisette.Internal.SymPrim.SymBool (SymBool)+import Grisette.Internal.SymPrim.SymFP (SymFP)+import Grisette.Internal.SymPrim.SymInteger (SymInteger)++-- | A class that gives the concrete type of a unified primitive type.+class UnifiedConRep a where+  type ConType a++-- | A class that gives the symbolic type of a unified primitive type.+class UnifiedSymRep a where+  type SymType a++instance UnifiedConRep Bool where+  type ConType Bool = Bool++instance UnifiedSymRep Bool where+  type SymType Bool = SymBool++instance UnifiedConRep SymBool where+  type ConType SymBool = Bool++instance UnifiedSymRep SymBool where+  type SymType SymBool = SymBool++instance UnifiedConRep Integer where+  type ConType Integer = Integer++instance UnifiedSymRep Integer where+  type SymType Integer = SymInteger++instance UnifiedConRep SymInteger where+  type ConType SymInteger = Integer++instance UnifiedSymRep SymInteger where+  type SymType SymInteger = SymInteger++instance UnifiedConRep AlgReal where+  type ConType AlgReal = AlgReal++instance UnifiedSymRep AlgReal where+  type SymType AlgReal = SymAlgReal++instance UnifiedConRep SymAlgReal where+  type ConType SymAlgReal = AlgReal++instance UnifiedSymRep SymAlgReal where+  type SymType SymAlgReal = SymAlgReal++instance (KnownNat n, 1 <= n) => UnifiedConRep (IntN n) where+  type ConType (IntN n) = IntN n++instance (KnownNat n, 1 <= n) => UnifiedSymRep (IntN n) where+  type SymType (IntN n) = SymIntN n++instance (KnownNat n, 1 <= n) => UnifiedConRep (SymIntN n) where+  type ConType (SymIntN n) = IntN n++instance (KnownNat n, 1 <= n) => UnifiedSymRep (SymIntN n) where+  type SymType (SymIntN n) = SymIntN n++instance (KnownNat n, 1 <= n) => UnifiedConRep (WordN n) where+  type ConType (WordN n) = WordN n++instance (KnownNat n, 1 <= n) => UnifiedSymRep (WordN n) where+  type SymType (WordN n) = SymWordN n++instance (KnownNat n, 1 <= n) => UnifiedConRep (SymWordN n) where+  type ConType (SymWordN n) = WordN n++instance (KnownNat n, 1 <= n) => UnifiedSymRep (SymWordN n) where+  type SymType (SymWordN n) = SymWordN n++instance (ValidFP eb sb) => UnifiedConRep (FP eb sb) where+  type ConType (FP eb sb) = FP eb sb++instance (ValidFP eb sb) => UnifiedSymRep (FP eb sb) where+  type SymType (FP eb sb) = SymFP eb sb++instance (ValidFP eb sb) => UnifiedConRep (SymFP eb sb) where+  type ConType (SymFP eb sb) = FP eb sb++instance (ValidFP eb sb) => UnifiedSymRep (SymFP eb sb) where+  type SymType (SymFP eb sb) = SymFP eb sb
+ src/Grisette/Internal/Unified/Class/UnifiedSafeBitCast.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Eta reduce" #-}++-- |+-- Module      :   Grisette.Internal.Unified.Class.UnifiedSafeBitCast+-- 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.Unified.Class.UnifiedSafeBitCast+  ( safeBitCast,+    UnifiedSafeBitCast (..),+  )+where++import Control.Monad.Error.Class (MonadError)+import GHC.TypeLits (KnownNat, type (+), type (<=))+import Grisette.Internal.Core.Data.Class.SafeBitCast (SafeBitCast)+import qualified Grisette.Internal.Core.Data.Class.SafeBitCast+import Grisette.Internal.SymPrim.BV (IntN, WordN)+import Grisette.Internal.SymPrim.FP (FP, NotRepresentableFPError, ValidFP)+import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN)+import Grisette.Internal.SymPrim.SymFP (SymFP)+import Grisette.Internal.Unified.Class.UnifiedSimpleMergeable+  ( UnifiedBranching (withBaseBranching),+  )+import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (S))+import Grisette.Internal.Unified.Util (withMode)++-- | 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+safeBitCast ::+  forall mode e a b m.+  ( MonadError e m,+    UnifiedSafeBitCast mode e a b m+  ) =>+  a ->+  m b+safeBitCast a =+  withBaseSafeBitCast @mode @e @a @b @m $+    Grisette.Internal.Core.Data.Class.SafeBitCast.safeBitCast a+{-# INLINE safeBitCast #-}++-- | A class that provides unified safe bitcast operations.+--+-- We use this type class to help resolve the constraints for `SafeBitCast`.+class UnifiedSafeBitCast (mode :: EvalModeTag) e a b m where+  withBaseSafeBitCast :: ((SafeBitCast e a b m) => r) -> r++instance+  {-# INCOHERENT #-}+  (UnifiedBranching mode m, SafeBitCast e a b m) =>+  UnifiedSafeBitCast mode e a b m+  where+  withBaseSafeBitCast r = r++instance+  ( MonadError NotRepresentableFPError m,+    UnifiedBranching mode m,+    ValidFP eb sb,+    KnownNat n,+    1 <= n,+    n ~ (eb + sb)+  ) =>+  UnifiedSafeBitCast mode NotRepresentableFPError (FP eb sb) (WordN n) m+  where+  withBaseSafeBitCast r =+    withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r)++instance+  ( MonadError NotRepresentableFPError m,+    UnifiedBranching mode m,+    ValidFP eb sb,+    KnownNat n,+    1 <= n,+    n ~ (eb + sb)+  ) =>+  UnifiedSafeBitCast mode NotRepresentableFPError (FP eb sb) (IntN n) m+  where+  withBaseSafeBitCast r =+    withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r)++instance+  ( MonadError NotRepresentableFPError m,+    UnifiedBranching 'S m,+    ValidFP eb sb,+    KnownNat n,+    1 <= n,+    n ~ (eb + sb)+  ) =>+  UnifiedSafeBitCast 'S NotRepresentableFPError (SymFP eb sb) (SymWordN n) m+  where+  withBaseSafeBitCast r = withBaseBranching @'S @m r++instance+  ( MonadError NotRepresentableFPError m,+    UnifiedBranching 'S m,+    ValidFP eb sb,+    KnownNat n,+    1 <= n,+    n ~ (eb + sb)+  ) =>+  UnifiedSafeBitCast 'S NotRepresentableFPError (SymFP eb sb) (SymIntN n) m+  where+  withBaseSafeBitCast r = withBaseBranching @'S @m r
+ src/Grisette/Internal/Unified/Class/UnifiedSafeDiv.hs view
@@ -0,0 +1,265 @@+{-# 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.Internal.Unified.Class.UnifiedSafeDiv+-- 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.Unified.Class.UnifiedSafeDiv+  ( safeDiv,+    safeMod,+    safeDivMod,+    safeQuot,+    safeRem,+    safeQuotRem,+    UnifiedSafeDiv (..),+  )+where++import Control.Monad.Error.Class (MonadError)+import GHC.TypeLits (KnownNat, type (<=))+import Grisette.Internal.Core.Data.Class.SafeDiv+  ( ArithException,+    SafeDiv,+  )+import qualified Grisette.Internal.Core.Data.Class.SafeDiv+import Grisette.Internal.SymPrim.BV (IntN, WordN)+import Grisette.Internal.SymPrim.SomeBV+  ( SomeBVException,+    SomeIntN,+    SomeSymIntN,+    SomeSymWordN,+    SomeWordN,+  )+import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN)+import Grisette.Internal.SymPrim.SymInteger (SymInteger)+import Grisette.Internal.Unified.Class.UnifiedSimpleMergeable+  ( UnifiedBranching (withBaseBranching),+  )+import Grisette.Internal.Unified.EvalModeTag+  ( EvalModeTag (S),+  )+import Grisette.Internal.Unified.Util (withMode)++-- | Unified `Grisette.Internal.Core.Data.Class.SafeDiv.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, UnifiedSafeDiv mode e a m) =>+  a ->+  a ->+  m a+safeDiv a b =+  withBaseSafeDiv @mode @e @a @m $+    Grisette.Internal.Core.Data.Class.SafeDiv.safeDiv a b+{-# INLINE safeDiv #-}++-- | Unified `Grisette.Internal.Core.Data.Class.SafeDiv.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, UnifiedSafeDiv mode e a m) =>+  a ->+  a ->+  m a+safeMod a b =+  withBaseSafeDiv @mode @e @a @m $+    Grisette.Internal.Core.Data.Class.SafeDiv.safeMod a b+{-# INLINE safeMod #-}++-- | Unified `Grisette.Internal.Core.Data.Class.SafeDiv.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, UnifiedSafeDiv mode e a m) =>+  a ->+  a ->+  m (a, a)+safeDivMod a b =+  withBaseSafeDiv @mode @e @a @m $+    Grisette.Internal.Core.Data.Class.SafeDiv.safeDivMod a b+{-# INLINE safeDivMod #-}++-- | Unified `Grisette.Internal.Core.Data.Class.SafeDiv.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, UnifiedSafeDiv mode e a m) =>+  a ->+  a ->+  m a+safeQuot a b =+  withBaseSafeDiv @mode @e @a @m $+    Grisette.Internal.Core.Data.Class.SafeDiv.safeQuot a b+{-# INLINE safeQuot #-}++-- | Unified `Grisette.Internal.Core.Data.Class.SafeDiv.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, UnifiedSafeDiv mode e a m) =>+  a ->+  a ->+  m a+safeRem a b =+  withBaseSafeDiv @mode @e @a @m $+    Grisette.Internal.Core.Data.Class.SafeDiv.safeRem a b+{-# INLINE safeRem #-}++-- | Unified `Grisette.Internal.Core.Data.Class.SafeDiv.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, UnifiedSafeDiv mode e a m) =>+  a ->+  a ->+  m (a, a)+safeQuotRem a b =+  withBaseSafeDiv @mode @e @a @m $+    Grisette.Internal.Core.Data.Class.SafeDiv.safeQuotRem a b+{-# INLINE safeQuotRem #-}++-- | A class that provides unified division operations.+--+-- We use this type class to help resolve the constraints for `SafeDiv`.+class UnifiedSafeDiv (mode :: EvalModeTag) e a m where+  withBaseSafeDiv :: ((SafeDiv e a m) => r) -> r++instance+  {-# INCOHERENT #-}+  (UnifiedBranching mode m, SafeDiv e a m) =>+  UnifiedSafeDiv mode e a m+  where+  withBaseSafeDiv r = r++instance+  (MonadError ArithException m, UnifiedBranching mode m) =>+  UnifiedSafeDiv mode ArithException Integer m+  where+  withBaseSafeDiv r =+    withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r)++instance+  (MonadError ArithException m, UnifiedBranching 'S m) =>+  UnifiedSafeDiv 'S ArithException SymInteger m+  where+  withBaseSafeDiv r = withBaseBranching @'S @m r++instance+  (MonadError ArithException m, UnifiedBranching mode m, KnownNat n, 1 <= n) =>+  UnifiedSafeDiv mode ArithException (IntN n) m+  where+  withBaseSafeDiv r =+    withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r)++instance+  (MonadError ArithException m, UnifiedBranching 'S m, KnownNat n, 1 <= n) =>+  UnifiedSafeDiv 'S ArithException (SymIntN n) m+  where+  withBaseSafeDiv r = withBaseBranching @'S @m r++instance+  (MonadError ArithException m, UnifiedBranching mode m, KnownNat n, 1 <= n) =>+  UnifiedSafeDiv mode ArithException (WordN n) m+  where+  withBaseSafeDiv r =+    withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r)++instance+  (MonadError ArithException m, UnifiedBranching 'S m, KnownNat n, 1 <= n) =>+  UnifiedSafeDiv 'S ArithException (SymWordN n) m+  where+  withBaseSafeDiv r = withBaseBranching @'S @m r++instance+  ( MonadError (Either SomeBVException ArithException) m,+    UnifiedBranching mode m+  ) =>+  UnifiedSafeDiv+    mode+    (Either SomeBVException ArithException)+    SomeIntN+    m+  where+  withBaseSafeDiv r =+    withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r)++instance+  ( MonadError (Either SomeBVException ArithException) m,+    UnifiedBranching 'S m+  ) =>+  UnifiedSafeDiv+    'S+    (Either SomeBVException ArithException)+    SomeSymIntN+    m+  where+  withBaseSafeDiv r = withBaseBranching @'S @m r++instance+  ( MonadError (Either SomeBVException ArithException) m,+    UnifiedBranching mode m+  ) =>+  UnifiedSafeDiv+    mode+    (Either SomeBVException ArithException)+    SomeWordN+    m+  where+  withBaseSafeDiv r =+    withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r)++instance+  ( MonadError (Either SomeBVException ArithException) m,+    UnifiedBranching 'S m+  ) =>+  UnifiedSafeDiv+    'S+    (Either SomeBVException ArithException)+    SomeSymWordN+    m+  where+  withBaseSafeDiv r = withBaseBranching @'S @m r
+ src/Grisette/Internal/Unified/Class/UnifiedSafeFdiv.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Eta reduce" #-}++-- |+-- Module      :   Grisette.Internal.Unified.Class.UnifiedSafeFdiv+-- 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.Unified.Class.UnifiedSafeFdiv+  ( safeFdiv,+    UnifiedSafeFdiv (..),+  )+where++import Control.Exception (ArithException)+import Control.Monad.Error.Class (MonadError)+import Grisette.Internal.Core.Data.Class.SafeFdiv (SafeFdiv)+import qualified Grisette.Internal.Core.Data.Class.SafeFdiv+import Grisette.Internal.SymPrim.AlgReal (AlgReal)+import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal)+import Grisette.Internal.Unified.Class.UnifiedSimpleMergeable+  ( UnifiedBranching (withBaseBranching),+  )+import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (S))+import Grisette.Internal.Unified.Util (withMode)++-- | Unified `Grisette.Internal.Core.Data.Class.SafeFdiv.safeFdiv` operation.+--+-- This function isn't able to infer the mode, so you need to provide the mode+-- explicitly. For example:+--+-- > safeFdiv @mode a b+safeFdiv ::+  forall mode e a m.+  (MonadError e m, UnifiedSafeFdiv mode e a m) =>+  a ->+  a ->+  m a+safeFdiv a b =+  withBaseUnifiedSafeFdiv @mode @e @a @m $+    Grisette.Internal.Core.Data.Class.SafeFdiv.safeFdiv a b+{-# INLINE safeFdiv #-}++-- | A class that provides unified floating division operations.+--+-- We use this type class to help resolve the constraints for `SafeFdiv`.+class UnifiedSafeFdiv (mode :: EvalModeTag) e a m where+  withBaseUnifiedSafeFdiv :: ((SafeFdiv e a m) => r) -> r++instance+  {-# INCOHERENT #-}+  (UnifiedBranching mode m, SafeFdiv e a m) =>+  UnifiedSafeFdiv mode e a m+  where+  withBaseUnifiedSafeFdiv r = r++instance+  (MonadError ArithException m, UnifiedBranching mode m) =>+  UnifiedSafeFdiv mode ArithException AlgReal m+  where+  withBaseUnifiedSafeFdiv r =+    withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r)++instance+  (MonadError ArithException m, UnifiedBranching 'S m) =>+  UnifiedSafeFdiv 'S ArithException SymAlgReal m+  where+  withBaseUnifiedSafeFdiv r = withBaseBranching @'S @m r
+ src/Grisette/Internal/Unified/Class/UnifiedSafeFromFP.hs view
@@ -0,0 +1,213 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Eta reduce" #-}++-- |+-- Module      :   Grisette.Internal.Unified.Class.UnifiedSafeFromFP+-- 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.Unified.Class.UnifiedSafeFromFP+  ( UnifiedSafeFromFP (..),+    safeFromFP,+  )+where++import Control.Monad.Error.Class (MonadError)+import GHC.TypeNats (KnownNat, type (<=))+import Grisette.Internal.Core.Data.Class.SafeFromFP (SafeFromFP)+import qualified Grisette.Internal.Core.Data.Class.SafeFromFP as SafeFromFP+import Grisette.Internal.SymPrim.AlgReal (AlgReal)+import Grisette.Internal.SymPrim.BV (IntN, WordN)+import Grisette.Internal.SymPrim.FP+  ( FP,+    FPRoundingMode,+    NotRepresentableFPError,+    ValidFP,+  )+import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal)+import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN)+import Grisette.Internal.SymPrim.SymFP (SymFP, SymFPRoundingMode)+import Grisette.Internal.SymPrim.SymInteger (SymInteger)+import Grisette.Internal.Unified.Class.UnifiedSimpleMergeable+  ( UnifiedBranching (withBaseBranching),+  )+import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (S))+import Grisette.Internal.Unified.Util (withMode)++-- | Unified `Grisette.Internal.Core.Data.Class.SafeFromFP.safeFromFP`+-- operation.+--+-- This function isn't able to infer the mode, so you need to provide the mode+-- explicitly. For example:+--+-- > safeFromFP @mode mode fp+safeFromFP ::+  forall mode e a fp fprd m.+  (UnifiedSafeFromFP mode e a fp fprd m, MonadError e m) =>+  fprd ->+  fp ->+  m a+safeFromFP rd fp =+  withBaseSafeFromFP @mode @e @a @fp @fprd @m $+    SafeFromFP.safeFromFP rd fp++-- | A class that provides unified safe conversion from floating points.+--+-- We use this type class to help resolve the constraints for `SafeFromFP`.+class UnifiedSafeFromFP (mode :: EvalModeTag) e a fp fprd m where+  withBaseSafeFromFP :: ((SafeFromFP e a fp fprd m) => r) -> r++instance+  {-# INCOHERENT #-}+  (UnifiedBranching mode m, SafeFromFP e a fp fprd m) =>+  UnifiedSafeFromFP mode e a fp fprd m+  where+  withBaseSafeFromFP r = r++instance+  ( MonadError NotRepresentableFPError m,+    UnifiedBranching mode m,+    ValidFP eb sb+  ) =>+  UnifiedSafeFromFP+    mode+    NotRepresentableFPError+    Integer+    (FP eb sb)+    FPRoundingMode+    m+  where+  withBaseSafeFromFP r =+    withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r)++instance+  ( MonadError NotRepresentableFPError m,+    UnifiedBranching mode m,+    ValidFP eb sb+  ) =>+  UnifiedSafeFromFP+    mode+    NotRepresentableFPError+    AlgReal+    (FP eb sb)+    FPRoundingMode+    m+  where+  withBaseSafeFromFP r =+    withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r)++instance+  ( MonadError NotRepresentableFPError m,+    UnifiedBranching mode m,+    ValidFP eb sb,+    KnownNat n,+    1 <= n+  ) =>+  UnifiedSafeFromFP+    mode+    NotRepresentableFPError+    (IntN n)+    (FP eb sb)+    FPRoundingMode+    m+  where+  withBaseSafeFromFP r =+    withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r)++instance+  ( MonadError NotRepresentableFPError m,+    UnifiedBranching mode m,+    ValidFP eb sb,+    KnownNat n,+    1 <= n+  ) =>+  UnifiedSafeFromFP+    mode+    NotRepresentableFPError+    (WordN n)+    (FP eb sb)+    FPRoundingMode+    m+  where+  withBaseSafeFromFP r =+    withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r)++instance+  ( MonadError NotRepresentableFPError m,+    UnifiedBranching 'S m,+    ValidFP eb sb+  ) =>+  UnifiedSafeFromFP+    'S+    NotRepresentableFPError+    SymInteger+    (SymFP eb sb)+    SymFPRoundingMode+    m+  where+  withBaseSafeFromFP r = withBaseBranching @'S @m r++instance+  ( MonadError NotRepresentableFPError m,+    UnifiedBranching 'S m,+    ValidFP eb sb+  ) =>+  UnifiedSafeFromFP+    'S+    NotRepresentableFPError+    SymAlgReal+    (SymFP eb sb)+    SymFPRoundingMode+    m+  where+  withBaseSafeFromFP r = withBaseBranching @'S @m r++instance+  ( MonadError NotRepresentableFPError m,+    UnifiedBranching 'S m,+    ValidFP eb sb,+    KnownNat n,+    1 <= n+  ) =>+  UnifiedSafeFromFP+    'S+    NotRepresentableFPError+    (SymIntN n)+    (SymFP eb sb)+    SymFPRoundingMode+    m+  where+  withBaseSafeFromFP r = withBaseBranching @'S @m r++instance+  ( MonadError NotRepresentableFPError m,+    UnifiedBranching 'S m,+    ValidFP eb sb,+    KnownNat n,+    1 <= n+  ) =>+  UnifiedSafeFromFP+    'S+    NotRepresentableFPError+    (SymWordN n)+    (SymFP eb sb)+    SymFPRoundingMode+    m+  where+  withBaseSafeFromFP r = withBaseBranching @'S @m r
+ src/Grisette/Internal/Unified/Class/UnifiedSafeLinearArith.hs view
@@ -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.Internal.Unified.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.Internal.Unified.Class.UnifiedSafeLinearArith+  ( safeAdd,+    safeNeg,+    safeSub,+    UnifiedSafeLinearArith (..),+  )+where++import Control.Monad.Error.Class (MonadError)+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 (IntN, WordN)+import Grisette.Internal.SymPrim.SomeBV+  ( SomeBVException,+    SomeIntN,+    SomeSymIntN,+    SomeSymWordN,+    SomeWordN,+  )+import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN)+import Grisette.Internal.SymPrim.SymInteger (SymInteger)+import Grisette.Internal.Unified.Class.UnifiedSimpleMergeable+  ( UnifiedBranching (withBaseBranching),+  )+import Grisette.Internal.Unified.EvalModeTag+  ( EvalModeTag (S),+  )+import Grisette.Internal.Unified.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+  (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 'S m) =>+  UnifiedSafeLinearArith 'S ArithException SymInteger m+  where+  withBaseSafeLinearArith r = withBaseBranching @'S @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 'S m, KnownNat n, 1 <= n) =>+  UnifiedSafeLinearArith 'S ArithException (SymIntN n) m+  where+  withBaseSafeLinearArith r = withBaseBranching @'S @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 'S m, KnownNat n, 1 <= n) =>+  UnifiedSafeLinearArith 'S ArithException (SymWordN n) m+  where+  withBaseSafeLinearArith r = withBaseBranching @'S @m r++instance+  ( MonadError (Either SomeBVException ArithException) m,+    UnifiedBranching mode m+  ) =>+  UnifiedSafeLinearArith+    mode+    (Either SomeBVException ArithException)+    SomeIntN+    m+  where+  withBaseSafeLinearArith r =+    withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r)++instance+  ( MonadError (Either SomeBVException ArithException) m,+    UnifiedBranching 'S m+  ) =>+  UnifiedSafeLinearArith+    'S+    (Either SomeBVException ArithException)+    SomeSymIntN+    m+  where+  withBaseSafeLinearArith r = withBaseBranching @'S @m r++instance+  ( MonadError (Either SomeBVException ArithException) m,+    UnifiedBranching mode m+  ) =>+  UnifiedSafeLinearArith+    mode+    (Either SomeBVException ArithException)+    SomeWordN+    m+  where+  withBaseSafeLinearArith r =+    withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r)++instance+  ( MonadError (Either SomeBVException ArithException) m,+    UnifiedBranching 'S m+  ) =>+  UnifiedSafeLinearArith+    'S+    (Either SomeBVException ArithException)+    SomeSymWordN+    m+  where+  withBaseSafeLinearArith r = withBaseBranching @'S @m r
+ src/Grisette/Internal/Unified/Class/UnifiedSafeSymRotate.hs view
@@ -0,0 +1,180 @@+{-# 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.Internal.Unified.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.Internal.Unified.Class.UnifiedSafeSymRotate+  ( safeSymRotateL,+    safeSymRotateR,+    UnifiedSafeSymRotate (..),+  )+where++import Control.Exception (ArithException)+import Control.Monad.Error.Class (MonadError)+import GHC.TypeLits (KnownNat, type (<=))+import Grisette.Internal.Core.Data.Class.SafeSymRotate (SafeSymRotate)+import qualified Grisette.Internal.Core.Data.Class.SafeSymRotate+import Grisette.Internal.SymPrim.BV (IntN, WordN)+import Grisette.Internal.SymPrim.SomeBV+  ( SomeBVException,+    SomeIntN,+    SomeSymIntN,+    SomeSymWordN,+    SomeWordN,+  )+import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN)+import Grisette.Internal.Unified.Class.UnifiedSimpleMergeable+  ( UnifiedBranching (withBaseBranching),+  )+import Grisette.Internal.Unified.EvalModeTag+  ( EvalModeTag (S),+  )+import Grisette.Internal.Unified.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 'S m, KnownNat n, 1 <= n) =>+  UnifiedSafeSymRotate 'S ArithException (SymIntN n) m+  where+  withBaseSafeSymRotate r = withBaseBranching @'S @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 'S m, KnownNat n, 1 <= n) =>+  UnifiedSafeSymRotate 'S ArithException (SymWordN n) m+  where+  withBaseSafeSymRotate r = withBaseBranching @'S @m r++instance+  ( MonadError (Either SomeBVException ArithException) m,+    UnifiedBranching mode m+  ) =>+  UnifiedSafeSymRotate+    mode+    (Either SomeBVException ArithException)+    SomeIntN+    m+  where+  withBaseSafeSymRotate r =+    withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r)++instance+  ( MonadError (Either SomeBVException ArithException) m,+    UnifiedBranching 'S m+  ) =>+  UnifiedSafeSymRotate+    'S+    (Either SomeBVException ArithException)+    SomeSymIntN+    m+  where+  withBaseSafeSymRotate r = withBaseBranching @'S @m r++instance+  ( MonadError (Either SomeBVException ArithException) m,+    UnifiedBranching mode m+  ) =>+  UnifiedSafeSymRotate+    mode+    (Either SomeBVException ArithException)+    SomeWordN+    m+  where+  withBaseSafeSymRotate r =+    withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r)++instance+  ( MonadError (Either SomeBVException ArithException) m,+    UnifiedBranching 'S m+  ) =>+  UnifiedSafeSymRotate+    'S+    (Either SomeBVException ArithException)+    SomeSymWordN+    m+  where+  withBaseSafeSymRotate r = withBaseBranching @'S @m r
+ src/Grisette/Internal/Unified/Class/UnifiedSafeSymShift.hs view
@@ -0,0 +1,224 @@+{-# 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.Internal.Unified.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.Internal.Unified.Class.UnifiedSafeSymShift+  ( safeSymShiftL,+    safeSymShiftR,+    safeSymStrictShiftL,+    safeSymStrictShiftR,+    UnifiedSafeSymShift (..),+  )+where++import Control.Exception (ArithException)+import Control.Monad.Error.Class (MonadError)+import GHC.TypeLits (KnownNat, type (<=))+import Grisette.Internal.Core.Data.Class.SafeSymShift (SafeSymShift)+import qualified Grisette.Internal.Core.Data.Class.SafeSymShift+import Grisette.Internal.SymPrim.BV (IntN, WordN)+import Grisette.Internal.SymPrim.SomeBV+  ( SomeBVException,+    SomeIntN,+    SomeSymIntN,+    SomeSymWordN,+    SomeWordN,+  )+import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN)+import Grisette.Internal.Unified.Class.UnifiedSimpleMergeable+  ( UnifiedBranching (withBaseBranching),+  )+import Grisette.Internal.Unified.EvalModeTag+  ( EvalModeTag (S),+  )+import Grisette.Internal.Unified.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 'S m, KnownNat n, 1 <= n) =>+  UnifiedSafeSymShift 'S ArithException (SymIntN n) m+  where+  withBaseSafeSymShift r = withBaseBranching @'S @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 'S m, KnownNat n, 1 <= n) =>+  UnifiedSafeSymShift 'S ArithException (SymWordN n) m+  where+  withBaseSafeSymShift r = withBaseBranching @'S @m r++instance+  ( MonadError (Either SomeBVException ArithException) m,+    UnifiedBranching mode m+  ) =>+  UnifiedSafeSymShift+    mode+    (Either SomeBVException ArithException)+    SomeIntN+    m+  where+  withBaseSafeSymShift r =+    withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r)++instance+  ( MonadError (Either SomeBVException ArithException) m,+    UnifiedBranching 'S m+  ) =>+  UnifiedSafeSymShift+    'S+    (Either SomeBVException ArithException)+    SomeSymIntN+    m+  where+  withBaseSafeSymShift r = withBaseBranching @'S @m r++instance+  ( MonadError (Either SomeBVException ArithException) m,+    UnifiedBranching mode m+  ) =>+  UnifiedSafeSymShift+    mode+    (Either SomeBVException ArithException)+    SomeWordN+    m+  where+  withBaseSafeSymShift r =+    withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r)++instance+  ( MonadError (Either SomeBVException ArithException) m,+    UnifiedBranching 'S m+  ) =>+  UnifiedSafeSymShift+    'S+    (Either SomeBVException ArithException)+    SomeSymWordN+    m+  where+  withBaseSafeSymShift r = withBaseBranching @'S @m r
+ src/Grisette/Internal/Unified/Class/UnifiedSimpleMergeable.hs view
@@ -0,0 +1,28 @@+{-# OPTIONS_GHC -Wno-missing-import-lists #-}++-- |+-- Module      :   Grisette.Internal.Unified.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.Internal.Unified.Class.UnifiedSimpleMergeable+  ( UnifiedBranching (..),+    UnifiedSimpleMergeable (..),+    UnifiedSimpleMergeable1 (..),+    UnifiedSimpleMergeable2 (..),+    mrgIf,+    liftUnion,+    mrgIte,+    mrgIte1,+    liftMrgIte,+    mrgIte2,+    liftMrgIte2,+    simpleMerge,+  )+where++import Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSimpleMergeable+import Grisette.Internal.Internal.Impl.Unified.Class.UnifiedSimpleMergeable
+ src/Grisette/Internal/Unified/Class/UnifiedSolvable.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}++-- |+-- Module      :   Grisette.Internal.Unified.Class.UnifiedSolvable+-- 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.Unified.Class.UnifiedSolvable+  ( UnifiedSolvable (withBaseSolvable),+    con,+    pattern Con,+    conView,+  )+where++import Data.Type.Bool (If)+import GHC.TypeLits (KnownNat, type (<=))+import Grisette.Internal.Core.Data.Class.Solvable (Solvable)+import qualified Grisette.Internal.Core.Data.Class.Solvable as Grisette+import Grisette.Internal.SymPrim.AlgReal (AlgReal)+import Grisette.Internal.SymPrim.BV (IntN, WordN)+import Grisette.Internal.SymPrim.FP (FP, ValidFP)+import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal)+import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN)+import Grisette.Internal.SymPrim.SymBool (SymBool)+import Grisette.Internal.SymPrim.SymFP (SymFP)+import Grisette.Internal.SymPrim.SymInteger (SymInteger)+import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C, S), IsConMode)+import Grisette.Internal.Unified.Util (DecideEvalMode, withMode)++-- $setup+-- >>> import Grisette.Core (ssym)++-- | Wrap a concrete value in a symbolic value.+--+-- >>> con True :: Bool+-- True+--+-- >>> con True :: SymBool+-- true+con ::+  forall mode a con. (DecideEvalMode mode, UnifiedSolvable mode a con) => con -> a+con v =+  withMode @mode+    (withBaseSolvable @mode @a @con v)+    (withBaseSolvable @mode @a @con $ Grisette.con v)++-- | Extract the concrete value from a symbolic value.+--+-- >>> conView (con True :: SymBool)+-- Just True+--+-- >>> conView (ssym "a" :: SymBool)+-- Nothing+--+-- >>> conView True+-- Just True+conView ::+  forall mode a con.+  (DecideEvalMode mode, UnifiedSolvable mode a con) =>+  a ->+  Maybe con+conView v =+  withMode @mode+    (withBaseSolvable @mode @a @con $ Just v)+    (withBaseSolvable @mode @a @con $ Grisette.conView v)++-- | A pattern synonym for extracting the concrete value from a symbolic value.+--+-- >>> case con True :: SymBool of Con v -> v+-- True+--+-- >>> case ssym "a" :: SymBool of Con v -> Just v; _ -> Nothing+-- Nothing+pattern Con :: (DecideEvalMode mode, UnifiedSolvable mode a con) => con -> a+pattern Con v <-+  (conView -> Just v)+  where+    Con v = con v++-- | A class that provides the ability to extract/wrap the concrete value+-- from/into a symbolic value.+class UnifiedSolvable mode a con | a -> mode con, con mode -> a where+  withBaseSolvable ::+    ((If (IsConMode mode) (a ~ con) (Solvable con a)) => r) -> r++instance UnifiedSolvable 'C Bool Bool where+  withBaseSolvable r = r++instance UnifiedSolvable 'S SymBool Bool where+  withBaseSolvable r = r++instance UnifiedSolvable 'C Integer Integer where+  withBaseSolvable r = r++instance UnifiedSolvable 'S SymInteger Integer where+  withBaseSolvable r = r++instance UnifiedSolvable 'C AlgReal AlgReal where+  withBaseSolvable r = r++instance UnifiedSolvable 'S SymAlgReal AlgReal where+  withBaseSolvable r = r++instance (KnownNat n, 1 <= n) => UnifiedSolvable 'C (WordN n) (WordN n) where+  withBaseSolvable r = r++instance (KnownNat n, 1 <= n) => UnifiedSolvable 'S (SymWordN n) (WordN n) where+  withBaseSolvable r = r++instance (KnownNat n, 1 <= n) => UnifiedSolvable 'C (IntN n) (IntN n) where+  withBaseSolvable r = r++instance (KnownNat n, 1 <= n) => UnifiedSolvable 'S (SymIntN n) (IntN n) where+  withBaseSolvable r = r++instance (ValidFP eb sb) => UnifiedSolvable 'C (FP eb sb) (FP eb sb) where+  withBaseSolvable r = r++instance (ValidFP eb sb) => UnifiedSolvable 'S (SymFP eb sb) (FP eb sb) where+  withBaseSolvable r = r
+ src/Grisette/Internal/Unified/Class/UnifiedSymEq.hs view
@@ -0,0 +1,26 @@+{-# OPTIONS_GHC -Wno-missing-import-lists #-}++-- |+-- Module      :   Grisette.Internal.Unified.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.Internal.Unified.Class.UnifiedSymEq+  ( UnifiedSymEq (..),+    UnifiedSymEq1 (..),+    UnifiedSymEq2 (..),+    (.==),+    (./=),+    symDistinct,+    liftSymEq,+    symEq1,+    liftSymEq2,+    symEq2,+  )+where++import Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSymEq+import Grisette.Internal.Internal.Impl.Unified.Class.UnifiedSymEq
+ src/Grisette/Internal/Unified/Class/UnifiedSymOrd.hs view
@@ -0,0 +1,27 @@+{-# OPTIONS_GHC -Wno-missing-import-lists #-}++-- |+-- Module      :   Grisette.Internal.Unified.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.Internal.Unified.Class.UnifiedSymOrd+  ( UnifiedSymOrd (..),+    UnifiedSymOrd1 (..),+    UnifiedSymOrd2 (..),+    (.<=),+    (.<),+    (.>=),+    (.>),+    symMax,+    symMin,+    mrgMax,+    mrgMin,+  )+where++import Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSymOrd+import Grisette.Internal.Internal.Impl.Unified.Class.UnifiedSymOrd
+ src/Grisette/Internal/Unified/Class/UnionViewMode.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE KindSignatures #-}++module Grisette.Internal.Unified.Class.UnionViewMode (UnionViewMode) where++import Control.Monad.Identity (Identity)+import Data.Kind (Type)+import Grisette.Internal.Internal.Decl.Core.Control.Monad.Union (Union)+import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C, S))++-- | This class is used to determine the type of the Boolean used in the+-- 'Grisette.Core.UnionView' class.+--+-- For 'Identity', we use 'Bool' as the Boolean type, and this ensures that+-- the 'Grisette.Core.ifView' function will return 'Nothing'.+--+-- For 'Union', we use 'SymBool' as the Boolean type, and 'Grisette.Core.ifView'+-- function can return 'Nothing' or 'Just'.+class UnionViewMode (mode :: EvalModeTag) (u :: Type -> Type) | u -> mode++instance UnionViewMode 'C Identity++instance UnionViewMode 'S Union
+ src/Grisette/Internal/Unified/EvalMode.hs view
@@ -0,0 +1,24 @@+{-# OPTIONS_GHC -Wno-missing-import-lists #-}++-- |+-- Module      :   Grisette.Internal.Unified.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.Internal.Unified.EvalMode+  ( EvalModeBase,+    EvalModeInteger,+    EvalModeBV,+    EvalModeFP,+    EvalModeAlgReal,+    EvalModeAll,+    MonadEvalModeAll,+    genEvalMode,+  )+where++import Grisette.Internal.Internal.Decl.Unified.EvalMode+import Grisette.Internal.Internal.Impl.Unified.EvalMode ()
+ src/Grisette/Internal/Unified/EvalModeTag.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeFamilyDependencies #-}++-- |+-- Module      :   Grisette.Internal.Unified.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.Internal.Unified.EvalModeTag+  ( EvalModeTag (..),+    IsConMode,+  )+where++import Language.Haskell.TH.Syntax (Lift)++-- | Evaluation mode for unified types. 'C' means concrete evaluation, 'S'+-- means symbolic evaluation.+data EvalModeTag = C | S deriving (Lift, Show, Eq)++-- | Type family to check if a mode is 'C'.+type family IsConMode (mode :: EvalModeTag) = (r :: Bool) | r -> mode where+  IsConMode 'C = 'True+  IsConMode 'S = 'False
+ src/Grisette/Internal/Unified/FPFPConversion.hs view
@@ -0,0 +1,18 @@+{-# OPTIONS_GHC -Wno-missing-import-lists #-}++-- |+-- Module      :   Grisette.Internal.Unified.FPFPConversion+-- 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.Unified.FPFPConversion+  ( UnifiedFPFPConversion,+    AllUnifiedFPFPConversion,+  )+where++import Grisette.Internal.Internal.Decl.Unified.FPFPConversion+import Grisette.Internal.Internal.Impl.Unified.FPFPConversion ()
+ src/Grisette/Internal/Unified/Theories.hs view
@@ -0,0 +1,28 @@+-- |+-- Module      :   Grisette.Internal.Unified.Theories+-- 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.Unified.Theories (TheoryToUnify (..), isUFun) where++-- | This data type is used to represent the theories that is unified.+--+-- The 'UFun' constructor is used to represent a specific uninterpreted function+-- type. The type is uncurried.+data TheoryToUnify+  = UBool+  | UIntN+  | UWordN+  | UInteger+  | UAlgReal+  | UFP+  | UFun [TheoryToUnify]+  deriving (Eq, Show)++-- | Check if the theory is a uninterpreted function.+isUFun :: TheoryToUnify -> Bool+isUFun (UFun _) = True+isUFun _ = False
+ src/Grisette/Internal/Unified/UnifiedAlgReal.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators #-}++-- |+-- Module      :   Grisette.Internal.Unified.UnifiedAlgReal+-- 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.Unified.UnifiedAlgReal+  ( UnifiedAlgReal,+    GetAlgReal,+  )+where++import Control.Exception (ArithException)+import Control.Monad.Error.Class (MonadError)+import Grisette.Internal.Core.Data.Class.SafeFdiv (FdivOr)+import Grisette.Internal.SymPrim.AlgReal (AlgReal)+import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal)+import Grisette.Internal.SymPrim.SymPrim (Prim)+import Grisette.Internal.Unified.Class.UnifiedFromIntegral (UnifiedFromIntegral)+import Grisette.Internal.Unified.Class.UnifiedRep+  ( UnifiedConRep (ConType),+    UnifiedSymRep (SymType),+  )+import Grisette.Internal.Unified.Class.UnifiedSafeFdiv (UnifiedSafeFdiv)+import Grisette.Internal.Unified.Class.UnifiedSimpleMergeable (UnifiedBranching)+import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C, S))+import Grisette.Internal.Unified.UnifiedInteger (GetInteger)+import Grisette.Internal.Unified.UnifiedPrim (UnifiedBasicPrim)++class+  ( r ~ GetAlgReal mode,+    UnifiedConRep r,+    UnifiedSymRep r,+    ConType r ~ AlgReal,+    SymType r ~ SymAlgReal,+    UnifiedBasicPrim mode r,+    Prim r,+    Num r,+    Fractional r,+    FdivOr r,+    forall m.+    (UnifiedBranching mode m, MonadError ArithException m) =>+    UnifiedSafeFdiv mode ArithException r m,+    UnifiedFromIntegral mode (GetInteger mode) r+  ) =>+  UnifiedAlgRealImpl (mode :: EvalModeTag) r+    | mode -> r+  where+  -- | Get a unified algebraic real type. Resolves to 'AlgReal' in 'C' mode,+  -- and 'SymAlgReal' in 'S' mode.+  --+  -- 'Floating', 'Grisette.LogBaseOr' and 'Grisette.SafeLogBase' for+  -- 'SymAlgReal' are not provided as they are not available for 'AlgReal'.+  type GetAlgReal mode = real | real -> mode++instance UnifiedAlgRealImpl 'C AlgReal where+  type GetAlgReal 'C = AlgReal++instance UnifiedAlgRealImpl 'S SymAlgReal where+  type GetAlgReal 'S = SymAlgReal++-- | Evaluation mode with unified 'AlgReal' type.+class+  (UnifiedAlgRealImpl mode (GetAlgReal mode)) =>+  UnifiedAlgReal (mode :: EvalModeTag)++instance UnifiedAlgReal 'C++instance UnifiedAlgReal 'S
+ src/Grisette/Internal/Unified/UnifiedBV.hs view
@@ -0,0 +1,24 @@+{-# OPTIONS_GHC -fno-warn-missing-import-lists #-}++-- |+-- Module      :   Grisette.Internal.Unified.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.Internal.Unified.UnifiedBV+  ( UnifiedBV,+    UnifiedBVImpl (GetIntN, GetWordN),+    AllUnifiedBV,+    SafeUnifiedBV,+    SafeUnifiedSomeBV,+    GetSomeWordN,+    GetSomeIntN,+    SomeBVPair,+  )+where++import Grisette.Internal.Internal.Decl.Unified.UnifiedBV+import Grisette.Internal.Internal.Impl.Unified.UnifiedBV ()
+ src/Grisette/Internal/Unified/UnifiedBool.hs view
@@ -0,0 +1,14 @@+{-# OPTIONS_GHC -fno-warn-missing-import-lists #-}++-- |+-- Module      :   Grisette.Internal.Unified.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.Internal.Unified.UnifiedBool (UnifiedBool (..)) where++import Grisette.Internal.Internal.Decl.Unified.UnifiedBool+import Grisette.Internal.Internal.Impl.Unified.UnifiedBool ()
+ src/Grisette/Internal/Unified/UnifiedData.hs view
@@ -0,0 +1,315 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.Unified.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.Internal.Unified.UnifiedData+  ( UnifiedDataBase,+    GetData,+    BaseMonad,+    wrapData,+    extractData,+    UnifiedData,+    AllUnifiedData,+    symCompare,+    liftSymCompare,+    symCompare1,+    liftSymCompare2,+    symCompare2,+  )+where++import Control.DeepSeq (NFData)+import Control.Monad.Identity (Identity (Identity, runIdentity))+import Data.Bytes.Serial (Serial)+import Data.Functor.Classes (Ord1 (liftCompare), Ord2 (liftCompare2), compare1, compare2)+import Data.Hashable (Hashable)+import Data.Kind (Type)+import Grisette.Internal.Core.Data.Class.AsKey (KeyEq, KeyHashable)+import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp)+import Grisette.Internal.Core.Data.Class.LogicalOp (LogicalOp)+import Grisette.Internal.Core.Data.Class.UnionView (UnionView)+import Grisette.Internal.Internal.Decl.Core.Control.Monad.Union+  ( Union,+  )+import Grisette.Internal.Internal.Decl.Core.Data.Class.EvalSym+  ( EvalSym,+  )+import Grisette.Internal.Internal.Decl.Core.Data.Class.ExtractSym+  ( ExtractSym,+  )+import Grisette.Internal.Internal.Decl.Core.Data.Class.Mergeable+  ( Mergeable,+  )+import Grisette.Internal.Internal.Decl.Core.Data.Class.PPrint+  ( PPrint,+  )+import Grisette.Internal.Internal.Decl.Core.Data.Class.SubstSym+  ( SubstSym,+  )+import Grisette.Internal.Internal.Decl.Core.Data.Class.SymEq+  ( SymEq,+  )+import Grisette.Internal.Internal.Decl.Core.Data.Class.SymOrd+  ( SymOrd,+  )+import qualified Grisette.Internal.Internal.Decl.Core.Data.Class.SymOrd as SymOrd+import Grisette.Internal.Internal.Decl.Core.Data.Class.ToCon+  ( ToCon,+  )+import Grisette.Internal.Internal.Decl.Core.Data.Class.ToSym+  ( ToSym,+  )+import Grisette.Internal.Internal.Decl.Core.Data.Class.TryMerge+  ( TryMerge,+    mrgSingle,+  )+import Grisette.Internal.Internal.Decl.SymPrim.AllSyms (AllSyms)+import Grisette.Internal.Internal.Decl.Unified.Class.UnifiedITEOp+  ( UnifiedITEOp,+  )+import Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSimpleMergeable+  ( UnifiedBranching (withBaseBranching),+    UnifiedSimpleMergeable,+    UnifiedSimpleMergeable1,+  )+import Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSymEq+  ( UnifiedSymEq,+  )+import Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSymOrd+  ( UnifiedSymOrd (withBaseSymOrd),+    UnifiedSymOrd1 (withBaseSymOrd1),+    UnifiedSymOrd2 (withBaseSymOrd2),+  )+import Grisette.Internal.Internal.Impl.Unified.Class.UnifiedITEOp ()+import Grisette.Internal.Internal.Impl.Unified.Class.UnifiedSimpleMergeable+  ( liftUnion,+  )+import Grisette.Internal.Internal.Impl.Unified.Class.UnifiedSymEq ()+import Grisette.Internal.Internal.Impl.Unified.Class.UnifiedSymOrd ()+import Grisette.Internal.Unified.Class.UnionViewMode (UnionViewMode)+import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C, S))+import Grisette.Internal.Unified.Util (DecideEvalMode, withMode)+import Instances.TH.Lift ()+import Language.Haskell.TH.Syntax (Lift)++-- | A type family that specifies the base monad for the evaluation mode.+--+-- Resolves to 'Identity' for `C` mode, and 'Union' for `S` mode.+type BaseMonad mode = GetData mode++class+  ( UnifiedSimpleMergeable1 mode (GetData mode),+    UnifiedBranching mode (GetData mode),+    UnionView (GetData mode),+    UnionViewMode mode (GetData mode),+    Monad (GetData mode),+    TryMerge (GetData mode)+  ) =>+  UnifiedDataBase mode+  where+  -- | Get a unified data type. Resolves to 'Identity' in 'C' mode, and 'Union'+  -- in 'S' mode.+  type GetData mode = (r :: Type -> Type) | r -> mode++class+  ( u ~ GetData mode v,+    (Mergeable v) => Mergeable u,+    (AllSyms v) => AllSyms u,+    (Eq v) => Eq u,+    (EvalSym v) => EvalSym u,+    (ExtractSym v) => ExtractSym u,+    (ITEOp v, Mergeable v) => ITEOp u,+    (PPrint v) => PPrint u,+    (Eq v) => KeyEq u,+    (Eq v, Hashable v) => KeyHashable u,+    (Lift v) => Lift u,+    (LogicalOp v, Mergeable v) => LogicalOp u,+    (NFData v) => NFData u,+    (Num v, Mergeable v) => Num u,+    (SymEq v) => SymEq u,+    (Show v) => Show u,+    (SymOrd v) => SymOrd u,+    (SubstSym v) => SubstSym u,+    (Serial v, Mergeable v) => Serial u,+    (UnifiedITEOp mode v, Mergeable v) => UnifiedITEOp mode u,+    (Mergeable v) => UnifiedSimpleMergeable mode u,+    (UnifiedSymEq mode v) => UnifiedSymEq mode u,+    (UnifiedSymOrd mode v) => UnifiedSymOrd mode u,+    forall a. (ToSym a v) => ToSym (Identity a) u,+    forall a. (ToSym v a) => ToSym u (Union a),+    forall a. (ToCon v a) => ToCon u (Identity a),+    forall a. (ToCon a v) => ToCon (Union a) u,+    UnifiedDataBase mode+  ) =>+  UnifiedDataImpl (mode :: EvalModeTag) v u+    | u -> mode v+  where+  -- type GetData mode = (r :: Type -> Type) | r -> mode++  -- | Wraps a value into the unified data type.+  wrapData :: (Mergeable v) => v -> u++  -- | Extracts a value from the unified data type.+  extractData :: (Mergeable v, Monad m, UnifiedBranching mode m) => u -> m v++instance UnifiedDataBase 'C where+  type GetData 'C = Identity++instance UnifiedDataImpl 'C v (Identity v) where+  wrapData = Identity+  extractData ::+    forall m. (Mergeable v, Monad m, UnifiedBranching C m) => Identity v -> m v+  extractData = withBaseBranching @'C @m $ return . runIdentity++instance UnifiedDataBase 'S where+  type GetData 'S = Union++instance UnifiedDataImpl 'S v (Union v) where+  wrapData = mrgSingle+  extractData ::+    forall m. (Mergeable v, Monad m, UnifiedBranching S m) => Union v -> m v+  extractData = liftUnion++-- | This class is needed as constraint in user code prior to GHC 9.2.1.+-- See the notes in 'Grisette.Internal.Unified.IsMode.IsMode'.+class (UnifiedDataImpl mode v (GetData mode v)) => UnifiedData mode v++instance (UnifiedDataImpl bool v (GetData bool v)) => UnifiedData bool v++class+  (UnifiedSimpleMergeable 'S (GetData 'S v)) =>+  UnifiedDataSimpleMergeable v++instance (Mergeable v) => UnifiedDataSimpleMergeable v++-- | Evaluation mode with unified data types.+class+  ( forall v. UnifiedData bool v,+    forall v. (Mergeable v) => UnifiedDataSimpleMergeable v+  ) =>+  AllUnifiedData bool++instance+  ( forall v. UnifiedData bool v,+    forall v. (Mergeable v) => UnifiedDataSimpleMergeable v+  ) =>+  AllUnifiedData bool++-- TODO: temporary instance for dependencies++-- | Unified `Grisette.Internal.Core.Data.Class.SymOrd.symCompare`.+symCompare ::+  forall mode a.+  (DecideEvalMode mode, UnifiedSymOrd mode a) =>+  a ->+  a ->+  GetData mode Ordering+symCompare x y =+  withMode @mode+    (withBaseSymOrd @mode @a $ return $ compare x y)+    ( withBaseSymOrd @mode @a $+        SymOrd.symCompare x y+    )+{-# INLINE symCompare #-}++-- | Unified `Grisette.Internal.Core.Data.Class.SymOrd.liftSymCompare`.+liftSymCompare ::+  forall mode f a b.+  (DecideEvalMode mode, UnifiedSymOrd1 mode f) =>+  (a -> b -> GetData mode Ordering) ->+  f a ->+  f b ->+  GetData mode Ordering+liftSymCompare f a b =+  withMode @mode+    ( withBaseSymOrd1 @mode @f $+        return $+          liftCompare (\x y -> runIdentity $ f x y) a b+    )+    ( withBaseSymOrd1 @mode @f $+        SymOrd.liftSymCompare f a b+    )+{-# INLINE liftSymCompare #-}++-- | Unified `Grisette.Internal.Core.Data.Class.SymOrd.symCompare1`.+symCompare1 ::+  forall mode f a.+  (DecideEvalMode mode, UnifiedSymOrd mode a, UnifiedSymOrd1 mode f) =>+  f a ->+  f a ->+  GetData mode Ordering+symCompare1 a b =+  withMode @mode+    (withBaseSymOrd1 @mode @f $ withBaseSymOrd @mode @a $ return $ compare1 a b)+    ( withBaseSymOrd1 @mode @f $+        withBaseSymOrd @mode @a $+          SymOrd.symCompare1 a b+    )+{-# INLINE symCompare1 #-}++-- | Unified `Grisette.Internal.Core.Data.Class.SymOrd.liftSymCompare2`.+liftSymCompare2 ::+  forall mode f a b c d.+  (DecideEvalMode mode, UnifiedSymOrd2 mode f) =>+  (a -> b -> GetData mode Ordering) ->+  (c -> d -> GetData mode Ordering) ->+  f a c ->+  f b d ->+  GetData 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 $+        SymOrd.liftSymCompare2 f g a b+    )+{-# INLINE liftSymCompare2 #-}++-- | Unified `Grisette.Internal.Core.Data.Class.SymOrd.symCompare2`.+symCompare2 ::+  forall mode f a b.+  ( DecideEvalMode mode,+    UnifiedSymOrd mode a,+    UnifiedSymOrd mode b,+    UnifiedSymOrd2 mode f+  ) =>+  f a b ->+  f a b ->+  GetData 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 $+            SymOrd.symCompare2 a b+    )+{-# INLINE symCompare2 #-}
+ src/Grisette/Internal/Unified/UnifiedFP.hs view
@@ -0,0 +1,20 @@+{-# OPTIONS_GHC -fno-warn-missing-import-lists #-}++-- |+-- Module      :   Grisette.Internal.Unified.UnifiedFP+-- 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.Unified.UnifiedFP+  ( UnifiedFPImpl (GetFP, GetFPRoundingMode),+    UnifiedFP,+    SafeUnifiedFP,+    AllUnifiedFP,+  )+where++import Grisette.Internal.Internal.Decl.Unified.UnifiedFP+import Grisette.Internal.Internal.Impl.Unified.UnifiedFP ()
+ src/Grisette/Internal/Unified/UnifiedFun.hs view
@@ -0,0 +1,369 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.Unified.UnifiedFun+-- 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.Unified.UnifiedFun+  ( UnifiedFunConstraint,+    UnifiedFun (..),+    unifiedFunInstanceName,+    genUnifiedFunInstance,+    GetFun2,+    GetFun3,+    GetFun4,+    GetFun5,+    GetFun6,+    GetFun7,+    GetFun8,+  )+where++#if MIN_VERSION_base(4,20,0)+#else+import Data.Foldable (Foldable (foldl'))+#endif++import Control.DeepSeq (NFData)+import Data.Binary (Binary)+import Data.Bytes.Serial (Serial)+import qualified Data.Kind+import Data.Serialize (Serialize)+import Data.Typeable (Typeable)+import GHC.TypeLits (KnownNat, Nat, type (<=))+import Grisette.Internal.Core.Data.Class.EvalSym (EvalSym)+import Grisette.Internal.Core.Data.Class.ExtractSym (ExtractSym)+import Grisette.Internal.Core.Data.Class.Function (Apply (FunType), Function)+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.ToCon (ToCon)+import Grisette.Internal.Core.Data.Class.ToSym (ToSym)+import Grisette.Internal.SymPrim.AlgReal (AlgReal)+import Grisette.Internal.SymPrim.BV (IntN, WordN)+import Grisette.Internal.SymPrim.FP (FP, ValidFP)+import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal)+import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN)+import Grisette.Internal.SymPrim.SymBool (SymBool)+import Grisette.Internal.SymPrim.SymFP (SymFP)+import Grisette.Internal.SymPrim.SymInteger (SymInteger)+import Grisette.Internal.SymPrim.SymTabularFun (type (=~>))+import Grisette.Internal.SymPrim.TabularFun (type (=->))+import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C, S))+import Grisette.Internal.Unified.Theories+  ( TheoryToUnify (UAlgReal, UBool, UFP, UFun, UIntN, UInteger, UWordN),+  )+import Grisette.Internal.Unified.UnifiedAlgReal (GetAlgReal)+import Grisette.Internal.Unified.UnifiedBV (UnifiedBVImpl (GetIntN, GetWordN))+import Grisette.Internal.Unified.UnifiedBool (UnifiedBool (GetBool))+import Grisette.Internal.Unified.UnifiedFP (UnifiedFPImpl (GetFP))+import Grisette.Internal.Unified.UnifiedInteger (GetInteger)+import Language.Haskell.TH+  ( DecsQ,+    Pred,+    Q,+    TyLit (NumTyLit),+    Type (AppT, ConT, ForallT, LitT, VarT),+    appT,+    classD,+    conT,+    instanceD,+    mkName,+    newName,+    promotedT,+    varT,+  )+import qualified Language.Haskell.TH+import Language.Haskell.TH.Datatype.TyVarBndr+  ( kindedTV,+    mapTVFlag,+    specifiedSpec,+    tvName,+  )+import Language.Haskell.TH.Syntax (Lift)++#if MIN_VERSION_template_haskell(2,21,0)+type TyVarBndrVis = Language.Haskell.TH.TyVarBndrVis+#elif MIN_VERSION_template_haskell(2,17,0)+type TyVarBndrVis = Language.Haskell.TH.TyVarBndr ()+#else+type TyVarBndrVis = Language.Haskell.TH.TyVarBndr+#endif++-- | Provide unified function types.+class UnifiedFun (mode :: EvalModeTag) where+  -- | Get a unified function type. Resolves to t'Grisette.SymPrim.=->' in 'C'+  -- mode, and t'Grisette.SymPrim.=~>' in 'S' mode.+  type+    GetFun mode =+      (fun :: Data.Kind.Type -> Data.Kind.Type -> Data.Kind.Type) | fun -> mode++instance UnifiedFun 'C where+  type GetFun 'C = (=->)++instance UnifiedFun 'S where+  type GetFun 'S = (=~>)++-- | The unified function type with 2 arguments.+type GetFun2 mode a b = GetFun mode a b++-- | The unified function type with 3 arguments.+type GetFun3 mode a b c = GetFun mode a (GetFun mode b c)++-- | The unified function type with 4 arguments.+type GetFun4 mode a b c d = GetFun mode a (GetFun mode b (GetFun mode c d))++-- | The unified function type with 5 arguments.+type GetFun5 mode a b c d e =+  GetFun mode a (GetFun mode b (GetFun mode c (GetFun mode d e)))++-- | The unified function type with 6 arguments.+type GetFun6 mode a b c d e f =+  GetFun+    mode+    a+    (GetFun mode b (GetFun mode c (GetFun mode d (GetFun mode e f))))++-- | The unified function type with 7 arguments.+type GetFun7 mode a b c d e f g =+  GetFun+    mode+    a+    ( GetFun+        mode+        b+        (GetFun mode c (GetFun mode d (GetFun mode e (GetFun mode f g))))+    )++-- | The unified function type with 8 arguments.+type GetFun8 mode a b c d e f g h =+  GetFun+    mode+    a+    ( GetFun+        mode+        b+        ( GetFun+            mode+            c+            (GetFun mode d (GetFun mode e (GetFun mode f (GetFun mode g h))))+        )+    )++-- | The constraint for a unified function.+type UnifiedFunConstraint mode a b ca cb sa sb =+  ( Show (GetFun mode a b),+    Binary (GetFun mode a b),+    Serial (GetFun mode a b),+    Serialize (GetFun mode a b),+    NFData (GetFun mode a b),+    Eq (GetFun mode a b),+    EvalSym (GetFun mode a b),+    ExtractSym (GetFun mode a b),+    Mergeable (GetFun mode a b),+    PPrint (GetFun mode a b),+    SubstSym (GetFun mode a b),+    Lift (GetFun mode a b),+    Typeable (GetFun mode a b),+    ToCon (GetFun mode a b) (ca =-> cb),+    ToCon (sa =~> sb) (GetFun mode a b),+    ToSym (GetFun mode a b) (sa =~> sb),+    ToSym (ca =-> cb) (GetFun mode a b),+    Function (GetFun mode a b) a b,+    Apply (GetFun mode a b),+    FunType (GetFun mode a b) ~ (a -> b)+  )++genInnerUnifiedFunInstance ::+  String ->+  TyVarBndrVis ->+  [Pred] ->+  [TyVarBndrVis] ->+  [(Type, Type, Type)] ->+  DecsQ+genInnerUnifiedFunInstance nm mode preds bndrs tys = do+  x <- classD (goPred tys) (mkName nm) (mode : bndrs) [] []+  dc <-+    instanceD+      (return preds)+      (applyTypeList (promotedT 'C : additionalTypes))+      []+  ds <-+    instanceD+      (return preds)+      (applyTypeList (promotedT 'S : additionalTypes))+      []+  return [x, dc, ds]+  where+    additionalTypes = (varT . tvName) <$> bndrs+    applyTypeList = foldl appT (conT (mkName nm))+    goPred :: [(Type, Type, Type)] -> Q [Pred]+    goPred [] = fail "Empty list of function types, at least 2."+    goPred [_] = return []+    goPred (x : xs) = do+      p1 <- pred x xs+      pr <- goPred xs+      return $ p1 : pr+    listTys :: [(Type, Type, Type)] -> Q (Type, Type, Type)+    listTys [] = fail "Should not happen"+    listTys [(u, c, s)] = return (u, c, s)+    listTys ((u, c, s) : xs) = do+      (u', c', s') <- listTys xs+      return+        ( AppT (AppT (AppT (ConT ''GetFun) (VarT $ tvName mode)) u) u',+          AppT (AppT (ConT ''(=->)) c) c',+          AppT (AppT (ConT ''(=~>)) s) s'+        )+    pred (ua, ca, sa) l = do+      (ub, cb, sb) <- listTys l+      [t|+        UnifiedFunConstraint+          $(return (VarT $ tvName mode))+          $(return ua)+          $(return ub)+          $(return ca)+          $(return cb)+          $(return sa)+          $(return sb)+        |]++genOuterUnifiedFunInstance ::+  String -> String -> TyVarBndrVis -> [Pred] -> [TyVarBndrVis] -> DecsQ+genOuterUnifiedFunInstance nm innerName mode preds bndrs = do+  let bndrs' = mapTVFlag (const specifiedSpec) <$> bndrs+  x <-+    classD+      ( return+          [ ForallT bndrs' preds $+              foldl' AppT (ConT $ mkName innerName) $+                VarT . tvName <$> mode : bndrs+          ]+      )+      (mkName nm)+      [mode]+      []+      []+  dc <-+    instanceD+      (return [])+      (appT (conT $ mkName nm) (promotedT 'C))+      []+  ds <-+    instanceD+      (return [])+      (appT (conT $ mkName nm) (promotedT 'S))+      []+  return [x, dc, ds]++-- | Generate unified function instance names.+unifiedFunInstanceName :: String -> [TheoryToUnify] -> String+unifiedFunInstanceName prefix theories =+  prefix ++ "Fun" ++ (concatMap show theories)++-- | Generate unified function instances.+genUnifiedFunInstance :: String -> [TheoryToUnify] -> DecsQ+genUnifiedFunInstance prefix theories = do+  modeName <- newName "mode"+  let modeType = VarT modeName+  allArgs <- traverse (genArgs modeType) theories+  let baseName = unifiedFunInstanceName prefix theories+  rinner <-+    genInnerUnifiedFunInstance+      baseName+      (kindedTV modeName (ConT ''EvalModeTag))+      (concatMap (\(_, p, _, _, _) -> p) allArgs)+      (concatMap (\(t, _, _, _, _) -> t) allArgs)+      ((\(_, _, u, c, s) -> (u, c, s)) <$> allArgs)+  router <-+    if all (\(bndr, _, _, _, _) -> null bndr) allArgs+      then return []+      else+        genOuterUnifiedFunInstance+          ("All" ++ baseName)+          baseName+          (kindedTV modeName (ConT ''EvalModeTag))+          (concatMap (\(_, p, _, _, _) -> p) allArgs)+          (concatMap (\(t, _, _, _, _) -> t) allArgs)+  return $ rinner ++ router+  where+    genArgs ::+      Type -> TheoryToUnify -> Q ([TyVarBndrVis], [Pred], Type, Type, Type)+    genArgs mode UBool =+      return+        ( [],+          [],+          AppT (ConT ''GetBool) mode,+          ConT ''Bool,+          ConT ''SymBool+        )+    genArgs mode UIntN = do+      n <- newName "n"+      let nType = VarT n+      return+        ( [kindedTV n (ConT ''Nat)],+          [ AppT (ConT ''KnownNat) nType,+            AppT (AppT (ConT ''(<=)) (LitT $ NumTyLit 1)) nType+          ],+          AppT (AppT (ConT ''GetIntN) mode) nType,+          AppT (ConT ''IntN) nType,+          AppT (ConT ''SymIntN) nType+        )+    genArgs mode UWordN = do+      n <- newName "n"+      let nType = VarT n+      return+        ( [kindedTV n (ConT ''Nat)],+          [ AppT (ConT ''KnownNat) nType,+            AppT (AppT (ConT ''(<=)) (LitT $ NumTyLit 1)) nType+          ],+          AppT (AppT (ConT ''GetWordN) mode) nType,+          AppT (ConT ''WordN) nType,+          AppT (ConT ''SymWordN) nType+        )+    genArgs mode UInteger =+      return+        ( [],+          [],+          AppT (ConT ''GetInteger) mode,+          ConT ''Integer,+          ConT ''SymInteger+        )+    genArgs mode UAlgReal =+      return+        ( [],+          [],+          AppT (ConT ''GetAlgReal) mode,+          ConT ''AlgReal,+          ConT ''SymAlgReal+        )+    genArgs mode UFP = do+      eb <- newName "eb"+      sb <- newName "sb"+      let ebType = VarT eb+      let sbType = VarT sb+      return+        ( [kindedTV eb (ConT ''Nat), kindedTV sb (ConT ''Nat)],+          [AppT (AppT (ConT ''ValidFP) ebType) sbType],+          AppT (AppT (AppT (ConT ''GetFP) mode) ebType) sbType,+          AppT (AppT (ConT ''FP) ebType) sbType,+          AppT (AppT (ConT ''SymFP) ebType) sbType+        )+    genArgs _ UFun {} = fail "UFun cannot be nested."
+ src/Grisette/Internal/Unified/UnifiedInteger.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UndecidableSuperClasses #-}++-- |+-- Module      :   Grisette.Internal.Unified.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.Internal.Unified.UnifiedInteger+  ( GetInteger,+    UnifiedInteger,+  )+where++import Control.Exception (ArithException)+import Control.Monad.Except (MonadError)+import Grisette.Internal.SymPrim.SymInteger (SymInteger)+import Grisette.Internal.Unified.Class.UnifiedFromIntegral (UnifiedFromIntegral)+import Grisette.Internal.Unified.Class.UnifiedRep+  ( UnifiedConRep (ConType),+    UnifiedSymRep (SymType),+  )+import Grisette.Internal.Unified.Class.UnifiedSafeDiv (UnifiedSafeDiv)+import Grisette.Internal.Unified.Class.UnifiedSafeLinearArith+  ( UnifiedSafeLinearArith,+  )+import Grisette.Internal.Unified.Class.UnifiedSimpleMergeable (UnifiedBranching)+import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C, S))+import Grisette.Internal.Unified.UnifiedPrim (UnifiedBasicPrim)++class+  ( i ~ GetInteger mode,+    UnifiedConRep i,+    UnifiedSymRep i,+    ConType i ~ Integer,+    SymType i ~ SymInteger,+    UnifiedBasicPrim mode i,+    Num i,+    forall m.+    (UnifiedBranching mode m, MonadError ArithException m) =>+    UnifiedSafeDiv mode ArithException i m,+    forall m.+    (UnifiedBranching mode m, MonadError ArithException m) =>+    UnifiedSafeLinearArith mode ArithException i m,+    UnifiedFromIntegral mode i i+  ) =>+  UnifiedIntegerImpl (mode :: EvalModeTag) i+    | mode -> i+  where+  -- | Get a unified Integer type. Resolves to 'Integer' in 'C' mode, and+  -- 'SymInteger' in 'S' mode.+  type GetInteger mode = int | int -> mode++instance UnifiedIntegerImpl 'C Integer where+  type GetInteger 'C = Integer++instance UnifiedIntegerImpl 'S SymInteger where+  type GetInteger 'S = SymInteger++-- | Evaluation mode with unified 'Integer' type.+class+  (UnifiedIntegerImpl mode (GetInteger mode)) =>+  UnifiedInteger (mode :: EvalModeTag)++instance UnifiedInteger 'C++instance UnifiedInteger 'S
+ src/Grisette/Internal/Unified/UnifiedPrim.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MonoLocalBinds #-}++-- |+-- Module      :   Grisette.Internal.Unified.UnifiedPrim+-- 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.Unified.UnifiedPrim+  ( UnifiedPrim,+    UnifiedBasicPrim,+  )+where++import Grisette.Internal.SymPrim.SymPrim (Prim)+import Grisette.Internal.Unified.BaseConstraint (ConSymConversion)+import Grisette.Internal.Unified.Class.UnifiedITEOp+  ( UnifiedITEOp,+  )+import Grisette.Internal.Unified.Class.UnifiedRep+  ( UnifiedConRep (ConType),+    UnifiedSymRep (SymType),+  )+import Grisette.Internal.Unified.Class.UnifiedSimpleMergeable+  ( UnifiedSimpleMergeable,+  )+import Grisette.Internal.Unified.Class.UnifiedSolvable (UnifiedSolvable)+import Grisette.Internal.Unified.Class.UnifiedSymEq (UnifiedSymEq)+import Grisette.Internal.Unified.Class.UnifiedSymOrd (UnifiedSymOrd)++-- | A type that is used as a constraint for all the (unified) primitive types+-- in Grisette.+type UnifiedPrim mode a =+  ( Prim a,+    UnifiedITEOp mode a,+    UnifiedSymEq mode a,+    UnifiedSymOrd mode a+  )++-- | A type that is used as a constraint for all the basic (unified) primitive+-- types in Grisette.+--+-- 'Grisette.Internal.Unified.GetSomeWordN' is not considered as a basic (unified)+-- primitive type.+type UnifiedBasicPrim mode a =+  ( UnifiedPrim mode a,+    UnifiedSimpleMergeable mode a,+    UnifiedConRep a,+    UnifiedSymRep a,+    UnifiedSolvable mode a (ConType a),+    ConSymConversion (ConType a) (SymType a) a+  )
+ src/Grisette/Internal/Unified/Util.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Eta reduce" #-}++-- |+-- Module      :   Grisette.Internal.Unified.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.Unified.Util+  ( DecideEvalMode (..),+    withMode,+    EvalModeConvertible (..),+  )+where++import Data.Typeable (type (:~:) (Refl))+import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C, S))+import Grisette.Internal.Utils.Parameterized (unsafeAxiom)++-- | A class that provides the mode tag at runtime.+class DecideEvalMode (mode :: EvalModeTag) where+  decideEvalMode :: EvalModeTag++instance DecideEvalMode 'C where+  decideEvalMode = C+  {-# INLINE decideEvalMode #-}++instance DecideEvalMode 'S where+  decideEvalMode = S+  {-# INLINE decideEvalMode #-}++-- | Case analysis on the mode.+withMode ::+  forall mode r.+  (DecideEvalMode mode) =>+  ((mode ~ 'C) => r) ->+  ((mode ~ 'S) => r) ->+  r+withMode con sym =+  case decideEvalMode @mode of+    C -> case unsafeAxiom @mode @'C of+      Refl -> con+    S -> case unsafeAxiom @mode @'S of+      Refl -> sym+{-# INLINE withMode #-}++-- | A class saying that we can convert a value with one mode to another mode.+--+-- Allowed conversions:+--+-- - 'C' <-> 'C'+-- - 'S' <-> 'S'+-- - 'C' <-> 'S'+--+-- Conversion from left to right uses 'Grisette.ToSym' class, and conversion+-- from right to left uses 'Grisette.ToCon' class.+class+  (DecideEvalMode c, DecideEvalMode s) =>+  EvalModeConvertible (c :: EvalModeTag) (s :: EvalModeTag)+  where+  withModeConvertible ::+    ((c ~ 'C) => r) ->+    ((s ~ 'S) => r) ->+    r+  withModeConvertible' ::+    ((c ~ 'C, s ~ 'C) => r) ->+    ((c ~ 'C, s ~ 'S) => r) ->+    ((c ~ 'S, s ~ 'S) => r) ->+    r++instance {-# INCOHERENT #-} (DecideEvalMode c) => EvalModeConvertible c c where+  withModeConvertible con sym = withMode @c con sym+  {-# INLINE withModeConvertible #-}+  withModeConvertible' con _ sym = withMode @c con sym+  {-# INLINE withModeConvertible' #-}++instance {-# INCOHERENT #-} (DecideEvalMode s) => EvalModeConvertible 'C s where+  withModeConvertible con _ = con+  {-# INLINE withModeConvertible #-}+  withModeConvertible' con0 con1 _ = withMode @s con0 con1+  {-# INLINE withModeConvertible' #-}++instance {-# INCOHERENT #-} (DecideEvalMode c) => EvalModeConvertible c 'S where+  withModeConvertible _ sym = sym+  {-# INLINE withModeConvertible #-}+  withModeConvertible' _ sym0 sym1 = withMode @c sym0 sym1+  {-# INLINE withModeConvertible' #-}
+ src/Grisette/Internal/Utils/Derive.hs view
@@ -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
+ src/Grisette/Internal/Utils/Parameterized.hs view
@@ -0,0 +1,325 @@+{-+Part of the code in this file comes 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.+-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++-- |+-- Module      :   Grisette.Internal.Utils.Parameterized+-- 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.Parameterized+  ( -- * Unsafe axiom+    unsafeAxiom,++    -- * Unparameterized type+    SomeNatRepr (..),+    SomePositiveNatRepr (..),++    -- * Runtime representation of type-level natural numbers+    NatRepr,+    withKnownNat,+    natValue,+    mkNatRepr,+    mkPositiveNatRepr,+    natRepr,+    decNat,+    predNat,+    incNat,+    addNat,+    subNat,+    divNat,+    halfNat,++    -- * Proof of KnownNat+    KnownProof (..),+    hasRepr,+    withKnownProof,+    unsafeKnownProof,+    knownAdd,++    -- * Proof of CmpNat+    CmpNatProof (..),+    unsafeCmpNatProof,+    withCmpNatProof,++    -- * Proof of (<=) for type-level natural numbers+    LeqProof (..),+    withLeqProof,+    unsafeLeqProof,+    testLeq,+    leqRefl,+    leqSucc,+    leqTrans,+    leqZero,+    leqAdd2,+    leqAdd,+    leqAddPos,+  )+where++import Data.Type.Equality (type (==))+import Data.Typeable (Proxy (Proxy), type (:~:) (Refl))+import GHC.TypeNats+  ( CmpNat,+    Div,+    KnownNat,+    Nat,+    SomeNat (SomeNat),+    natVal,+    someNatVal,+    type (+),+    type (-),+    type (<=),+  )+import Numeric.Natural (Natural)+import Unsafe.Coerce (unsafeCoerce)++-- | Assert a proof of equality between two types.+-- This is unsafe if used improperly, so use this with caution!+unsafeAxiom :: forall a b. a :~: b+unsafeAxiom = unsafeCoerce (Refl @a)+{-# INLINE unsafeAxiom #-}++-- | 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+    SomeNat (Proxy :: Proxy n') ->+      case unsafeAxiom :: n :~: n' of+        Refl -> v+{-# INLINE withKnownNat #-}++-- | A runtime representation of type-level natural numbers.+-- This can be used for performing dynamic checks on type-level natural numbers.+newtype NatRepr (n :: Nat) = NatRepr Natural++-- | The underlying runtime natural number value of a type-level natural number.+natValue :: NatRepr n -> Natural+natValue (NatRepr n) = n+{-# INLINE natValue #-}++data SomeNatReprHelper where+  SomeNatReprHelper :: NatRepr n -> SomeNatReprHelper++-- | Existential wrapper for t'NatRepr'.+data SomeNatRepr where+  SomeNatRepr :: (KnownNat n) => NatRepr n -> SomeNatRepr++-- | Turn a @Natural@ into the corresponding @NatRepr@ with the KnownNat+-- constraint.+mkNatRepr :: Natural -> SomeNatRepr+mkNatRepr n = case SomeNatReprHelper (NatRepr n) of+  SomeNatReprHelper natRepr -> withKnownNat natRepr $ SomeNatRepr natRepr+{-# INLINE mkNatRepr #-}++-- | Existential wrapper for t'NatRepr' with the constraint that the natural+-- number is greater than 0.+data SomePositiveNatRepr where+  SomePositiveNatRepr ::+    (KnownNat n, 1 <= n) => NatRepr n -> SomePositiveNatRepr++-- | Turn a @NatRepr@ into the corresponding @NatRepr@ with the KnownNat+-- constraint and asserts that its greater than 0.+mkPositiveNatRepr :: Natural -> SomePositiveNatRepr+mkPositiveNatRepr 0 = error "mkPositiveNatRepr: 0 is not a positive number"+mkPositiveNatRepr n = case mkNatRepr n of+  SomeNatRepr (natRepr :: NatRepr n) -> case unsafeLeqProof @1 @n of+    LeqProof -> SomePositiveNatRepr natRepr+{-# INLINE mkPositiveNatRepr #-}++-- | Construct a runtime representation of a type-level natural number when its+-- runtime value is known.+natRepr :: forall n. (KnownNat n) => NatRepr n+natRepr = NatRepr (natVal (Proxy @n))+{-# INLINE natRepr #-}++-- | Decrement a t'NatRepr' by 1.+decNat :: (1 <= n) => NatRepr n -> NatRepr (n - 1)+decNat (NatRepr n) = NatRepr (n - 1)+{-# INLINE decNat #-}++-- | Predecessor of a t'NatRepr'+predNat :: NatRepr (n + 1) -> NatRepr n+predNat (NatRepr n) = NatRepr (n - 1)+{-# INLINE predNat #-}++-- | Increment a t'NatRepr' by 1.+incNat :: NatRepr n -> NatRepr (n + 1)+incNat (NatRepr n) = NatRepr (n + 1)+{-# INLINE incNat #-}++-- | Addition of two t'NatRepr's.+addNat :: NatRepr m -> NatRepr n -> NatRepr (m + n)+addNat (NatRepr m) (NatRepr n) = NatRepr (m + n)+{-# INLINE addNat #-}++-- | Subtraction of two t'NatRepr's.+subNat :: (n <= m) => NatRepr m -> NatRepr n -> NatRepr (m - n)+subNat (NatRepr m) (NatRepr n) = NatRepr (m - n)+{-# INLINE subNat #-}++-- | Division of two t'NatRepr's.+divNat :: (1 <= n) => NatRepr m -> NatRepr n -> NatRepr (Div m n)+divNat (NatRepr m) (NatRepr n) = NatRepr (m `div` n)+{-# INLINE divNat #-}++-- | Half of a t'NatRepr'.+halfNat :: NatRepr (n + n) -> NatRepr n+halfNat (NatRepr n) = NatRepr (n `div` 2)+{-# INLINE halfNat #-}++-- | @'KnownProof n'@ is a type whose values are only inhabited when @n@ has+-- a known runtime value.+data KnownProof (n :: Nat) where+  KnownProof :: (KnownNat n) => KnownProof n++-- | Introduces the 'KnownNat' constraint when it's proven.+withKnownProof :: KnownProof n -> ((KnownNat n) => r) -> r+withKnownProof p r = case p of KnownProof -> r+{-# INLINE withKnownProof #-}++-- | Construct a t'KnownProof' given the runtime value.+--+-- __Note:__ This function is unsafe, as it does not check that the runtime+-- representation is consistent with the type-level representation.+-- You should ensure the consistency yourself or the program can crash or+-- generate incorrect results.+unsafeKnownProof :: Natural -> KnownProof n+unsafeKnownProof nVal = hasRepr (NatRepr nVal)+{-# INLINE unsafeKnownProof #-}++-- | Construct a t'KnownProof' given the runtime representation.+hasRepr :: forall n. NatRepr n -> KnownProof n+hasRepr (NatRepr nVal) =+  case someNatVal nVal of+    SomeNat (Proxy :: Proxy n') ->+      case unsafeAxiom :: n :~: n' of+        Refl -> KnownProof+{-# INLINE hasRepr #-}++-- | Adding two type-level natural numbers with known runtime values gives a+-- type-level natural number with a known runtime value.+knownAdd :: forall m n. KnownProof m -> KnownProof n -> KnownProof (m + n)+knownAdd KnownProof KnownProof = hasRepr @(m + n) (NatRepr (natVal (Proxy @m) + natVal (Proxy @n)))+{-# INLINE knownAdd #-}++-- | @'LeqProof m n'@ is a type whose values are only inhabited when @m <= n@.+data LeqProof (m :: Nat) (n :: Nat) where+  LeqProof :: (m <= n) => LeqProof m n++-- | Introduces the @m <= n@ constraint when it's proven.+withLeqProof :: LeqProof m n -> ((m <= n) => r) -> r+withLeqProof p r = case p of LeqProof -> r+{-# INLINE withLeqProof #-}++-- | Construct a t'LeqProof'.+--+-- __Note:__ This function is unsafe, as it does not check that the left-hand+-- side is less than or equal to the right-hand side.+-- You should ensure the consistency yourself or the program can crash or+-- generate incorrect results.+unsafeLeqProof :: forall m n. LeqProof m n+unsafeLeqProof = unsafeCoerce (LeqProof @0 @0)+{-# INLINE unsafeLeqProof #-}++-- | Proof that the comparison of two type-level natural numbers is consistent+-- with the runtime comparison.+data CmpNatProof (m :: Nat) (n :: Nat) (o :: Ordering) where+  CmpNatProof :: ((CmpNat m n == o) ~ 'True) => CmpNatProof m n o++-- | Construct a t'CmpNatProof'.+unsafeCmpNatProof :: forall m n o. CmpNatProof m n o+unsafeCmpNatProof = unsafeCoerce (CmpNatProof @0 @0 @'EQ)+{-# INLINE unsafeCmpNatProof #-}++-- | Introduces the @t'CmpNat' m n o@ constraint when it's proven.+withCmpNatProof :: CmpNatProof m n o -> (((CmpNat m n == o) ~ 'True) => r) -> r+withCmpNatProof p r = case p of CmpNatProof -> r+{-# INLINE withCmpNatProof #-}++-- | Checks if a t'NatRepr' is less than or equal to another t'NatRepr'.+testLeq :: NatRepr m -> NatRepr n -> Maybe (LeqProof m n)+testLeq (NatRepr m) (NatRepr n) =+  case compare m n of+    LT -> Nothing+    EQ -> Just unsafeLeqProof+    GT -> Just unsafeLeqProof+{-# INLINE testLeq #-}++-- | Apply reflexivity to t'LeqProof'.+leqRefl :: f n -> LeqProof n n+leqRefl _ = LeqProof+{-# INLINE leqRefl #-}++-- | A natural number is less than or equal to its successor.+leqSucc :: f n -> LeqProof n (n + 1)+leqSucc _ = unsafeLeqProof+{-# INLINE leqSucc #-}++-- | Apply transitivity to t'LeqProof'.+leqTrans :: LeqProof a b -> LeqProof b c -> LeqProof a c+leqTrans _ _ = unsafeLeqProof+{-# INLINE leqTrans #-}++-- | Zero is less than or equal to any natural number.+leqZero :: LeqProof 0 n+leqZero = unsafeLeqProof+{-# INLINE leqZero #-}++-- | Add both sides of two inequalities.+leqAdd2 :: LeqProof xl xh -> LeqProof yl yh -> LeqProof (xl + yl) (xh + yh)+leqAdd2 _ _ = unsafeLeqProof+{-# INLINE leqAdd2 #-}++-- | Produce proof that adding a value to the larger element in an t'LeqProof'+-- is larger.+leqAdd :: LeqProof m n -> f o -> LeqProof m (n + o)+leqAdd _ _ = unsafeLeqProof+{-# INLINE leqAdd #-}++-- | Adding two positive natural numbers is positive.+leqAddPos :: (1 <= m, 1 <= n) => p m -> q n -> LeqProof 1 (m + n)+leqAddPos _ _ = unsafeLeqProof+{-# INLINE leqAddPos #-}
src/Grisette/Lib/Base.hs view
@@ -1,8 +1,9 @@ {-# LANGUAGE Trustworthy #-}+{-# OPTIONS_GHC -Wno-missing-import-lists #-}  -- | -- Module      :   Grisette.Lib.Base--- 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@@ -10,76 +11,26 @@ -- Portability :   GHC only module Grisette.Lib.Base   ( -- * Symbolic or mrg* variants for the operations in the base package--    -- ** mrg* variants for operations in "Control.Monad"-    mrgReturnWithStrategy,-    mrgBindWithStrategy,-    mrgReturn,-    (.>>=),-    (.>>),-    mrgFoldM,-    mrgMzero,-    mrgMplus,-    mrgFmap,--    -- ** mrg* variants for operations in "Data.Foldable"-    mrgFoldlM,-    mrgFoldrM,-    mrgTraverse_,-    mrgFor_,-    mrgMapM_,-    mrgForM_,-    mrgSequence_,-    mrgMsum,--    -- ** mrg* variants for operations in "Data.Traversable"-    mrgTraverse,-    mrgSequenceA,-    mrgFor,-    mrgMapM,-    mrgForM,-    mrgSequence,--    -- ** Symbolic versions for operations in "Data.List"-    (.!!),-    symFilter,-    symTake,-    symDrop,+    module Grisette.Lib.Control.Applicative,+    module Grisette.Lib.Control.Monad,+    module Grisette.Lib.Data.Either,+    module Grisette.Lib.Data.Foldable,+    module Grisette.Lib.Data.Functor,+    module Grisette.Lib.Data.Functor.Sum,+    module Grisette.Lib.Data.List,+    module Grisette.Lib.Data.Maybe,+    module Grisette.Lib.Data.Traversable,+    module Grisette.Lib.Data.Tuple,   ) where +import Grisette.Lib.Control.Applicative import Grisette.Lib.Control.Monad-  ( mrgBindWithStrategy,-    mrgFmap,-    mrgFoldM,-    mrgMplus,-    mrgMzero,-    mrgReturn,-    mrgReturnWithStrategy,-    (.>>),-    (.>>=),-  )+import Grisette.Lib.Data.Either import Grisette.Lib.Data.Foldable-  ( mrgFoldlM,-    mrgFoldrM,-    mrgForM_,-    mrgFor_,-    mrgMapM_,-    mrgMsum,-    mrgSequence_,-    mrgTraverse_,-  )+import Grisette.Lib.Data.Functor+import Grisette.Lib.Data.Functor.Sum import Grisette.Lib.Data.List-  ( symDrop,-    symFilter,-    symTake,-    (.!!),-  )+import Grisette.Lib.Data.Maybe import Grisette.Lib.Data.Traversable-  ( mrgFor,-    mrgForM,-    mrgMapM,-    mrgSequence,-    mrgSequenceA,-    mrgTraverse,-  )+import Grisette.Lib.Data.Tuple
+ src/Grisette/Lib/Control/Applicative.hs view
@@ -0,0 +1,161 @@+-- |+-- Module      :   Grisette.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.Lib.Control.Applicative+  ( -- * Applicative Functors+    mrgPureWithStrategy,+    mrgPure,+    (.<*>),+    mrgLiftA2,+    (.*>),+    (.<*),++    -- * Alternatives+    mrgEmpty,+    (.<|>),+    mrgSome,+    mrgMany,++    -- * Utility functions+    (.<$>),+    (.<$),+    (.<**>),+    mrgLiftA,+    mrgLiftA3,+    mrgOptional,+    mrgAsum,+  )+where++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 'Grisette.Core.mrgSingleWithStrategy'.+mrgPureWithStrategy ::+  (TryMerge m, Applicative m) => MergingStrategy a -> a -> m a+mrgPureWithStrategy = Unified.mrgPureWithStrategy+{-# INLINE mrgPureWithStrategy #-}++-- | Alias for 'Grisette.Core.mrgSingle'.+mrgPure :: (TryMerge m, Applicative m, Mergeable a) => a -> m a+mrgPure = Unified.mrgPure+{-# INLINE mrgPure #-}++infixl 4 .<*>++-- | '<*>' with 'MergingStrategy' knowledge propagation.+(.<*>) ::+  (Applicative f, TryMerge f, Mergeable a, Mergeable b) =>+  f (a -> b) ->+  f a ->+  f b+(.<*>) = (Unified..<*>)+{-# 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 = Unified.mrgLiftA2+{-# INLINE mrgLiftA2 #-}++infixl 4 .*>++-- | '*>' with 'MergingStrategy' knowledge propagation.+(.*>) ::+  (Applicative f, TryMerge f, Mergeable a, Mergeable b) => f a -> f b -> f b+(.*>) = (Unified..*>)+{-# INLINE (.*>) #-}++infixl 4 .<*++-- | '<*' with 'MergingStrategy' knowledge propagation.+(.<*) ::+  (Applicative f, TryMerge f, Mergeable a, Mergeable b) => f a -> f b -> f a+(.<*) = (Unified..<*)+{-# INLINE (.<*) #-}++-- | 'Control.Applicative.empty' with 'MergingStrategy' knowledge propagation.+mrgEmpty :: (Alternative f, TryMerge f, Mergeable a) => f a+mrgEmpty = Unified.mrgEmpty+{-# INLINE mrgEmpty #-}++infixl 3 .<|>++-- | 'Control.Applicative.<|>' with 'MergingStrategy' knowledge propagation.+(.<|>) :: (Alternative f, TryMerge f, Mergeable a) => f a -> f a -> f a+(.<|>) = (Unified..<|>)+{-# INLINE (.<|>) #-}++-- | 'Control.Applicative.some' with 'MergingStrategy' knowledge propagation.+mrgSome :: (Alternative f, TryMerge f, Mergeable a) => f a -> f [a]+mrgSome = Unified.mrgSome+{-# INLINE mrgSome #-}++-- | 'Control.Applicative.many' with 'MergingStrategy' knowledge propagation.+mrgMany :: (Alternative f, TryMerge f, Mergeable a) => f a -> f [a]+mrgMany = Unified.mrgMany+{-# 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+(.<**>) = (Unified..<**>)+{-# INLINE (.<**>) #-}++-- | 'Control.Applicative.liftA' with 'MergingStrategy' knowledge propagation.+mrgLiftA ::+  (Applicative f, TryMerge f, Mergeable a, Mergeable b) =>+  (a -> b) ->+  f a ->+  f b+mrgLiftA = Unified.mrgLiftA+{-# 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 = Unified.mrgLiftA3+{-# INLINE mrgLiftA3 #-}++-- | 'Control.Applicative.optional' with 'MergingStrategy' knowledge+-- propagation.+mrgOptional ::+  (Alternative f, TryMerge f, Mergeable a) =>+  f a ->+  f (Maybe a)+mrgOptional = Unified.mrgOptional+{-# INLINE mrgOptional #-}++-- | 'Control.Applicative.asum' with 'MergingStrategy' knowledge propagation.+mrgAsum ::+  (Alternative f, TryMerge f, Mergeable a, Foldable t) => t (f a) -> f a+mrgAsum = Unified.mrgAsum+{-# INLINE mrgAsum #-}
src/Grisette/Lib/Control/Monad.hs view
@@ -1,85 +1,457 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeApplications #-}  -- | -- Module      :   Grisette.Lib.Control.Monad--- 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.Lib.Control.Monad-  ( -- * mrg* variants for operations in "Control.Monad"+  ( -- * Functor and Monad classes+    mrgFmap,+    (.<$),     mrgReturnWithStrategy,     mrgBindWithStrategy,     mrgReturn,     (.>>=),     (.>>),-    mrgFoldM,+    mrgFail,     mrgMzero,     mrgMplus,-    mrgFmap,++    -- * 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.Monad (MonadPlus (mplus, mzero))-import Grisette.Core.Control.Monad.Union (MonadUnion)-import Grisette.Core.Data.Class.Mergeable+import Control.Applicative (Alternative)+import Control.Monad (MonadPlus)+import Grisette.Internal.Core.Control.Monad.Class.Union (MonadUnion)+import Grisette.Internal.Core.Data.Class.Mergeable   ( Mergeable,     MergingStrategy,   )-import Grisette.Core.Data.Class.SimpleMergeable-  ( UnionLike (mergeWithStrategy),-    merge,+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,   )-import Grisette.Lib.Data.Foldable (mrgFoldlM)+import Grisette.Internal.SymPrim.SymBool (SymBool)+import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (S))+import Grisette.Lib.Data.Foldable+  ( mrgForM_,+    mrgMapM_,+    mrgMsum,+    mrgSequence_,+  )+import Grisette.Lib.Data.Functor (mrgFmap, mrgVoid, (.<$))+import Grisette.Lib.Data.Traversable+  ( mrgForM,+    mrgMapM,+    mrgSequence,+  )+import qualified Grisette.Unified.Lib.Control.Monad as Unified  -- | 'return' with 'MergingStrategy' knowledge propagation.-mrgReturnWithStrategy :: (MonadUnion u) => MergingStrategy a -> a -> u a-mrgReturnWithStrategy s = mergeWithStrategy s . return+mrgReturnWithStrategy :: (MonadTryMerge u) => MergingStrategy a -> a -> u a+mrgReturnWithStrategy = Unified.mrgReturnWithStrategy {-# INLINE mrgReturnWithStrategy #-}  -- | '>>=' with 'MergingStrategy' knowledge propagation.-mrgBindWithStrategy :: (MonadUnion u) => MergingStrategy b -> u a -> (a -> u b) -> u b-mrgBindWithStrategy s a f = mergeWithStrategy s $ a >>= f+mrgBindWithStrategy ::+  (MonadTryMerge u) =>+  MergingStrategy a ->+  MergingStrategy b ->+  u a ->+  (a -> u b) ->+  u b+mrgBindWithStrategy = Unified.mrgBindWithStrategy {-# INLINE mrgBindWithStrategy #-}  -- | 'return' with 'MergingStrategy' knowledge propagation.-mrgReturn :: (MonadUnion u, Mergeable a) => a -> u a-mrgReturn = merge . return+mrgReturn :: (MonadTryMerge u, Mergeable a) => a -> u a+mrgReturn = Unified.mrgReturn {-# INLINE mrgReturn #-} +infixl 1 .>>=+ -- | '>>=' with 'MergingStrategy' knowledge propagation.-(.>>=) :: (MonadUnion u, Mergeable b) => u a -> (a -> u b) -> u b-a .>>= f = merge $ a >>= f+(.>>=) ::+  (MonadTryMerge u, Mergeable a, Mergeable b) =>+  u a ->+  (a -> u b) ->+  u b+(.>>=) = (Unified..>>=) {-# INLINE (.>>=) #-} --- | 'foldM' with 'MergingStrategy' knowledge propagation.-mrgFoldM :: (MonadUnion m, Mergeable b, Foldable t) => (b -> a -> m b) -> b -> t a -> m b-mrgFoldM = mrgFoldlM-{-# INLINE mrgFoldM #-}+infixl 1 .>>  -- | '>>' with 'MergingStrategy' knowledge propagation. ----- This is usually more efficient than calling the original '>>' and merge the results.-(.>>) :: forall m a b. (MonadUnion m, Mergeable b) => m a -> m b -> m b-a .>> f = merge $ mrgFmap (const ()) a >> f+-- 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+(.>>) = (Unified..>>) {-# INLINE (.>>) #-} --- | 'mzero' with 'MergingStrategy' knowledge propagation.-mrgMzero :: forall m a. (MonadUnion m, Mergeable a, MonadPlus m) => m a-mrgMzero = merge mzero+-- | 'fail' with 'MergingStrategy' knowledge propagation.+mrgFail :: (MonadTryMerge m, Mergeable a, MonadFail m) => String -> m a+mrgFail = Unified.mrgFail+{-# INLINE mrgFail #-}++-- | 'Control.Monad.mzero' with 'MergingStrategy' knowledge propagation.+mrgMzero :: forall m a. (MonadTryMerge m, Mergeable a, MonadPlus m) => m a+mrgMzero = Unified.mrgMzero {-# INLINE mrgMzero #-} --- | 'mplus' with 'MergingStrategy' knowledge propagation.-mrgMplus :: forall m a. (MonadUnion m, Mergeable a, MonadPlus m) => m a -> m a -> m a-mrgMplus a b = merge $ mplus a b+-- | 'Control.Monad.mplus' with 'MergingStrategy' knowledge propagation.+mrgMplus ::+  forall m a. (MonadTryMerge m, Mergeable a, MonadPlus m) => m a -> m a -> m a+mrgMplus = Unified.mrgMplus {-# INLINE mrgMplus #-} --- | 'fmap' with 'MergingStrategy' knowledge propagation.-mrgFmap :: (MonadUnion f, Mergeable b, Functor f) => (a -> b) -> f a -> f b-mrgFmap f a = merge $ fmap f a-{-# INLINE mrgFmap #-}+infixr 1 .=<<++-- | '=<<' with 'MergingStrategy' knowledge propagation.+(.=<<) ::+  (MonadTryMerge m, Mergeable a, Mergeable b) => (a -> m b) -> m a -> m b+(.=<<) = (Unified..=<<)+{-# INLINE (.=<<) #-}++infixr 1 .>=>++-- | 'Control.Monad.>=>' with 'MergingStrategy' knowledge propagation.+(.>=>) ::+  (MonadTryMerge m, Mergeable a, Mergeable b, Mergeable c) =>+  (a -> m b) ->+  (b -> m c) ->+  a ->+  m c+(.>=>) = (Unified..>=>)+{-# INLINE (.>=>) #-}++infixr 1 .<=<++-- | 'Control.Monad.<=<' with 'MergingStrategy' knowledge propagation.+(.<=<) ::+  (MonadTryMerge m, Mergeable a, Mergeable b, Mergeable c) =>+  (b -> m c) ->+  (a -> m b) ->+  a ->+  m c+(.<=<) = (Unified..<=<)+{-# INLINE (.<=<) #-}++-- | 'Control.Monad.forever' with 'MergingStrategy' knowledge propagation.+mrgForever ::+  (Applicative m, TryMerge m, Mergeable b, Mergeable a) => m a -> m b+mrgForever = Unified.mrgForever+{-# INLINE mrgForever #-}++-- | 'Control.Monad.join' with 'MergingStrategy' knowledge propagation.+mrgJoin :: (MonadTryMerge m, Mergeable a) => m (m a) -> m a+mrgJoin = Unified.mrgJoin+{-# INLINE mrgJoin #-}++-- | 'Control.Monad.mfilter' with 'MergingStrategy' knowledge propagation.+mrgMfilter ::+  (MonadTryMerge m, MonadPlus m, Mergeable a) =>+  (a -> Bool) ->+  m a ->+  m a+mrgMfilter = Unified.mrgMfilter+{-# INLINE mrgMfilter #-}++-- | '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 = Unified.symMfilter+{-# INLINE symMfilter #-}++-- | 'Control.Monad.filterM' with 'MergingStrategy' knowledge propagation.+mrgFilterM ::+  (TryMerge m, Applicative m, Mergeable a, Foldable t) =>+  (a -> m Bool) ->+  t a ->+  m [a]+mrgFilterM = Unified.mrgFilterM+{-# INLINE mrgFilterM #-}++-- | '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 = Unified.symFilterM+{-# INLINE symFilterM #-}++-- | 'Control.Monad.mapAndUnzipM' with 'MergingStrategy' knowledge propagation.+mrgMapAndUnzipM ::+  ( Applicative m,+    TryMerge m,+    Mergeable b,+    Mergeable c+  ) =>+  (a -> m (b, c)) ->+  [a] ->+  m ([b], [c])+mrgMapAndUnzipM = Unified.mrgMapAndUnzipM+{-# INLINE mrgMapAndUnzipM #-}++-- | 'Control.Monad.zipWithM' with 'MergingStrategy' knowledge propagation.+mrgZipWithM ::+  (Applicative m, TryMerge m, Mergeable c) =>+  (a -> b -> m c) ->+  [a] ->+  [b] ->+  m [c]+mrgZipWithM = Unified.mrgZipWithM+{-# INLINE mrgZipWithM #-}++-- | 'Control.Monad.zipWithM_' with 'MergingStrategy' knowledge propagation.+mrgZipWithM_ ::+  (Applicative m, TryMerge m, Mergeable c) =>+  (a -> b -> m c) ->+  [a] ->+  [b] ->+  m ()+mrgZipWithM_ = Unified.mrgZipWithM_+{-# INLINE mrgZipWithM_ #-}++-- | 'Control.Monad.foldM' with 'MergingStrategy' knowledge propagation.+mrgFoldM ::+  (MonadTryMerge m, Mergeable b, Foldable t) =>+  (b -> a -> m b) ->+  b ->+  t a ->+  m b+mrgFoldM = Unified.mrgFoldM+{-# INLINE mrgFoldM #-}++-- | 'Control.Monad.foldM_' with 'MergingStrategy' knowledge propagation.+mrgFoldM_ ::+  (MonadTryMerge m, Foldable t, Mergeable b) =>+  (b -> a -> m b) ->+  b ->+  t a ->+  m ()+mrgFoldM_ = Unified.mrgFoldM_+{-# INLINE mrgFoldM_ #-}++-- | 'Control.Monad.replicateM' with 'MergingStrategy' knowledge propagation.+mrgReplicateM ::+  (Applicative m, TryMerge m, Mergeable a) =>+  Int ->+  m a ->+  m [a]+mrgReplicateM = Unified.mrgReplicateM+{-# INLINE mrgReplicateM #-}++-- | 'Control.Monad.replicateM' with 'MergingStrategy' knowledge propagation and+-- symbolic number of elements.+symReplicateM ::+  (MonadUnion m, TryMerge m, Mergeable a, Num int, SymOrd int) =>+  Int ->+  int ->+  m a ->+  m [a]+symReplicateM = Unified.symReplicateM @'S+{-# INLINE symReplicateM #-}++-- | 'Control.Monad.replicateM_' with 'MergingStrategy' knowledge propagation.+mrgReplicateM_ ::+  (Applicative m, TryMerge m, Mergeable a) =>+  Int ->+  m a ->+  m ()+mrgReplicateM_ = Unified.mrgReplicateM_+{-# INLINE mrgReplicateM_ #-}++-- | 'Control.Monad.replicateM_' with 'MergingStrategy' knowledge propagation+-- and symbolic number of elements.+symReplicateM_ ::+  (MonadUnion m, TryMerge m, Mergeable a, Num int, SymOrd int) =>+  Int ->+  int ->+  m a ->+  m ()+symReplicateM_ = Unified.symReplicateM_ @'S+{-# INLINE symReplicateM_ #-}++-- | 'Control.Monad.guard' with 'MergingStrategy' knowledge propagation.+mrgGuard :: (Alternative m, TryMerge m) => Bool -> m ()+mrgGuard = Unified.mrgGuard+{-# INLINE mrgGuard #-}++-- | 'Control.Monad.guard' with 'MergingStrategy' knowledge propagation and+-- symbolic conditions.+symGuard :: (SymBranching m, TryMerge m, Alternative m) => SymBool -> m ()+symGuard = Unified.symGuard+{-# INLINE symGuard #-}++-- | 'Control.Monad.when' with 'MergingStrategy' knowledge propagation.+mrgWhen :: (Applicative m, TryMerge m) => Bool -> m () -> m ()+mrgWhen = Unified.mrgWhen+{-# INLINE mrgWhen #-}++-- | 'Control.Monad.when' with 'MergingStrategy' knowledge propagation and+-- symbolic conditions.+symWhen ::+  (Applicative m, TryMerge m, SymBranching m) => SymBool -> m () -> m ()+symWhen = Unified.symWhen+{-# INLINE symWhen #-}++-- | 'Control.Monad.unless' with 'MergingStrategy' knowledge propagation.+mrgUnless :: (Applicative m, TryMerge m) => Bool -> m () -> m ()+mrgUnless = Unified.mrgUnless+{-# INLINE mrgUnless #-}++-- | 'Control.Monad.unless' with 'MergingStrategy' knowledge propagation and+-- symbolic conditions.+symUnless ::+  (Applicative m, TryMerge m, SymBranching m) => SymBool -> m () -> m ()+symUnless = Unified.symUnless+{-# INLINE symUnless #-}++-- | 'Control.Monad.liftM' with 'MergingStrategy' knowledge propagation.+mrgLiftM ::+  (MonadTryMerge m, Mergeable a, Mergeable b) => (a -> b) -> m a -> m b+mrgLiftM = Unified.mrgLiftM+{-# INLINE mrgLiftM #-}++-- | '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 = Unified.mrgLiftM2+{-# INLINE mrgLiftM2 #-}++-- | 'Control.Monad.liftM3' with '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 = Unified.mrgLiftM3+{-# INLINE mrgLiftM3 #-}++-- | 'Control.Monad.liftM4' with '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 = Unified.mrgLiftM4+{-# INLINE mrgLiftM4 #-}++-- | 'Control.Monad.liftM5' with '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 = Unified.mrgLiftM5+{-# INLINE mrgLiftM5 #-}++-- | '<*>' with 'MergingStrategy' knowledge propagation.+mrgAp ::+  (MonadTryMerge m, Mergeable a, Mergeable b) => m (a -> b) -> m a -> m b+mrgAp = Unified.mrgAp+{-# INLINE mrgAp #-}++infixl 4 .<$!>++-- | '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+(.<$!>) = (Unified..<$!>)+{-# INLINE (.<$!>) #-}
src/Grisette/Lib/Control/Monad.hs-boot view
@@ -10,23 +10,21 @@     (.>>),     mrgMzero,     mrgMplus,-    mrgFmap,   ) where  import Control.Monad (MonadPlus)-import Grisette.Core.Control.Monad.Union (MonadUnion)-import Grisette.Core.Data.Class.Mergeable+import Grisette.Internal.Core.Data.Class.Mergeable   ( Mergeable,     MergingStrategy,   )+import Grisette.Internal.Core.Data.Class.TryMerge (MonadTryMerge) -mrgReturnWithStrategy :: (MonadUnion u) => MergingStrategy a -> a -> u a-mrgBindWithStrategy :: (MonadUnion u) => MergingStrategy b -> u a -> (a -> u b) -> u b-mrgReturn :: (MonadUnion u, Mergeable a) => a -> u a-(.>>=) :: (MonadUnion u, Mergeable b) => u a -> (a -> u b) -> u b-mrgFoldM :: (MonadUnion m, Mergeable b, Foldable t) => (b -> a -> m b) -> b -> t a -> m b-(.>>) :: forall m a b. (MonadUnion m, Mergeable b) => m a -> m b -> m b-mrgMzero :: forall m a. (MonadUnion m, Mergeable a, MonadPlus m) => m a-mrgMplus :: forall m a. (MonadUnion m, Mergeable a, MonadPlus m) => m a -> m a -> m a-mrgFmap :: (MonadUnion f, Mergeable b, Functor f) => (a -> b) -> f a -> f b+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
src/Grisette/Lib/Control/Monad/Except.hs view
@@ -2,7 +2,7 @@  -- | -- Module      :   Grisette.Lib.Control.Monad.Except--- 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@@ -12,24 +12,105 @@   ( -- * mrg* variants for operations in "Control.Monad.Except"     mrgThrowError,     mrgCatchError,+    mrgLiftEither,+    mrgTryError,+    mrgWithError,+    mrgHandleError,+    mrgMapError,+    mrgModifyError,   ) where -import Control.Monad.Except (MonadError (catchError, throwError))-import Grisette.Core.Control.Monad.Union (MonadUnion)-import Grisette.Core.Data.Class.Mergeable (Mergeable)-import Grisette.Core.Data.Class.SimpleMergeable (merge)+import Control.Monad.Except (ExceptT, MonadError (catchError, throwError))+import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable)+import Grisette.Internal.Core.Data.Class.TryMerge (TryMerge, tryMerge)+import Grisette.Lib.Control.Monad (mrgReturn)+import Grisette.Lib.Control.Monad.Trans.Except (mrgRunExceptT)+import Grisette.Lib.Data.Functor (mrgFmap) --- | 'throwError' with 'MergingStrategy' knowledge propagation.-mrgThrowError :: (MonadError e m, MonadUnion m, Mergeable a) => e -> m a-mrgThrowError = merge . throwError+-- | '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 #-} --- | 'catchError' with 'MergingStrategy' knowledge propagation.+-- | 'Control.Monad.Except.catchError' with 'Grisette.Core.MergingStrategy'+-- knowledge propagation. mrgCatchError ::-  (MonadError e m, MonadUnion m, Mergeable a) =>+  (MonadError e m, TryMerge m, Mergeable a) =>   m a ->   (e -> m a) ->   m a-mrgCatchError v handler = merge $ v `catchError` (merge . handler)+mrgCatchError v handler = tryMerge $ v `catchError` (tryMerge . handler) {-# INLINE mrgCatchError #-}++-- | '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 'Grisette.Core.MergingStrategy'+-- knowledge propagation.+mrgTryError ::+  (MonadError e m, TryMerge m, Mergeable a, Mergeable e) =>+  m a ->+  m (Either e a)+mrgTryError action = (mrgFmap Right action) `mrgCatchError` (mrgReturn . Left)+{-# INLINE mrgTryError #-}++-- | 'Control.Monad.Except.withError' with 'Grisette.Core.MergingStrategy'+-- knowledge propagation.+mrgWithError ::+  (MonadError e m, TryMerge m, Mergeable a, Mergeable e) =>+  (e -> e) ->+  m a ->+  m a+mrgWithError f action =+  tryMerge $ mrgTryError action >>= either (mrgThrowError . f) mrgReturn+{-# INLINE mrgWithError #-}++-- | 'Control.Monad.Except.handleError' with 'Grisette.Core.MergingStrategy'+-- knowledge propagation.+mrgHandleError ::+  (MonadError e m, TryMerge m, Mergeable a, Mergeable e) =>+  (e -> m a) ->+  m a ->+  m a+mrgHandleError = flip mrgCatchError+{-# INLINE mrgHandleError #-}++-- | 'Control.Monad.Except.mapError' with 'Grisette.Core.MergingStrategy'+-- knowledge propagation.+mrgMapError ::+  ( MonadError e m,+    TryMerge m,+    MonadError e' n,+    TryMerge n,+    Mergeable a,+    Mergeable b,+    Mergeable e,+    Mergeable e'+  ) =>+  (m (Either e a) -> n (Either e' b)) ->+  m a ->+  n b+mrgMapError f action = tryMerge (f (mrgTryError action)) >>= mrgLiftEither+{-# INLINE mrgMapError #-}++-- | 'Control.Monad.Except.modifyError' with 'Grisette.Core.MergingStrategy'+-- knowledge propagation.+mrgModifyError ::+  ( MonadError e' m,+    TryMerge m,+    Mergeable a,+    Mergeable e,+    Mergeable e+  ) =>+  (e -> e') ->+  ExceptT e m a ->+  m a+mrgModifyError f m =+  tryMerge $ mrgRunExceptT m >>= either (mrgThrowError . f) mrgReturn+{-# INLINE mrgModifyError #-}
src/Grisette/Lib/Control/Monad/State/Class.hs view
@@ -20,52 +20,52 @@ where  import Control.Monad.State.Class (MonadState (get, put))-import Grisette.Core.Data.Class.Mergeable (Mergeable)-import Grisette.Core.Data.Class.SimpleMergeable (UnionLike, merge)+import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable)+import Grisette.Internal.Core.Data.Class.TryMerge (TryMerge, tryMerge) import Grisette.Lib.Control.Monad (mrgReturn) --- | 'Control.Monad.State.Class.get' with 'MergingStrategy' knowledge--- propagation.-mrgGet :: (MonadState s m, UnionLike m, Mergeable s) => m s-mrgGet = merge get+-- | '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.-mrgPut :: (MonadState s m, UnionLike m) => s -> m ()-mrgPut = merge . put+-- | '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, UnionLike m, Mergeable s, Mergeable a) =>+  (MonadState s m, TryMerge m, Mergeable s, Mergeable a) =>   (s -> (a, s)) ->   m a-mrgState f = do+mrgState f = tryMerge $ do   s <- mrgGet   let ~(a, s') = f s   mrgPut s'   mrgReturn a --- | 'Control.Monad.State.Class.modify' with 'MergingStrategy' knowledge--- propagation.-mrgModify :: (MonadState s m, UnionLike m, Mergeable s) => (s -> s) -> m ()+-- | '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.-mrgModify' :: (MonadState s m, UnionLike m, Mergeable s) => (s -> s) -> m ()+-- | '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, UnionLike m, Mergeable s, Mergeable a) =>+  (MonadState s m, TryMerge m, Mergeable s, Mergeable a) =>   (s -> a) ->   m a mrgGets f = do
src/Grisette/Lib/Control/Monad/Trans/Class.hs view
@@ -17,15 +17,14 @@ where  import Control.Monad.Trans (MonadTrans (lift))-import Grisette.Core.Control.Monad.Union (MonadUnion)-import Grisette.Core.Data.Class.Mergeable (Mergeable)-import Grisette.Core.Data.Class.SimpleMergeable (merge)+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.-  (MonadUnion (t m), MonadTrans t, Monad m, Mergeable a) =>+  (TryMerge (t m), MonadTrans t, Monad m, Mergeable a) =>   m a ->   t m a-mrgLift v = merge $ lift v+mrgLift v = tryMerge $ lift v {-# INLINE mrgLift #-}
src/Grisette/Lib/Control/Monad/Trans/Cont.hs view
@@ -18,24 +18,30 @@  import Control.Monad.Cont (ContT (runContT)) import Control.Monad.Trans.Class (lift)-import Grisette.Core.Data.Class.Mergeable (Mergeable)-import Grisette.Core.Data.Class.SimpleMergeable-  ( UnionLike,-    merge,+import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable)+import Grisette.Internal.Core.Data.Class.TryMerge+  ( TryMerge,+    tryMerge,   ) import Grisette.Lib.Control.Monad (mrgReturn) --- | 'Control.Monad.Cont.runContT' with 'MergingStrategy' knowledge propagation-mrgRunContT :: (UnionLike m, Mergeable r) => ContT r m a -> (a -> m r) -> m r-mrgRunContT c = merge . runContT c+-- | '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-mrgEvalContT :: (UnionLike m, Mergeable r, Monad m) => ContT r m r -> m r+-- | '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-mrgResetT :: (UnionLike m, Mergeable r, Monad m) => (Monad m) => ContT r m r -> ContT r' m r+-- | 'Control.Monad.Cont.resetT' with 'Grisette.Core.MergingStrategy' knowledge+-- propagation.+mrgResetT ::+  (TryMerge m, Mergeable r, Monad m) =>+  ContT r m r ->+  ContT r' m r mrgResetT = lift . mrgEvalContT {-# INLINE mrgResetT #-}
+ src/Grisette/Lib/Control/Monad/Trans/Except.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE Trustworthy #-}++-- |+-- Module      :   Grisette.Lib.Control.Monad.Trans.Except+-- 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.Lib.Control.Monad.Trans.Except+  ( mrgExcept,+    mrgRunExceptT,+    mrgWithExceptT,+    mrgThrowE,+    mrgCatchE,+  )+where++import Control.Monad.Trans.Except+  ( ExceptT,+    catchE,+    except,+    runExceptT,+    throwE,+    withExceptT,+  )+import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable)+import Grisette.Internal.Core.Data.Class.TryMerge (MonadTryMerge, tryMerge)++-- | '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+-- '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+-- 'Grisette.Core.MergingStrategy' knowledge propagation.+mrgWithExceptT ::+  (MonadTryMerge m, Mergeable a, Mergeable e, Mergeable e') =>+  (e -> e') ->+  ExceptT e m a ->+  ExceptT e' m a+mrgWithExceptT f e = tryMerge $ withExceptT f (tryMerge e)+{-# INLINE mrgWithExceptT #-}++-- | '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 'Grisette.Core.MergingStrategy'+-- knowledge propagation.+mrgCatchE ::+  (MonadTryMerge m, Mergeable e, Mergeable a) =>+  ExceptT e m a ->+  (e -> ExceptT e m a) ->+  ExceptT e m a+mrgCatchE value handler =+  tryMerge $ catchE (tryMerge value) (tryMerge . handler)+{-# INLINE mrgCatchE #-}
src/Grisette/Lib/Control/Monad/Trans/State/Lazy.hs view
@@ -28,103 +28,103 @@   ( StateT (StateT),     runStateT,   )-import Grisette.Core.Data.Class.Mergeable (Mergeable)-import Grisette.Core.Data.Class.SimpleMergeable (UnionLike, merge)+import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable)+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, UnionLike m, Mergeable s, Mergeable a) =>+  (Monad m, TryMerge m, Mergeable s, Mergeable a) =>   (s -> (a, s)) ->   StateT s m a 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, UnionLike m, Mergeable s, Mergeable a) =>+  (Monad m, TryMerge m, Mergeable s, Mergeable a) =>   StateT s m a ->   s ->   m (a, s)-mrgRunStateT m s = runStateT m s >>= mrgReturn+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, UnionLike m, Mergeable a) =>+  (Monad m, TryMerge m, Mergeable a) =>   StateT s m a ->   s ->   m a-mrgEvalStateT m s = do+mrgEvalStateT m s = tryMerge $ do   ~(a, _) <- runStateT m s-  mrgReturn a+  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, UnionLike m, Mergeable s) =>+  (Monad m, TryMerge m, Mergeable s) =>   StateT s m a ->   s ->   m s-mrgExecStateT m s = do+mrgExecStateT m s = tryMerge $ do   ~(_, s') <- runStateT m s-  mrgReturn s'+  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 ::-  (UnionLike n, Mergeable b, Mergeable s) =>+  (TryMerge n, Mergeable b, Mergeable s) =>   (m (a, s) -> n (b, s)) ->   StateT s m a ->   StateT s n b-mrgMapStateT f m = StateT $ merge . f . runStateT m+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 ::-  (UnionLike m, Mergeable s, Mergeable a) =>+  (TryMerge m, Mergeable s, Mergeable a) =>   (s -> s) ->   StateT s m a ->   StateT s m a-mrgWithStateT f m = StateT $ merge . runStateT m . f+mrgWithStateT f m = StateT $ tryMerge . runStateT m . f {-# INLINE mrgWithStateT #-} --- | 'Control.Monad.Trans.State.Lazy.get' with 'MergingStrategy' knowledge--- propagation.-mrgGet :: (Monad m, UnionLike m, Mergeable s) => StateT s m s+-- | '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.-mrgPut :: (Monad m, UnionLike m, Mergeable s) => s -> StateT s m ()+-- | '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.-mrgModify :: (Monad m, UnionLike m, Mergeable s) => (s -> s) -> StateT s m ()+-- | '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.-mrgModify' :: (Monad m, UnionLike m, Mergeable s) => (s -> s) -> StateT s m ()+-- | '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, UnionLike m, Mergeable s, Mergeable a) =>+  (Monad m, TryMerge m, Mergeable s, Mergeable a) =>   (s -> a) ->   StateT s m a mrgGets f = mrgState $ \s -> (f s, s)
src/Grisette/Lib/Control/Monad/Trans/State/Strict.hs view
@@ -28,103 +28,103 @@   ( StateT (StateT),     runStateT,   )-import Grisette.Core.Data.Class.Mergeable (Mergeable)-import Grisette.Core.Data.Class.SimpleMergeable (UnionLike, merge)+import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable)+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, UnionLike m, Mergeable s, Mergeable a) =>+  (Monad m, TryMerge m, Mergeable s, Mergeable a) =>   (s -> (a, s)) ->   StateT s m a 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, UnionLike m, Mergeable s, Mergeable a) =>+  (Monad m, TryMerge m, Mergeable s, Mergeable a) =>   StateT s m a ->   s ->   m (a, s)-mrgRunStateT m s = runStateT m s >>= mrgReturn+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, UnionLike m, Mergeable a) =>+  (Monad m, TryMerge m, Mergeable a) =>   StateT s m a ->   s ->   m a-mrgEvalStateT m s = do+mrgEvalStateT m s = tryMerge $ do   (a, _) <- runStateT m s-  mrgReturn a+  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, UnionLike m, Mergeable s) =>+  (Monad m, TryMerge m, Mergeable s) =>   StateT s m a ->   s ->   m s-mrgExecStateT m s = do+mrgExecStateT m s = tryMerge $ do   (_, s') <- runStateT m s-  mrgReturn s'+  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 ::-  (UnionLike n, Mergeable b, Mergeable s) =>+  (TryMerge n, Mergeable b, Mergeable s) =>   (m (a, s) -> n (b, s)) ->   StateT s m a ->   StateT s n b-mrgMapStateT f m = StateT $ merge . f . runStateT m+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 ::-  (UnionLike m, Mergeable s, Mergeable a) =>+  (TryMerge m, Mergeable s, Mergeable a) =>   (s -> s) ->   StateT s m a ->   StateT s m a-mrgWithStateT f m = StateT $ merge . runStateT m . f+mrgWithStateT f m = StateT $ tryMerge . runStateT m . f {-# INLINE mrgWithStateT #-} --- | 'Control.Monad.Trans.State.Strict.get' with 'MergingStrategy' knowledge--- propagation.-mrgGet :: (Monad m, UnionLike m, Mergeable s) => StateT s m s+-- | '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.-mrgPut :: (Monad m, UnionLike m, Mergeable s) => s -> StateT s m ()+-- | '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.-mrgModify :: (Monad m, UnionLike m, Mergeable s) => (s -> s) -> StateT s m ()+-- | '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.-mrgModify' :: (Monad m, UnionLike m, Mergeable s) => (s -> s) -> StateT s m ()+-- | '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, UnionLike m, Mergeable s, Mergeable a) =>+  (Monad m, TryMerge m, Mergeable s, Mergeable a) =>   (s -> a) ->   StateT s m a mrgGets f = mrgState $ \s -> (f s, s)
+ src/Grisette/Lib/Data/Bool.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE KindSignatures #-}+{-# 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.TH.Ctor.SmartConstructor+  ( makePrefixedSmartCtor,+  )++makePrefixedSmartCtor "mrg" ''Bool
+ src/Grisette/Lib/Data/Either.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE KindSignatures #-}+{-# 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.TH.Ctor.SmartConstructor+  ( makePrefixedSmartCtor,+  )++makePrefixedSmartCtor "mrg" ''Either
src/Grisette/Lib/Data/Foldable.hs view
@@ -1,81 +1,254 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeApplications #-}  -- | -- Module      :   Grisette.Lib.Control.Foldable--- 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.Lib.Data.Foldable-  ( -- * mrg* variants for operations in "Data.Foldable"-    mrgFoldlM,+  ( symElem,+    symMaximum,+    mrgMaximum,+    symMinimum,+    mrgMinimum,++    -- * Special biased folds     mrgFoldrM,+    mrgFoldlM,++    -- * Folding actions++    -- ** Applicative actions     mrgTraverse_,     mrgFor_,+    mrgSequenceA_,+    mrgAsum,++    -- ** Monadic actions     mrgMapM_,     mrgForM_,     mrgSequence_,     mrgMsum,++    -- ** Specialized folds+    symAnd,+    symOr,+    symAny,+    symAll,+    symMaximumBy,+    mrgMaximumBy,+    symMinimumBy,+    mrgMinimumBy,++    -- ** Searches+    symNotElem,+    mrgFind,   ) where  import Control.Monad (MonadPlus)-import Grisette.Core.Control.Monad.Union (MonadUnion)-import Grisette.Core.Data.Class.Mergeable (Mergeable)-import Grisette.Core.Data.Class.SimpleMergeable (merge)-import {-# SOURCE #-} Grisette.Lib.Control.Monad-  ( mrgMplus,-    mrgMzero,-    mrgReturn,+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.Mergeable (Mergeable)+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,   )+import Grisette.Internal.SymPrim.SymBool (SymBool)+import Grisette.Lib.Control.Applicative (mrgAsum)+import Grisette.Unified (EvalModeTag (S))+import qualified Grisette.Unified.Lib.Data.Foldable as Unified --- | 'Data.Foldable.foldlM' with 'MergingStrategy' knowledge propagation.-mrgFoldlM :: (MonadUnion m, Mergeable b, Foldable t) => (b -> a -> m b) -> b -> t a -> m b-mrgFoldlM f z0 xs = foldr c mrgReturn xs z0-  where-    c x k z = merge (f z x) >>= k-{-# INLINE mrgFoldlM #-}+-- | 'Data.Foldable.elem' with symbolic equality.+symElem :: (Foldable t, SymEq a) => a -> t a -> SymBool+symElem = Unified.symElem+{-# INLINE symElem #-} --- | 'Data.Foldable.foldrM' with 'MergingStrategy' knowledge propagation.-mrgFoldrM :: (MonadUnion m, Mergeable b, Foldable t) => (a -> b -> m b) -> b -> t a -> m b-mrgFoldrM f z0 xs = foldl c mrgReturn xs z0-  where-    c k x z = merge (f x z) >>= k+-- | 'Data.Foldable.maximum' with 'Grisette.Core.MergingStrategy' knowledge+-- propagation.+mrgMaximum ::+  forall a t m.+  (Foldable t, MonadUnion m, Mergeable a, SymOrd a) =>+  t a ->+  m a+mrgMaximum = Unified.mrgMaximum @'S+{-# INLINE mrgMaximum #-}++-- | 'Data.Foldable.maximum' with result merged with 'ITEOp'.+symMaximum ::+  forall a t.+  (Foldable t, Mergeable a, SymOrd a, ITEOp a) =>+  t a ->+  a+symMaximum = Unified.symMaximum @'S+{-# INLINE symMaximum #-}++-- | 'Data.Foldable.minimum' with 'Grisette.Core.MergingStrategy' knowledge+-- propagation.+mrgMinimum ::+  forall a t m.+  (Foldable t, MonadUnion m, Mergeable a, SymOrd a) =>+  t a ->+  m a+mrgMinimum = Unified.mrgMinimum @'S+{-# INLINE mrgMinimum #-}++-- | 'Data.Foldable.minimum' with result merged with 'ITEOp'.+symMinimum ::+  forall a t.+  (Foldable t, Mergeable a, SymOrd a, ITEOp a) =>+  t a ->+  a+symMinimum = Unified.symMinimum @'S+{-# 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 = Unified.mrgFoldrM {-# INLINE mrgFoldrM #-} --- | 'Data.Foldable.traverse_' with 'MergingStrategy' knowledge propagation.-mrgTraverse_ :: (MonadUnion m, Foldable t) => (a -> m b) -> t a -> m ()-mrgTraverse_ f = foldr c (mrgReturn ())-  where-    c x k = f x >> k+-- | '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 = Unified.mrgFoldlM+{-# 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_ = Unified.mrgTraverse_ {-# INLINE mrgTraverse_ #-} --- | 'Data.Foldable.for_' with 'MergingStrategy' knowledge propagation.-mrgFor_ :: (MonadUnion m, Foldable t) => t a -> (a -> m b) -> m ()-mrgFor_ = flip mrgTraverse_+-- | 'Data.Foldable.for_' with 'Grisette.Core.MergingStrategy' knowledge+-- propagation.+mrgFor_ ::+  (Applicative m, TryMerge m, Foldable t) => t a -> (a -> m b) -> m ()+mrgFor_ = Unified.mrgFor_ {-# INLINE mrgFor_ #-} --- | 'Data.Foldable.mapM_' with 'MergingStrategy' knowledge propagation.-mrgMapM_ :: (MonadUnion m, Foldable t) => (a -> m b) -> t a -> m ()-mrgMapM_ = mrgTraverse_+-- | 'Data.Foldable.sequence_' with 'Grisette.Core.MergingStrategy' knowledge+-- propagation.+mrgSequenceA_ ::+  (Foldable t, TryMerge m, Applicative m) => t (m a) -> m ()+mrgSequenceA_ = Unified.mrgSequenceA_+{-# INLINE mrgSequenceA_ #-}++-- | 'Data.Foldable.mapM_' with 'Grisette.Core.MergingStrategy' knowledge+-- propagation.+mrgMapM_ :: (MonadTryMerge m, Foldable t) => (a -> m b) -> t a -> m ()+mrgMapM_ = Unified.mrgMapM_ {-# INLINE mrgMapM_ #-} --- | 'Data.Foldable.forM_' with 'MergingStrategy' knowledge propagation.-mrgForM_ :: (MonadUnion m, Foldable t) => t a -> (a -> m b) -> m ()-mrgForM_ = flip mrgMapM_+-- | 'Data.Foldable.forM_' with 'Grisette.Core.MergingStrategy' knowledge+-- propagation.+mrgForM_ :: (MonadTryMerge m, Foldable t) => t a -> (a -> m b) -> m ()+mrgForM_ = Unified.mrgForM_ {-# INLINE mrgForM_ #-} --- | 'Data.Foldable.sequence_' with 'MergingStrategy' knowledge propagation.-mrgSequence_ :: (Foldable t, MonadUnion m) => t (m a) -> m ()-mrgSequence_ = foldr c (mrgReturn ())-  where-    c m k = m >> k+-- | 'Data.Foldable.sequence_' with 'Grisette.Core.MergingStrategy' knowledge+-- propagation.+mrgSequence_ :: (Foldable t, MonadTryMerge m) => t (m a) -> m ()+mrgSequence_ = Unified.mrgSequence_ {-# INLINE mrgSequence_ #-} --- | 'Data.Foldable.msum' with 'MergingStrategy' knowledge propagation.-mrgMsum :: forall m a t. (MonadUnion m, Mergeable a, MonadPlus m, Foldable t) => t (m a) -> m a-mrgMsum = foldr mrgMplus mrgMzero+-- | 'Data.Foldable.msum' with 'Grisette.Core.MergingStrategy' knowledge+-- propagation.+mrgMsum ::+  (MonadTryMerge m, Mergeable a, MonadPlus m, Foldable t) => t (m a) -> m a+mrgMsum = Unified.mrgMsum {-# INLINE mrgMsum #-}++-- | 'Data.Foldable.and' on symbolic boolean.+symAnd :: (Foldable t) => t SymBool -> SymBool+symAnd = Unified.symAnd++-- | 'Data.Foldable.or' on symbolic boolean.+symOr :: (Foldable t) => t SymBool -> SymBool+symOr = Unified.symOr++-- | 'Data.Foldable.any' on symbolic boolean.+symAny :: (Foldable t) => (a -> SymBool) -> t a -> SymBool+symAny = Unified.symAny++-- | 'Data.Foldable.all' on symbolic boolean.+symAll :: (Foldable t) => (a -> SymBool) -> t a -> SymBool+symAll = Unified.symAll++-- | 'Data.Foldable.maximumBy' with 'Grisette.Core.MergingStrategy' knowledge+-- propagation.+mrgMaximumBy ::+  forall t a m.+  (Foldable t, Mergeable a, MonadUnion m) =>+  (a -> a -> Union Ordering) ->+  t a ->+  m a+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 -> Union Ordering) ->+  t a ->+  a+symMaximumBy = Unified.symMaximumBy+{-# INLINE symMaximumBy #-}++-- | 'Data.Foldable.minimumBy' with 'Grisette.Core.MergingStrategy' knowledge+-- propagation.+mrgMinimumBy ::+  forall t a m.+  (Foldable t, Mergeable a, MonadUnion m) =>+  (a -> a -> Union Ordering) ->+  t a ->+  m a+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 -> Union Ordering) ->+  t a ->+  a+symMinimumBy = Unified.symMinimumBy+{-# INLINE symMinimumBy #-}++-- | 'Data.Foldable.elem' with symbolic equality.+symNotElem :: (Foldable t, SymEq a) => a -> t a -> SymBool+symNotElem = Unified.symNotElem+{-# INLINE symNotElem #-}++-- | '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 = Unified.mrgFind+{-# INLINE mrgFind #-}
+ src/Grisette/Lib/Data/Functor.hs view
@@ -0,0 +1,80 @@+-- |+-- Module      :   Grisette.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.Lib.Data.Functor+  ( mrgFmap,+    (.<$),+    (.$>),+    (.<$>),+    (.<&>),+    mrgUnzip,+    mrgVoid,+  )+where++import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable)+import Grisette.Internal.Core.Data.Class.TryMerge (TryMerge)+import qualified Grisette.Unified.Lib.Data.Functor as Unified++-- | 'fmap' with 'Grisette.Core.MergingStrategy' knowledge propagation.+mrgFmap ::+  (TryMerge f, Mergeable a, Mergeable b, Functor f) =>+  (a -> b) ->+  f a ->+  f b+mrgFmap = Unified.mrgFmap+{-# INLINE mrgFmap #-}++infixl 4 .<$>++-- | '<$>' with 'Grisette.Core.MergingStrategy' knowledge propagation.+(.<$>) ::+  (TryMerge f, Mergeable a, Mergeable b, Functor f) => (a -> b) -> f a -> f b+(.<$>) = (Unified..<$>)+{-# INLINE (.<$>) #-}++infixl 4 .<$++-- | '<$' with 'Grisette.Core.MergingStrategy' knowledge propagation.+(.<$) :: (TryMerge f, Mergeable a, Mergeable b, Functor f) => b -> f a -> f b+(.<$) = (Unified..<$)+{-# INLINE (.<$) #-}++infixl 4 .$>++-- | 'Data.Functor.$>' with 'Grisette.Core.MergingStrategy' knowledge+-- propagation.+(.$>) :: (TryMerge f, Mergeable a, Mergeable b, Functor f) => f a -> b -> f b+(.$>) = (Unified..$>)+{-# 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+(.<&>) = (Unified..<&>)+{-# 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 = Unified.mrgUnzip+{-# INLINE mrgUnzip #-}++-- | 'Data.Functor.void' with 'Grisette.Core.MergingStrategy' knowledge+-- propagation.+mrgVoid :: (TryMerge f, Functor f) => f a -> f ()+mrgVoid = Unified.mrgVoid+{-# INLINE mrgVoid #-}
+ src/Grisette/Lib/Data/Functor/Sum.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# 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.TH.Ctor.SmartConstructor+  ( makePrefixedSmartCtor,+  )++makePrefixedSmartCtor "mrg" ''Sum
src/Grisette/Lib/Data/List.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}  -- | -- Module      :   Grisette.Lib.Data.List@@ -9,59 +10,617 @@ -- Stability   :   Experimental -- Portability :   GHC only module Grisette.Lib.Data.List-  ( -- * Symbolic versions of 'Data.List' operations-    (.!!),-    symFilter,-    symTake,-    symDrop,+  ( -- * Special folds+    symAnd,+    symOr,+    symAny,+    symAll,+    mrgMaximum,+    symMaximum,+    mrgMinimum,+    symMinimum,++    -- * Sublists++    -- ** Extracting sublists+    mrgTake,+    mrgDrop,+    mrgSplitAt,+    mrgTakeWhile,+    mrgDropWhile,+    mrgDropWhileEnd,+    mrgSpan,+    mrgBreak,+    mrgStripPrefix,+    mrgGroup,++    -- ** Predicates+    symIsPrefixOf,+    symIsSuffixOf,+    symIsInfixOf,+    symIsSubsequenceOf,++    -- * Searching lists++    -- ** Searching by equality+    symElem,+    symNotElem,+    mrgLookup,++    -- ** Searching with a predicate+    mrgFind,+    mrgFilter,+    mrgPartition,++    -- * Indexing lists+    (.!?),+    mrgElemIndex,+    mrgElemIndices,+    mrgFindIndex,+    mrgFindIndices,++    -- * Special lists++    -- ** "Set" operations+    mrgNub,+    mrgDelete,+    (.\\),+    mrgUnion,+    mrgIntersect,++    -- ** Ordered lists (sorting not supported yet)+    mrgInsert,++    -- * Generalized functions++    -- ** The "By" operations++    -- *** User-supplied equality (replacing an 'SymEq' context)+    mrgNubBy,+    mrgDeleteBy,+    mrgDeleteFirstsBy,+    mrgUnionBy,+    mrgIntersectBy,+    mrgGroupBy,++    -- *** User-supplied comparison (replacing an 'SymOrd' context)+    mrgInsertBy,+    mrgMaximumBy,+    symMaximumBy,+    mrgMinimumBy,+    symMinimumBy,   ) where -import Control.Exception (ArrayException (IndexOutOfBounds))-import Control.Monad.Except (MonadError (throwError))-import Grisette.Core.Control.Monad.Union (MonadUnion)-import Grisette.Core.Data.Class.Error (TransformError (transformError))-import Grisette.Core.Data.Class.Mergeable (Mergeable)-import Grisette.Core.Data.Class.SEq (SEq ((.==)))-import Grisette.Core.Data.Class.SOrd (SOrd ((.<=)))-import Grisette.Core.Data.Class.SimpleMergeable (mrgIf)-import Grisette.IR.SymPrim.Data.SymPrim (SymBool, SymInteger)-import Grisette.Lib.Control.Monad (mrgFmap, mrgReturn)+import Data.Bifunctor (Bifunctor (first, second))+import Data.List (tails)+import Data.Maybe (listToMaybe)+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 (symIte))+import Grisette.Internal.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.&&), (.||)))+import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable)+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.Core.Data.Class.UnionView (liftUnion)+import Grisette.Internal.SymPrim.SymBool (SymBool)+import Grisette.Lib.Control.Applicative (mrgPure)+import Grisette.Lib.Control.Monad (mrgReturn)+import Grisette.Lib.Data.Foldable+  ( mrgFind,+    mrgFoldlM,+    mrgMaximum,+    mrgMaximumBy,+    mrgMinimum,+    mrgMinimumBy,+    symAll,+    symAnd,+    symAny,+    symElem,+    symMaximum,+    symMaximumBy,+    symMinimum,+    symMinimumBy,+    symNotElem,+    symOr,+  )+import Grisette.Lib.Data.Functor (mrgFmap) --- | Symbolic version of 'Data.List.!!', the result would be merged and+symListOpOnSymInt ::+  (Applicative u, SymBranching u, Mergeable b, Num int, SymOrd int) =>+  Bool ->+  (Int -> [a] -> b) ->+  int ->+  [a] ->+  u b+symListOpOnSymInt reversed f x vs = do+  let zipped =+        (\n -> (fromIntegral n, mrgPure $ f n vs))+          <$> (if reversed then reverse else id) [1 .. length vs - 1]+  let outerMostX = if reversed then length vs else 0+  let innerMostX = if reversed then 0 else length vs+  let guardCond =+        if reversed then (x .>= fromIntegral (length vs)) else (x .<= 0)+  mrgIf guardCond (mrgPure $ f outerMostX vs) $+    foldr+      (\(n, l) acc -> mrgIf (x .== n) l acc)+      (mrgPure $ f innerMostX vs)+      zipped++-- | Symbolic version of 'Data.List.take', the result would be merged and -- propagate the mergeable knowledge.-(.!!) ::+--+-- Can generate O(n) cases and O(n) sized branch constraints.+mrgTake ::+  (Applicative u, SymBranching u, Mergeable a, Num int, SymOrd int) =>+  int ->+  [a] ->+  u [a]+mrgTake = symListOpOnSymInt False take++-- | Symbolic version of 'Data.List.drop', the result would be merged and+-- propagate the mergeable knowledge.+--+-- Can generate O(n) cases and O(n) sized branch constraints.+mrgDrop ::+  (Applicative u, SymBranching u, Mergeable a, Num int, SymOrd int) =>+  int ->+  [a] ->+  u [a]+mrgDrop = symListOpOnSymInt True drop++-- | Symbolic version of 'Data.List.splitAt', the result would be merged and+-- propagate the mergeable knowledge.+--+-- Can generate O(n) cases and O(n) sized branch constraints.+mrgSplitAt ::+  forall a int u.+  (MonadUnion u, Mergeable a, Num int, SymOrd int) =>+  int ->+  [a] ->+  u ([a], [a])+mrgSplitAt = symListOpOnSymInt False splitAt++-- | Symbolic version of 'Data.List.takeWhile', the result would be merged and+-- propagate the mergeable knowledge.+--+-- Can generate O(n) cases and O(n) sized branch constraints.+mrgTakeWhile ::+  (Applicative u, SymBranching u, Mergeable a) =>+  (a -> SymBool) ->+  [a] ->+  u [a]+mrgTakeWhile _ [] = mrgPure []+mrgTakeWhile p (x : xs) =+  mrgIf (p x) (mrgFmap (x :) $ mrgTakeWhile p xs) (mrgPure [])++-- | Symbolic version of 'Data.List.dropWhile', the result would be merged and+-- propagate the mergeable knowledge.+--+-- Can generate O(n) cases and O(n) sized branch constraints.+mrgDropWhile ::+  (Applicative u, SymBranching u, Mergeable a) =>+  (a -> SymBool) ->+  [a] ->+  u [a]+mrgDropWhile _ [] = mrgPure []+mrgDropWhile p r = do+  let allConds = reverse $ scanl1 (.&&) $ p <$> r+  foldr (\(cond, l) acc -> mrgIf cond (pure l) acc) (pure r) $+    zip allConds $+      reverse $+        tails r++-- | Symbolic version of 'Data.List.dropWhileEnd', the result would be merged+-- and propagate the mergeable knowledge.+--+-- Can generate O(n) cases and O(n) sized branch constraints.+mrgDropWhileEnd ::+  (MonadUnion u, Mergeable a) =>+  (a -> SymBool) ->+  [a] ->+  u [a]+mrgDropWhileEnd p =+  foldr+    ( \x xs -> do+        xsv <- xs+        mrgIf (p x .&& con (null xsv)) (mrgPure []) (mrgPure $ x : xsv)+    )+    (mrgPure [])++-- | Symbolic version of 'Data.List.span', the result would be merged and+-- propagate the mergeable knowledge.+--+-- Can generate O(n) cases and O(n) sized branch constraints.+mrgSpan ::+  (Applicative u, SymBranching u, Mergeable a) =>+  (a -> SymBool) ->+  [a] ->+  u ([a], [a])+mrgSpan _ [] = mrgPure ([], [])+mrgSpan p xs@(x : xs') =+  mrgIf (p x) (mrgFmap (first (x :)) $ mrgSpan p xs') (mrgPure ([], xs))++-- | Symbolic version of 'Data.List.break', the result would be merged and+-- propagate the mergeable knowledge.+--+-- Can generate O(n) cases and O(n) sized branch constraints.+mrgBreak ::+  (Applicative u, SymBranching u, Mergeable a) =>+  (a -> SymBool) ->+  [a] ->+  u ([a], [a])+mrgBreak p = mrgSpan (symNot . p)++-- | Symbolic version of 'Data.List.stripPrefix', the result would be merged and+-- propagate the mergeable knowledge.+--+-- Generate O(1) cases and O(len(prefix)) sized branch constraints.+mrgStripPrefix ::+  (Applicative u, SymBranching u, Mergeable a, SymEq a) =>+  [a] ->+  [a] ->+  u (Maybe [a])+mrgStripPrefix [] ys = mrgPure $ Just ys+mrgStripPrefix (x : xs) (y : ys) =+  mrgIf (x .== y) (mrgStripPrefix xs ys) (mrgPure Nothing)+mrgStripPrefix _ _ = mrgPure Nothing++-- | Symbolic version of 'Data.List.group', the result would be merged and+-- propagate the mergeable knowledge.+--+-- This function can be very inefficient on large symbolic lists and generate+-- O(2^n) cases. Use with caution.+mrgGroup ::+  (MonadUnion u, Mergeable a, SymEq a) =>+  [a] ->+  u [[a]]+mrgGroup = mrgGroupBy (.==)++-- | Symbolic version of 'Data.List.isPrefixOf'.+--+-- Generate O(len(prefix)) sized constraints.+symIsPrefixOf :: (SymEq a) => [a] -> [a] -> SymBool+symIsPrefixOf [] _ = con True+symIsPrefixOf _ [] = con False+symIsPrefixOf (x : xs) (y : ys) =+  x .== y .&& symIsPrefixOf xs ys++-- | Symbolic version of 'Data.List.isSuffixOf'.+--+-- Generate O(len(suffix)) sized constraints.+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 :: (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 :: (SymEq a) => [a] -> [a] -> SymBool+symIsSubsequenceOf [] _ = con True+symIsSubsequenceOf _ [] = con False+symIsSubsequenceOf a@(x : a') (y : b) =+  symIte (x .== y) (symIsSubsequenceOf a' b) (symIsSubsequenceOf a b)++-- | Symbolic version of 'Data.List.lookup', the result would be merged and+-- propagate the mergeable knowledge.+--+-- Can generate O(n) cases and O(n) sized branch constraints.+mrgLookup ::+  forall a b u.+  (Applicative u, SymBranching u, Mergeable b, SymEq a) =>+  a ->+  [(a, b)] ->+  u (Maybe b)+mrgLookup _ [] = mrgPure Nothing+mrgLookup key l =+  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) =+      mrgIf (key .== x) (mrgPure $ Just y) (mrgLookup' xys)++-- | Symbolic version of 'Data.List.filter', the result would be merged and+-- propagate the mergeable knowledge.+--+-- This function can be very inefficient on large symbolic lists and generate+-- O(2^n) cases. Use with caution.+mrgFilter ::+  (Applicative u, SymBranching u, Mergeable a) =>+  (a -> SymBool) ->+  [a] ->+  u [a]+mrgFilter _ [] = mrgPure []+mrgFilter p (x : xs) =+  mrgIf (p x) (mrgFmap (x :) $ mrgFilter p xs) (mrgFilter p xs)++-- | Symbolic version of 'Data.List.partition', the result would be merged and+-- propagate the mergeable knowledge.+--+-- This function can be very inefficient on large symbolic lists and generate+-- O(2^n) cases. Use with caution.+mrgPartition ::+  forall u a.+  (Applicative u, SymBranching u, Mergeable a) =>+  (a -> SymBool) ->+  [a] ->+  u ([a], [a])+mrgPartition _ [] = mrgPure ([], [])+mrgPartition p (x : xs) =+  mrgIf+    (p x)+    (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+-- propagate the mergeable knowledge.+--+-- Can generate O(1) cases and O(n) sized branch constraints.+(.!?) ::+  forall a uf int.   ( MonadUnion uf,-    MonadError e uf,-    TransformError ArrayException e,-    Mergeable a+    Mergeable a,+    Num int,+    SymEq int   ) =>   [a] ->-  SymInteger ->-  uf a-l .!! p = go l p 0+  int ->+  uf (Maybe a)+l .!? p = go l p 0   where-    go [] _ _ = throwError $ transformError (IndexOutOfBounds "!!~")-    go (x : xs) p1 i = mrgIf (p1 .== i) (mrgReturn x) (go xs p1 $ i + 1)+    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) --- | Symbolic version of 'Data.List.filter', the result would be merged and+-- | Symbolic version of 'Data.List.elemIndex', the result would be merged and -- propagate the mergeable knowledge.-symFilter :: (MonadUnion u, Mergeable a) => (a -> SymBool) -> [a] -> u [a]-symFilter f = go+--+-- Can generate O(n) cases (or O(1) if int is merged), and O(n^2) sized+-- constraints.+mrgElemIndex ::+  (MonadUnion u, Mergeable int, SymEq a, Num int) =>+  a ->+  [a] ->+  u (Maybe int)+mrgElemIndex x = mrgFindIndex (x .==)++-- | Symbolic version of 'Data.List.elemIndices', the result would be merged and+-- propagate the mergeable knowledge.+--+-- Can generate O(n) cases, and O(n^3) sized constraints.+mrgElemIndices ::+  (MonadUnion u, Mergeable int, SymEq a, Num int) =>+  a ->+  [a] ->+  u [int]+mrgElemIndices x = mrgFindIndices (x .==)++-- | Symbolic version of 'Data.List.findIndex', the result would be merged and+-- propagate the mergeable knowledge.+--+-- 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, SymBranching u, Mergeable int, SymEq a, Num int) =>+  (a -> SymBool) ->+  [a] ->+  u (Maybe int)+mrgFindIndex p l = mrgFmap listToMaybe $ mrgFindIndices p l++-- | Symbolic version of 'Data.List.findIndices', the result would be merged and+-- propagate the mergeable knowledge.+--+-- Can generate O(n) cases, and O(n^3) sized constraints, assuming the predicate+-- only generates O(1) constraints.+mrgFindIndices ::+  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 [] = mrgReturn []-    go (x : xs) = do-      r <- go xs-      mrgIf (f x) (mrgReturn (x : r)) (mrgReturn r)+    go :: [(a, int)] -> u [int]+    go [] = mrgPure []+    go ((x, y) : xys) = mrgIf (p x) (mrgFmap (y :) $ go xys) (go xys) --- | Symbolic version of 'Data.List.take', the result would be merged and+-- | Symbolic version of 'Data.List.nub', the result would be merged and -- propagate the mergeable knowledge.-symTake :: (MonadUnion u, Mergeable a) => SymInteger -> [a] -> u [a]-symTake _ [] = mrgReturn []-symTake x (v : vs) = mrgIf (x .<= 0) (mrgReturn []) (mrgFmap (v :) $ symTake (x - 1) vs)+--+-- Can generate O(n) cases, and O(n^3) sized constraints.+mrgNub ::+  (Applicative u, SymBranching u, Mergeable a, SymEq a) =>+  [a] ->+  u [a]+mrgNub = mrgNubBy (.==) --- | Symbolic version of 'Data.List.drop', the result would be merged and+-- | Symbolic version of 'Data.List.delete', the result would be merged and -- propagate the mergeable knowledge.-symDrop :: (MonadUnion u, Mergeable a) => SymInteger -> [a] -> u [a]-symDrop _ [] = mrgReturn []-symDrop x r@(_ : vs) = mrgIf (x .<= 0) (mrgReturn r) (symDrop (x - 1) vs)+--+-- Can generate O(n) cases, and O(n^2) sized constraints.+mrgDelete ::+  (Applicative u, SymBranching u, Mergeable a, SymEq a) =>+  a ->+  [a] ->+  u [a]+mrgDelete = mrgDeleteBy (.==)++-- | Symbolic version of 'Data.List.\\', the result would be merged and+-- propagate the mergeable knowledge.+--+-- Can generate O(len(lhs)) cases, and O(len(lhs)^2 * len(rhs)) sized+-- constraints.+(.\\) ::+  (MonadUnion u, Mergeable a, SymEq a) =>+  [a] ->+  [a] ->+  u [a]+(.\\) = mrgDeleteFirstsBy (.==)++-- | Symbolic version of 'Data.List.union', the result would be merged and+-- propagate the mergeable knowledge.+--+-- Can generate O(len(rhs)) cases, and O(len(rhs)^5 * len(lhs)) sized+-- constraints.+--+-- Should be improvable.+mrgUnion ::+  (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, SymEq a) =>+  [a] ->+  [a] ->+  u [a]+mrgIntersect = mrgIntersectBy (.==)++-- | Symbolic version of 'Data.List.nubBy', the result would be merged and+-- propagate the mergeable knowledge.+--+-- Can generate O(n) cases, and O(n^3) sized constraints, assuming the predicate+-- only generates O(1) constraints.+mrgNubBy ::+  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+        (mrgElemBy y xs)+        (mrgNubBy' ys xs)+        (mrgFmap (y :) $ mrgNubBy' ys (y : xs))+    mrgElemBy _ [] = con False+    mrgElemBy x (y : ys) = eq x y .|| mrgElemBy x ys++-- | Symbolic version of 'Data.List.deleteBy', the result would be merged and+-- propagate the mergeable knowledge.+--+-- Can generate O(n) cases, and O(n^2) sized constraints, assuming the predicate+-- only generates O(1) constraints.+mrgDeleteBy ::+  (Applicative u, SymBranching u, Mergeable a) =>+  (a -> a -> SymBool) ->+  a ->+  [a] ->+  u [a]+mrgDeleteBy _ _ [] = mrgPure []+mrgDeleteBy eq x (y : ys) =+  mrgIf (eq x y) (mrgPure ys) (mrgFmap (y :) $ mrgDeleteBy eq x ys)++-- | Symbolic version of 'Data.List.deleteFirstsBy', the result would be merged+-- and propagate the mergeable knowledge.+--+-- Can generate O(len(lhs)) cases, and O(len(lhs)^2 * len(rhs)) sized+-- constraints, assuming the predicate only generates O(1) constraints.+mrgDeleteFirstsBy ::+  (MonadUnion u, Mergeable a) =>+  (a -> a -> SymBool) ->+  [a] ->+  [a] ->+  u [a]+mrgDeleteFirstsBy eq = mrgFoldlM (flip $ mrgDeleteBy eq)++-- | Symbolic version of 'Data.List.unionBy', the result would be merged and+-- propagate the mergeable knowledge.+--+-- Can generate O(len(rhs)) cases, and O(len(rhs)^5 * len(lhs)) sized+-- constraints, assuming the predicate only generates O(1) constraints.+--+-- Should be improvable.+mrgUnionBy ::+  (MonadUnion u, Mergeable a) =>+  (a -> a -> SymBool) ->+  [a] ->+  [a] ->+  u [a]+mrgUnionBy eq xs ys =+  mrgFmap (xs ++) $+    (mrgNubBy eq ys)+      >>= \nubbed -> mrgFoldlM (flip $ mrgDeleteBy eq) nubbed xs++-- | Symbolic version of 'Data.List.intersectBy', the result would be merged and+-- propagate the mergeable knowledge.+--+-- Can generate O(len(rhs)) cases, and O(len(lhs) * len(rhs)) constraints,+-- assuming the predicate only generates O(1) constraints.+mrgIntersectBy ::+  (MonadUnion u, Mergeable a) =>+  (a -> a -> SymBool) ->+  [a] ->+  [a] ->+  u [a]+mrgIntersectBy _ [] _ = mrgPure []+mrgIntersectBy _ _ [] = mrgPure []+mrgIntersectBy eq xs ys = do+  tl <- mrgIntersectBy eq (tail xs) ys+  mrgIf (symAny (eq (head xs)) ys) (mrgReturn $ head xs : tl) (mrgPure tl)++-- | This function can be very inefficient on large symbolic lists and generate+-- O(2^n) cases. Use with caution.+mrgGroupBy ::+  (MonadUnion u, Mergeable a) =>+  (a -> a -> SymBool) ->+  [a] ->+  u [[a]]+mrgGroupBy _ [] = mrgPure []+mrgGroupBy eq (x : xs) = do+  (ys, zs) <- mrgSpan (eq x) xs+  tl <- mrgGroupBy eq zs+  mrgReturn $ (x : ys) : tl++-- | Symbolic version of 'Data.List.insert', the result would be merged and+-- propagate the mergeable knowledge.+--+-- Can generate 1 case, and O(n^2) sized constraints.+mrgInsert ::+  (MonadUnion m, Mergeable a, SymOrd a) =>+  a ->+  [a] ->+  m [a]+mrgInsert x [] = mrgPure [x]+mrgInsert x ys@(y : ys') =+  mrgIf (x .<= y) (mrgReturn $ x : ys) (mrgFmap (y :) $ mrgInsert x ys')++-- | Symbolic version of 'Data.List.insertBy', the result would be merged and+-- propagate the mergeable knowledge.+--+-- Can generate 1 case, and O(n^2) sized constraints, assuming the ordering+-- function only generates O(1) constraints.+mrgInsertBy ::+  (MonadUnion m, Mergeable a) =>+  (a -> a -> Union Ordering) ->+  a ->+  [a] ->+  m [a]+mrgInsertBy _ x [] = mrgPure [x]+mrgInsertBy cmp x ys@(y : ys') = do+  r <- liftUnion $ cmp x y+  case r of+    GT -> mrgFmap (y :) $ mrgInsertBy cmp x ys'+    _ -> mrgReturn $ x : ys
+ src/Grisette/Lib/Data/Maybe.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE KindSignatures #-}+{-# 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.TH.Ctor.SmartConstructor+  ( makePrefixedSmartCtor,+  )++makePrefixedSmartCtor "mrg" ''Maybe
src/Grisette/Lib/Data/Traversable.hs view
@@ -11,47 +11,58 @@ -- Stability   :   Experimental -- Portability :   GHC only module Grisette.Lib.Data.Traversable-  ( -- * mrg* variants for operations in "Data.Traversable"+  ( -- * The 'Traversable' class     mrgTraverse,     mrgSequenceA,-    mrgFor,     mrgMapM,-    mrgForM,     mrgSequence,++    -- * Utility functions+    mrgFor,+    mrgForM,+    mrgMapAccumM,+    mrgForAccumM,   ) where -import Grisette.Core.Control.Monad.Union (MonadUnion)-import Grisette.Core.Data.Class.Mergeable-  ( Mergeable,+import Control.Monad.State (StateT (StateT, runStateT))+import Grisette.Internal.Core.Data.Class.Mergeable+  ( Mergeable (rootStrategy),     Mergeable1,+    Mergeable2 (liftRootStrategy2),     rootStrategy1,   )-import Grisette.Core.Data.Class.SimpleMergeable-  ( UnionLike (mergeWithStrategy),-    merge,+import Grisette.Internal.Core.Data.Class.TryMerge+  ( MonadTryMerge,+    TryMerge (tryMergeWithStrategy),+    tryMerge,   )+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,     Mergeable1 t,-    MonadUnion f,+    TryMerge f,+    Applicative f,     Traversable t   ) =>   (a -> f b) ->   t a ->   f (t b)-mrgTraverse f = mergeWithStrategy rootStrategy1 . traverse (merge . f)+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,     Mergeable1 t,-    MonadUnion f,+    Applicative f,+    TryMerge f,     Traversable t   ) =>   t (f a) ->@@ -59,12 +70,13 @@ 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,     Mergeable1 t,-    MonadUnion f,+    MonadTryMerge f,     Traversable t   ) =>   (a -> f b) ->@@ -73,12 +85,13 @@ 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,     Mergeable1 t,-    MonadUnion f,+    MonadTryMerge f,     Traversable t   ) =>   t (f a) ->@@ -86,12 +99,14 @@ 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,     Traversable t,-    MonadUnion m+    TryMerge m,+    Applicative m   ) =>   t a ->   (a -> m b) ->@@ -99,15 +114,47 @@ 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,     Traversable t,-    MonadUnion m+    MonadTryMerge m   ) =>   t a ->   (a -> m b) ->   m (t b) mrgForM = flip mrgMapM {-# INLINE mrgForM #-}++-- | '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)) ->+  s ->+  t a ->+  m (s, t b)+mrgMapAccumM f s t =+  tryMergeWithStrategy (liftRootStrategy2 rootStrategy rootStrategy1) $ do+    (tb, s) <- flip runStateT s $ do+      mrgMapM+        ( \a -> StateT $ \s -> do+            (sr, br) <- f s a+            mrgPure (br, sr)+        )+        t+    return (s, tb)+{-# INLINE mrgMapAccumM #-}++-- | 'Data.Traversable.forAccumM' and 'Grisette.Core.MergingStrategy' knowledge+-- propagation.+mrgForAccumM ::+  (MonadTryMerge m, Traversable t, Mergeable s, Mergeable b, Mergeable1 t) =>+  s ->+  t a ->+  (s -> a -> m (s, b)) ->+  m (s, t b)+mrgForAccumM s t f = mrgMapAccumM f s t+{-# INLINE mrgForAccumM #-}
+ src/Grisette/Lib/Data/Tuple.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# 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,+    mrgTuple3,+    mrgTuple4,+    mrgTuple5,+    mrgTuple6,+    mrgTuple7,+    mrgTuple8,+  )+where++import Grisette.Internal.TH.Ctor.SmartConstructor+  ( makeNamedSmartCtor,+  )++makeNamedSmartCtor ["mrgUnit"] ''()+makeNamedSmartCtor ["mrgTuple2"] ''(,)+makeNamedSmartCtor ["mrgTuple3"] ''(,,)+makeNamedSmartCtor ["mrgTuple4"] ''(,,,)+makeNamedSmartCtor ["mrgTuple5"] ''(,,,,)+makeNamedSmartCtor ["mrgTuple6"] ''(,,,,,)+makeNamedSmartCtor ["mrgTuple7"] ''(,,,,,,)+makeNamedSmartCtor ["mrgTuple8"] ''(,,,,,,,)
− src/Grisette/Qualified/ParallelUnionDo.hs 
@@ -1,22 +0,0 @@--- |--- Module      :   Grisette.Qualified.ParallelUnionDo--- Copyright   :   (c) Sirui Lu 2023--- License     :   BSD-3-Clause (see the LICENSE file)------ Maintainer  :   siruilu@cs.washington.edu--- Stability   :   Experimental--- Portability :   GHC only-module Grisette.Qualified.ParallelUnionDo ((>>=), (>>)) where--import Control.Parallel.Strategies (NFData)-import Grisette.Core.Control.Monad.Class.MonadParallelUnion-  ( MonadParallelUnion (parBindUnion),-  )-import Grisette.Core.Data.Class.Mergeable (Mergeable)-import Prelude (const, ($))--(>>=) :: (MonadParallelUnion m, Mergeable b, NFData b) => m a -> (a -> m b) -> m b-(>>=) = parBindUnion--(>>) :: (MonadParallelUnion m, Mergeable b, NFData b) => m a -> m b -> m b-(>>) a b = parBindUnion a $ const b
+ src/Grisette/SymPrim.hs view
@@ -0,0 +1,518 @@+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE PatternSynonyms #-}+-- Disable this warning because we are re-exporting things.+{-# OPTIONS_GHC -Wno-missing-import-lists #-}++-- |+-- Module      :   Grisette.SymPrim+-- 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.SymPrim+  ( -- | 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.+    -- * 'AlgReal': algebraic real numbers. Can represent rational numbers.+    --   If come from solver's response, it may also represented by roots of+    --   polynomials or intervals.+    -- * @'Bool' t'Grisette.SymPrim.=->' 'Bool'@: functions represented as a+    --   table for the input-output relations.+    -- * @'Bool' t'Grisette.SymPrim.-->' '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.+    --+    -- * t'SymBool' ('Bool', symbolic Booleans)+    -- * t'SymInteger' ('Integer', symbolic unbounded integers)+    -- * @t'SymIntN' n@ (@'IntN' n@, symbolic signed bit vectors of bit width+    --   @n@)+    -- * @t'SymWordN' n@ (@'WordN' n@, symbolic unsigned bit vectors of bit width+    --   @n@)+    -- * @t'SymFP' eb sb@ (@'FP' eb sb@, symbolic IEEE-754 floating point numbers+    --   with @eb@ exponent bits and @sb@ significand bits)+    -- * t'SymAlgReal': symbolic algebraic real numbers.+    -- * @t'SymBool' t'Grisette.SymPrim.=~>' t'SymBool'@+    --   (@'Bool' t'Grisette.SymPrim.=->' 'Bool'@, symbolic+    --   functions, uninterpreted or represented as a table for the+    --   input-output relations).+    -- * @t'SymBool' t'Grisette.SymPrim.-~>' t'SymBool'@+    --   (@'Bool' t'Grisette.SymPrim.-->' '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 (@t'TypedSymbol'@), symbol sets+    -- (@t'SymbolSet'@), and models (@t'Model'@). They are useful when working+    -- with t'Grisette.Core.EvalSym', t'Grisette.Core.ExtractSym', and+    -- t'Grisette.Core.SubstSym'.++    -- * Extended types++    -- ** Size-tagged bit-vector types+    IntN,+    IntN8,+    IntN16,+    IntN32,+    IntN64,+    WordN,+    WordN8,+    WordN16,+    WordN32,+    WordN64,++    -- ** Runtime-sized bit-vector types+    SomeBV (..),+    SomeBVKey,+    SomeBVException (..),+    pattern SomeIntN,+    type SomeIntN,+    pattern SomeWordN,+    type SomeWordN,+    conBV,+    conBVView,+    pattern ConBV,+    symBV,+    ssymBV,+    isymBV,+    arbitraryBV,++    -- *** Some low-level helpers for writing instances for t'SomeBV'++    -- | The functions here will check the bitwidths of the input bit-vectors+    -- and raise v'BitwidthMismatch' if they do not match.+    unsafeSomeBV,+    unarySomeBV,+    unarySomeBVR1,+    binSomeBV,+    binSomeBVR1,+    binSomeBVR2,+    binSomeBVSafe,+    binSomeBVSafeR1,+    binSomeBVSafeR2,++    -- ** Floating point+    ValidFP,+    FP,+    FP16,+    FP32,+    FP64,+    withValidFPProofs,+    FPRoundingMode (..),+    allFPRoundingMode,++    -- ** Algebraic real numbers+    AlgReal (..),+    AlgRealPoly (..),+    RealPoint (..),+    UnsupportedAlgRealOperation (..),++    -- ** Functions+    type (=->) (..),+    type (-->),+    (-->),++    -- * Symbolic types++    -- ** Symbolic bool and integer types+    SymBool (..),+    SymBoolKey,+    SymInteger (..),+    SymIntegerKey,++    -- ** Symbolic bit-vector types+    SymWordN (..),+    SymWordNKey,+    SymWordN8,+    SymWordN8Key,+    SymWordN16,+    SymWordN16Key,+    SymWordN32,+    SymWordN32Key,+    SymWordN64,+    SymWordN64Key,+    SymIntN (..),+    SymIntNKey,+    SymIntN8,+    SymIntN8Key,+    SymIntN16,+    SymIntN16Key,+    SymIntN32,+    SymIntN32Key,+    SymIntN64,+    SymIntN64Key,+    SomeSymIntN,+    SomeSymIntNKey,+    SomeSymWordN,+    SomeSymWordNKey,+    pattern SomeSymIntN,+    pattern SomeSymWordN,+    pattern SomeSymIntNKey,+    pattern SomeSymWordNKey,++    -- ** Symbolic floating point+    SymFP (..),+    SymFPKey,+    SymFPRoundingMode (..),+    SymFPRoundingModeKey,+    SymFP16,+    SymFP16Key,+    SymFP32,+    SymFP32Key,+    SymFP64,+    SymFP64Key,++    -- ** Symbolic algebraic real numbers+    SymAlgReal (..),+    SymAlgRealKey,++    -- ** Symbolic function, possibly uninterpreted+    type (=~>) (..),+    type (-~>) (..),++    -- ** Shared constraints+    Prim,+    SymPrim,+    BasicSymPrim,++    -- ** Quantifiers+    forallSet,+    forallSym,+    forallFresh,+    existsSet,+    existsSym,+    existsFresh,++    -- ** Basic constraints+    SupportedPrim,+    SymRep (SymType),+    ConRep (ConType),+    LinkedRep (..),++    -- * Extract symbolic values+    SomeSym (..),+    AllSyms (..),+    AllSyms1 (..),+    allSymsS1,+    AllSyms2 (..),+    allSymsS2,+    allSymsSize,+    symSize,+    symsSize,++    -- ** Generic 'AllSyms'+    AllSymsArgs (..),+    GAllSyms (..),+    genericAllSymsS,+    genericLiftAllSymsS,++    -- * Symbolic constant sets and models+    SymbolKind (..),+    IsSymbolKind (..),+    TypedSymbol (..),+    typedAnySymbol,+    TypedAnySymbol,+    typedConstantSymbol,+    TypedConstantSymbol,+    SomeTypedSymbol (..),+    SomeTypedAnySymbol,+    SomeTypedConstantSymbol,+    SymbolSet,+    AnySymbolSet,+    ConstantSymbolSet,+    Model,+    ModelValuePair (..),+    ModelSymPair (..),++    -- * Analysis on the terms+    Term,+    SomeTerm (..),+    termSize,+    someTermSize,+    termsSize,+    someTermsSize,+    pattern SupportedTerm,+    pattern SupportedTypedSymbol,+    pattern SupportedConstantTypedSymbol,+    pattern ConTerm,+    pattern SymTerm,+    pattern ForallTerm,+    pattern ExistsTerm,+    pattern NotTerm,+    pattern OrTerm,+    pattern AndTerm,+    pattern EqTerm,+    pattern DistinctTerm,+    pattern ITETerm,+    pattern AddNumTerm,+    pattern NegNumTerm,+    pattern MulNumTerm,+    pattern AbsNumTerm,+    pattern SignumNumTerm,+    pattern LtOrdTerm,+    pattern LeOrdTerm,+    pattern AndBitsTerm,+    pattern OrBitsTerm,+    pattern XorBitsTerm,+    pattern ComplementBitsTerm,+    pattern ShiftLeftTerm,+    pattern RotateLeftTerm,+    pattern ShiftRightTerm,+    pattern RotateRightTerm,+    pattern BitCastTerm,+    pattern BitCastOrTerm,+    pattern BVConcatTerm,+    pattern BVSelectTerm,+    pattern BVExtendTerm,+    pattern ApplyTerm,+    pattern DivIntegralTerm,+    pattern ModIntegralTerm,+    pattern QuotIntegralTerm,+    pattern RemIntegralTerm,+    pattern FPTraitTerm,+    pattern FdivTerm,+    pattern RecipTerm,+    pattern FloatingUnaryTerm,+    pattern PowerTerm,+    pattern FPUnaryTerm,+    pattern FPBinaryTerm,+    pattern FPRoundingUnaryTerm,+    pattern FPRoundingBinaryTerm,+    pattern FPFMATerm,+    pattern FromIntegralTerm,+    pattern FromFPOrTerm,+    pattern ToFPTerm,+    pattern SubTerms,+  )+where++import Grisette.Internal.SymPrim.AlgReal+  ( AlgReal (..),+    AlgRealPoly (..),+    RealPoint (..),+    UnsupportedAlgRealOperation (..),+  )+import Grisette.Internal.SymPrim.AllSyms+  ( AllSyms (..),+    AllSyms1 (..),+    AllSyms2 (..),+    AllSymsArgs (..),+    GAllSyms (..),+    SomeSym (..),+    allSymsS1,+    allSymsS2,+    allSymsSize,+    genericAllSymsS,+    genericLiftAllSymsS,+    symSize,+    symsSize,+  )+import Grisette.Internal.SymPrim.BV+  ( 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+  ( AnySymbolSet,+    ConstantSymbolSet,+    Model (..),+    ModelValuePair (..),+    SymbolSet (..),+  )+import Grisette.Internal.SymPrim.Prim.Pattern (pattern SubTerms)+import Grisette.Internal.SymPrim.Prim.SomeTerm+  ( SomeTerm (..),+  )+import Grisette.Internal.SymPrim.Prim.Term+  ( ConRep (..),+    IsSymbolKind (..),+    LinkedRep (..),+    SomeTypedAnySymbol,+    SomeTypedConstantSymbol,+    SomeTypedSymbol (..),+    SupportedPrim,+    SymRep (..),+    SymbolKind (..),+    Term,+    TypedAnySymbol,+    TypedConstantSymbol,+    TypedSymbol (..),+    typedAnySymbol,+    typedConstantSymbol,+    pattern AbsNumTerm,+    pattern AddNumTerm,+    pattern AndBitsTerm,+    pattern AndTerm,+    pattern ApplyTerm,+    pattern BVConcatTerm,+    pattern BVExtendTerm,+    pattern BVSelectTerm,+    pattern BitCastOrTerm,+    pattern BitCastTerm,+    pattern ComplementBitsTerm,+    pattern ConTerm,+    pattern DistinctTerm,+    pattern DivIntegralTerm,+    pattern EqTerm,+    pattern ExistsTerm,+    pattern FPBinaryTerm,+    pattern FPFMATerm,+    pattern FPRoundingBinaryTerm,+    pattern FPRoundingUnaryTerm,+    pattern FPTraitTerm,+    pattern FPUnaryTerm,+    pattern FdivTerm,+    pattern FloatingUnaryTerm,+    pattern ForallTerm,+    pattern FromFPOrTerm,+    pattern FromIntegralTerm,+    pattern ITETerm,+    pattern LeOrdTerm,+    pattern LtOrdTerm,+    pattern ModIntegralTerm,+    pattern MulNumTerm,+    pattern NegNumTerm,+    pattern NotTerm,+    pattern OrBitsTerm,+    pattern OrTerm,+    pattern PowerTerm,+    pattern QuotIntegralTerm,+    pattern RecipTerm,+    pattern RemIntegralTerm,+    pattern RotateLeftTerm,+    pattern RotateRightTerm,+    pattern ShiftLeftTerm,+    pattern ShiftRightTerm,+    pattern SignumNumTerm,+    pattern SupportedConstantTypedSymbol,+    pattern SupportedTerm,+    pattern SupportedTypedSymbol,+    pattern SymTerm,+    pattern ToFPTerm,+    pattern XorBitsTerm,+  )+import Grisette.Internal.SymPrim.Prim.TermUtils+  ( someTermSize,+    someTermsSize,+    termSize,+    termsSize,+  )+import Grisette.Internal.SymPrim.Quantifier+  ( existsFresh,+    existsSet,+    existsSym,+    forallFresh,+    forallSet,+    forallSym,+  )+import Grisette.Internal.SymPrim.SomeBV+  ( SomeBV (..),+    SomeBVException (..),+    SomeBVKey,+    SomeSymIntNKey,+    SomeSymWordNKey,+    arbitraryBV,+    binSomeBV,+    binSomeBVR1,+    binSomeBVR2,+    binSomeBVSafe,+    binSomeBVSafeR1,+    binSomeBVSafeR2,+    conBV,+    conBVView,+    isymBV,+    ssymBV,+    symBV,+    unarySomeBV,+    unarySomeBVR1,+    unsafeSomeBV,+    pattern ConBV,+    pattern SomeIntN,+    pattern SomeSymIntN,+    pattern SomeSymIntNKey,+    pattern SomeSymWordN,+    pattern SomeSymWordNKey,+    pattern SomeWordN,+    type SomeIntN,+    type SomeSymIntN,+    type SomeSymWordN,+    type SomeWordN,+  )+import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal (..), SymAlgRealKey)+import Grisette.Internal.SymPrim.SymBV+  ( SymIntN (..),+    SymIntN16,+    SymIntN16Key,+    SymIntN32,+    SymIntN32Key,+    SymIntN64,+    SymIntN64Key,+    SymIntN8,+    SymIntN8Key,+    SymIntNKey,+    SymWordN (..),+    SymWordN16,+    SymWordN16Key,+    SymWordN32,+    SymWordN32Key,+    SymWordN64,+    SymWordN64Key,+    SymWordN8,+    SymWordN8Key,+    SymWordNKey,+  )+import Grisette.Internal.SymPrim.SymBool+  ( SymBool (..),+    SymBoolKey,+  )+import Grisette.Internal.SymPrim.SymFP+  ( SymFP (..),+    SymFP16,+    SymFP16Key,+    SymFP32,+    SymFP32Key,+    SymFP64,+    SymFP64Key,+    SymFPKey,+    SymFPRoundingMode (..),+    SymFPRoundingModeKey,+  )+import Grisette.Internal.SymPrim.SymGeneralFun ((-->), type (-~>) (..))+import Grisette.Internal.SymPrim.SymInteger+  ( SymInteger (..),+    SymIntegerKey,+  )+import Grisette.Internal.SymPrim.SymPrim+  ( BasicSymPrim,+    Prim,+    SymPrim,+  )+import Grisette.Internal.SymPrim.SymTabularFun (type (=~>) (..))+import Grisette.Internal.SymPrim.TabularFun (type (=->) (..))
+ src/Grisette/TH.hs view
@@ -0,0 +1,153 @@+{-# 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 TH procedures for ADTs+    makeGrisetteADTWithClasses,+    makeGrisetteBasicADT,+    makeGrisetteBasicADT1,+    makeGrisetteBasicADT2,+    makeGrisetteBasicADTWith,+    makeGrisetteBasicADT1With,+    makeGrisetteBasicADT2With,+    makeGrisetteADT,+    makeGrisetteADT1,+    makeGrisetteADT2,+    makeGrisetteADTWith,+    makeGrisetteADT1With,+    makeGrisetteADT2With,++    -- * Convenient derivation of all instances relating to Grisette+    EvalModeConfig (..),+    DeriveConfig (..),+    derive,+    deriveWith,+    allClasses0,+    allClasses01,+    allClasses012,+    basicClasses0,+    basicClasses1,+    basicClasses2,+    basicClasses01,+    basicClasses012,+    noExistentialClasses0,+    concreteOrdClasses0,+    noExistentialClasses1,+    concreteOrdClasses1,+    noExistentialClasses2,+    concreteOrdClasses2,+    showClasses,+    pprintClasses,+    evalSymClasses,+    extractSymClasses,+    substSymClasses,+    allSymsClasses,+    eqClasses,+    ordClasses,+    symOrdClasses,+    symEqClasses,+    unifiedSymOrdClasses,+    unifiedSymEqClasses,+    mergeableClasses,+    nfDataClasses,+    hashableClasses,+    toSymClasses,+    toConClasses,+    serialClasses,+    simpleMergeableClasses,+    unifiedSimpleMergeableClasses,+    filterExactNumArgs,+    filterLeqNumArgs,++    -- * Smart constructors that merges in a monad+    makePrefixedSmartCtor,+    makeNamedSmartCtor,+    makeSmartCtor,+    makeSmartCtorWith,++    -- * Smart constructors that are polymorphic in evaluation modes+    makePrefixedUnifiedCtor,+    makeNamedUnifiedCtor,+    makeUnifiedCtor,+    makeUnifiedCtorWith,+  )+where++import Grisette.Internal.TH.ADT+  ( makeGrisetteADT,+    makeGrisetteADT1,+    makeGrisetteADT1With,+    makeGrisetteADT2,+    makeGrisetteADT2With,+    makeGrisetteADTWith,+    makeGrisetteADTWithClasses,+    makeGrisetteBasicADT,+    makeGrisetteBasicADT1,+    makeGrisetteBasicADT1With,+    makeGrisetteBasicADT2,+    makeGrisetteBasicADT2With,+    makeGrisetteBasicADTWith,+  )+import Grisette.Internal.TH.Ctor.SmartConstructor+  ( makeNamedSmartCtor,+    makePrefixedSmartCtor,+    makeSmartCtor,+    makeSmartCtorWith,+  )+import Grisette.Internal.TH.Ctor.UnifiedConstructor+  ( makeNamedUnifiedCtor,+    makePrefixedUnifiedCtor,+    makeUnifiedCtor,+    makeUnifiedCtorWith,+  )+import Grisette.Internal.TH.Derivation.Common+  ( DeriveConfig (..),+    EvalModeConfig (..),+  )+import Grisette.Internal.TH.Derivation.Derive+  ( allClasses0,+    allClasses01,+    allClasses012,+    allSymsClasses,+    basicClasses0,+    basicClasses01,+    basicClasses012,+    basicClasses1,+    basicClasses2,+    concreteOrdClasses0,+    concreteOrdClasses1,+    concreteOrdClasses2,+    derive,+    deriveWith,+    eqClasses,+    evalSymClasses,+    extractSymClasses,+    filterExactNumArgs,+    filterLeqNumArgs,+    hashableClasses,+    mergeableClasses,+    nfDataClasses,+    noExistentialClasses0,+    noExistentialClasses1,+    noExistentialClasses2,+    ordClasses,+    pprintClasses,+    serialClasses,+    showClasses,+    simpleMergeableClasses,+    substSymClasses,+    symEqClasses,+    symOrdClasses,+    toConClasses,+    toSymClasses,+    unifiedSimpleMergeableClasses,+    unifiedSymEqClasses,+    unifiedSymOrdClasses,+  )
+ src/Grisette/Unified.hs view
@@ -0,0 +1,373 @@+{-# 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+    genEvalMode,+    TheoryToUnify (..),+    EvalModeBase,+    EvalModeInteger,+    EvalModeBV,+    EvalModeFP,+    EvalModeAlgReal,+    EvalModeAll,+    MonadEvalModeAll,+    DecideEvalMode (..),+    withMode,+    EvalModeConvertible (..),++    -- * Unified operations++    -- ** Unified simple mergeable+    UnifiedBranching (..),+    UnifiedSimpleMergeable (..),+    UnifiedSimpleMergeable1 (..),+    UnifiedSimpleMergeable2 (..),+    mrgIf,+    liftUnion,+    mrgIte,+    mrgIte1,+    liftMrgIte,+    mrgIte2,+    liftMrgIte2,+    simpleMerge,+    (.#),+    onUnion,+    onUnion2,+    onUnion3,+    onUnion4,++    -- ** Unified ITE operator+    UnifiedITEOp (..),+    symIte,+    symIteMerge,++    -- ** Unified SymEq+    UnifiedSymEq (..),+    UnifiedSymEq1 (..),+    UnifiedSymEq2 (..),+    (.==),+    (./=),+    symDistinct,+    liftSymEq,+    symEq1,+    liftSymEq2,+    symEq2,++    -- ** Unified SymOrd+    UnifiedSymOrd (..),+    UnifiedSymOrd1 (..),+    UnifiedSymOrd2 (..),+    (.<=),+    (.<),+    (.>=),+    (.>),+    symCompare,+    liftSymCompare,+    symCompare1,+    liftSymCompare2,+    symCompare2,+    symMax,+    symMin,+    mrgMax,+    mrgMin,++    -- ** Unified finite bits+    UnifiedFiniteBits (..),+    symTestBit,+    symSetBitTo,+    symFromBits,+    symBitBlast,+    symLsb,+    symMsb,+    symPopCount,+    symCountLeadingZeros,+    symCountTrailingZeros,++    -- ** Unified conversions+    UnifiedFromIntegral (..),+    symFromIntegral,+    UnifiedSafeBitCast (..),+    safeBitCast,+    UnifiedSafeFromFP (..),+    safeFromFP,++    -- ** Unified safe ops+    UnifiedSafeDiv (..),+    safeDiv,+    safeMod,+    safeDivMod,+    safeQuot,+    safeRem,+    safeQuotRem,+    UnifiedSafeLinearArith (..),+    safeAdd,+    safeNeg,+    safeSub,+    UnifiedSafeSymRotate (..),+    safeSymRotateL,+    safeSymRotateR,+    UnifiedSafeSymShift (..),+    safeSymShiftL,+    safeSymShiftR,+    safeSymStrictShiftL,+    safeSymStrictShiftR,+    UnifiedSafeFdiv (..),+    safeFdiv,++    -- ** Shared constraints+    UnifiedPrim,+    UnifiedBasicPrim,++    -- * Unified types++    -- ** Boolean+    GetBool,++    -- ** Bit-vector+    GetIntN,+    GetWordN,+    GetSomeWordN,+    GetSomeIntN,+    UnifiedBV,+    SafeUnifiedBV,+    SafeUnifiedSomeBV,++    -- ** Integer+    GetInteger,+    UnifiedInteger,++    -- ** FP+    GetFP,+    GetFPRoundingMode,+    UnifiedFP,+    SafeUnifiedFP,++    -- ** AlgReal+    GetAlgReal,+    UnifiedAlgReal,++    -- ** Data+    GetData,+    UnifiedData,+    extractData,+    wrapData,++    -- ** Functions+    GetFun,+    GetFun2,+    GetFun3,+    GetFun4,+    GetFun5,+    GetFun6,+    GetFun7,+    GetFun8,+    UnifiedFun,+    UnifiedFunConstraint,+    unifiedFunInstanceName,+    genUnifiedFunInstance,++    -- ** Supplemental conversions+    UnifiedBVBVConversion,+    UnifiedBVFPConversion,+    SafeUnifiedBVFPConversion,+    UnifiedFPFPConversion,+  )+where++import Grisette.Internal.Internal.Impl.Unified.Class.UnifiedSimpleMergeable (onUnion, onUnion2, onUnion3, onUnion4, (.#))+import Grisette.Internal.Unified.BVBVConversion+  ( UnifiedBVBVConversion,+  )+import Grisette.Internal.Unified.BVFPConversion+  ( SafeUnifiedBVFPConversion,+    UnifiedBVFPConversion,+  )+import Grisette.Internal.Unified.Class.UnifiedFiniteBits+  ( UnifiedFiniteBits (..),+    symBitBlast,+    symCountLeadingZeros,+    symCountTrailingZeros,+    symFromBits,+    symLsb,+    symMsb,+    symPopCount,+    symSetBitTo,+    symTestBit,+  )+import Grisette.Internal.Unified.Class.UnifiedFromIntegral+  ( UnifiedFromIntegral (..),+    symFromIntegral,+  )+import Grisette.Internal.Unified.Class.UnifiedITEOp+  ( UnifiedITEOp (..),+    symIte,+    symIteMerge,+  )+import Grisette.Internal.Unified.Class.UnifiedSafeBitCast+  ( UnifiedSafeBitCast (..),+    safeBitCast,+  )+import Grisette.Internal.Unified.Class.UnifiedSafeDiv+  ( UnifiedSafeDiv (..),+    safeDiv,+    safeDivMod,+    safeMod,+    safeQuot,+    safeQuotRem,+    safeRem,+  )+import Grisette.Internal.Unified.Class.UnifiedSafeFdiv+  ( UnifiedSafeFdiv (..),+    safeFdiv,+  )+import Grisette.Internal.Unified.Class.UnifiedSafeFromFP+  ( UnifiedSafeFromFP (..),+    safeFromFP,+  )+import Grisette.Internal.Unified.Class.UnifiedSafeLinearArith+  ( UnifiedSafeLinearArith (..),+    safeAdd,+    safeNeg,+    safeSub,+  )+import Grisette.Internal.Unified.Class.UnifiedSafeSymRotate+  ( UnifiedSafeSymRotate (..),+    safeSymRotateL,+    safeSymRotateR,+  )+import Grisette.Internal.Unified.Class.UnifiedSafeSymShift+  ( UnifiedSafeSymShift (..),+    safeSymShiftL,+    safeSymShiftR,+    safeSymStrictShiftL,+    safeSymStrictShiftR,+  )+import Grisette.Internal.Unified.Class.UnifiedSimpleMergeable+  ( UnifiedBranching (..),+    UnifiedSimpleMergeable (..),+    UnifiedSimpleMergeable1 (..),+    UnifiedSimpleMergeable2 (..),+    liftMrgIte,+    liftMrgIte2,+    liftUnion,+    mrgIf,+    mrgIte,+    mrgIte1,+    mrgIte2,+    simpleMerge,+  )+import Grisette.Internal.Unified.Class.UnifiedSymEq+  ( UnifiedSymEq (..),+    UnifiedSymEq1 (..),+    UnifiedSymEq2 (..),+    liftSymEq,+    liftSymEq2,+    symDistinct,+    symEq1,+    symEq2,+    (./=),+    (.==),+  )+import Grisette.Internal.Unified.Class.UnifiedSymOrd+  ( UnifiedSymOrd (..),+    UnifiedSymOrd1 (..),+    UnifiedSymOrd2 (..),+    mrgMax,+    mrgMin,+    symMax,+    symMin,+    (.<),+    (.<=),+    (.>),+    (.>=),+  )+import Grisette.Internal.Unified.EvalMode+  ( EvalModeAlgReal,+    EvalModeAll,+    EvalModeBV,+    EvalModeBase,+    EvalModeFP,+    EvalModeInteger,+    MonadEvalModeAll,+    genEvalMode,+  )+import Grisette.Internal.Unified.EvalModeTag+  ( EvalModeTag (..),+    IsConMode,+  )+import Grisette.Internal.Unified.FPFPConversion+  ( UnifiedFPFPConversion,+  )+import Grisette.Internal.Unified.Theories (TheoryToUnify (..))+import Grisette.Internal.Unified.UnifiedAlgReal+  ( GetAlgReal,+    UnifiedAlgReal,+  )+import Grisette.Internal.Unified.UnifiedBV+  ( GetIntN,+    GetSomeIntN,+    GetSomeWordN,+    GetWordN,+    SafeUnifiedBV,+    SafeUnifiedSomeBV,+    UnifiedBV,+  )+import Grisette.Internal.Unified.UnifiedBool (UnifiedBool (..))+import Grisette.Internal.Unified.UnifiedData+  ( BaseMonad,+    GetData,+    UnifiedData,+    extractData,+    liftSymCompare,+    liftSymCompare2,+    symCompare,+    symCompare1,+    symCompare2,+    wrapData,+  )+import Grisette.Internal.Unified.UnifiedFP+  ( GetFP,+    GetFPRoundingMode,+    SafeUnifiedFP,+    UnifiedFP,+  )+import Grisette.Internal.Unified.UnifiedFun+  ( GetFun,+    GetFun2,+    GetFun3,+    GetFun4,+    GetFun5,+    GetFun6,+    GetFun7,+    GetFun8,+    UnifiedFun,+    UnifiedFunConstraint,+    genUnifiedFunInstance,+    unifiedFunInstanceName,+  )+import Grisette.Internal.Unified.UnifiedInteger+  ( GetInteger,+    UnifiedInteger,+  )+import Grisette.Internal.Unified.UnifiedPrim+  ( UnifiedBasicPrim,+    UnifiedPrim,+  )+import Grisette.Internal.Unified.Util+  ( DecideEvalMode (..),+    EvalModeConvertible (..),+    withMode,+  )
+ src/Grisette/Unified/Lib/Control/Applicative.hs view
@@ -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 #-}
+ src/Grisette/Unified/Lib/Control/Monad.hs view
@@ -0,0 +1,562 @@+{-# 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+  ( EvalModeBase,+    GetBool,+    UnifiedBranching,+    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,+    UnifiedBranching 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,+    UnifiedBranching mode m,+    MonadTryMerge m,+    EvalModeBase mode,+    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.+  ( EvalModeBase mode,+    TryMerge m,+    Applicative m,+    Mergeable a,+    Num int,+    UnifiedBranching mode m,+    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.+  ( EvalModeBase mode,+    TryMerge m,+    Applicative m,+    Mergeable a,+    Num int,+    UnifiedBranching mode m,+    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.Internal.Unified.Lib.Data.Functor..<$>'.+(.<$!>) ::+  (MonadTryMerge m, Mergeable a, Mergeable b) => (a -> b) -> m a -> m b+f .<$!> a = f .<$> a+{-# INLINE (.<$!>) #-}
+ src/Grisette/Unified/Lib/Control/Monad.hs-boot view
@@ -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
+ src/Grisette/Unified/Lib/Data/Foldable.hs view
@@ -0,0 +1,389 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-}+{-# 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++#if MIN_VERSION_base(4,20,0)+#else+import Data.Foldable (Foldable (foldl'))+#endif++import Control.Monad (MonadPlus)+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.Internal.Unified.Class.UnifiedSymEq (UnifiedSymEq, (.==))+import Grisette.Internal.Unified.Class.UnifiedSymOrd (mrgMax, mrgMin)+import Grisette.Internal.Unified.UnifiedBool (GetBool)+import Grisette.Internal.Unified.UnifiedData (GetData)+import Grisette.Lib.Control.Applicative (mrgAsum, mrgPure, (.*>))+import {-# SOURCE #-} Grisette.Lib.Control.Monad+  ( mrgMplus,+    mrgMzero,+    (.>>),+  )+import Grisette.Lib.Data.Functor (mrgFmap, mrgVoid)+import Grisette.Unified+  ( EvalModeBase,+    UnifiedBranching,+    UnifiedITEOp,+    UnifiedSymOrd,+    liftUnion,+    mrgIf,+    symIteMerge,+  )++-- | 'Data.Foldable.elem' with symbolic equality.+symElem ::+  forall mode t a.+  (Foldable t, EvalModeBase 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,+    EvalModeBase mode,+    UnifiedBranching mode m,+    MonadTryMerge 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,+    EvalModeBase mode+  ) =>+  t a ->+  a+symMaximum l = symIteMerge @mode (mrgMaximum @mode l :: GetData mode a)+{-# INLINE symMaximum #-}++-- | 'Data.Foldable.minimum' with 'Grisette.Core.MergingStrategy' knowledge+-- propagation.+mrgMinimum ::+  forall mode a t m.+  ( Foldable t,+    EvalModeBase mode,+    UnifiedBranching mode m,+    MonadTryMerge 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,+    EvalModeBase mode+  ) =>+  t a ->+  a+symMinimum l = symIteMerge @mode (mrgMinimum @mode l :: GetData 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 :: (EvalModeBase mode, Foldable t) => t (GetBool mode) -> GetBool mode+symAnd = foldl' (.&&) (toSym True)+{-# INLINE symAnd #-}++-- | 'Data.Foldable.or' on unified boolean.+symOr :: (EvalModeBase mode, Foldable t) => t (GetBool mode) -> GetBool mode+symOr = foldl' (.||) (toSym False)+{-# INLINE symOr #-}++-- | 'Data.Foldable.any' on unified boolean.+symAny ::+  (EvalModeBase 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 ::+  (EvalModeBase 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,+    EvalModeBase mode,+    MonadTryMerge m,+    UnifiedBranching mode m+  ) =>+  (a -> a -> GetData 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 <- liftUnion @mode $ 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, EvalModeBase mode) =>+  (a -> a -> GetData mode Ordering) ->+  t a ->+  a+symMaximumBy cmp l = symIteMerge @mode (mrgMaximumBy cmp l :: GetData mode a)+{-# INLINE symMaximumBy #-}++-- | 'Data.Foldable.minimumBy' with 'Grisette.Core.MergingStrategy' knowledge+-- propagation.+mrgMinimumBy ::+  forall mode t a m.+  ( Foldable t,+    Mergeable a,+    EvalModeBase mode,+    MonadTryMerge m,+    UnifiedBranching mode m+  ) =>+  (a -> a -> GetData 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 <- liftUnion @mode $ 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, EvalModeBase mode) =>+  (a -> a -> GetData mode Ordering) ->+  t a ->+  a+symMinimumBy cmp l = symIteMerge @mode (mrgMinimumBy cmp l :: GetData mode a)+{-# INLINE symMinimumBy #-}++-- | 'Data.Foldable.elem' with symbolic equality.+symNotElem ::+  (Foldable t, UnifiedSymEq mode a, EvalModeBase 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,+    EvalModeBase mode,+    MonadTryMerge m,+    UnifiedBranching 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)
+ src/Grisette/Unified/Lib/Data/Functor.hs view
@@ -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 #-}
src/Grisette/Utils.hs view
@@ -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@@ -18,7 +51,6 @@     -- ** Runtime representation of type-level natural numbers     NatRepr,     natValue,-    unsafeMkNatRepr,     natRepr,     decNat,     predNat,@@ -50,7 +82,7 @@   ) where -import Grisette.Utils.Parameterized+import Grisette.Internal.Utils.Parameterized   ( KnownProof (..),     LeqProof (..),     NatRepr,@@ -76,7 +108,6 @@     unsafeAxiom,     unsafeKnownProof,     unsafeLeqProof,-    unsafeMkNatRepr,     withKnownProof,     withLeqProof,   )
− src/Grisette/Utils/Parameterized.hs 
@@ -1,244 +0,0 @@-{--Part of the code in this file comes 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.--}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeOperators #-}---- |--- Module      :   Grisette.Utils.Parameterized--- 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.Utils.Parameterized-  ( -- * Unsafe axiom-    unsafeAxiom,--    -- * Runtime representation of type-level natural numbers-    NatRepr,-    natValue,-    unsafeMkNatRepr,-    natRepr,-    decNat,-    predNat,-    incNat,-    addNat,-    subNat,-    divNat,-    halfNat,--    -- * Proof of KnownNat-    KnownProof (..),-    hasRepr,-    withKnownProof,-    unsafeKnownProof,-    knownAdd,--    -- * Proof of (<=) for type-level natural numbers-    LeqProof (..),-    withLeqProof,-    unsafeLeqProof,-    testLeq,-    leqRefl,-    leqSucc,-    leqTrans,-    leqZero,-    leqAdd2,-    leqAdd,-    leqAddPos,-  )-where--import Data.Typeable (Proxy (Proxy), type (:~:) (Refl))-import GHC.Natural (Natural)-import GHC.TypeNats-  ( Div,-    KnownNat,-    Nat,-    SomeNat (SomeNat),-    natVal,-    someNatVal,-    type (+),-    type (-),-    type (<=),-  )-import Unsafe.Coerce (unsafeCoerce)---- | Assert a proof of equality between two types.--- This is unsafe if used improperly, so use this with caution!-unsafeAxiom :: forall a b. a :~: b-unsafeAxiom = unsafeCoerce (Refl @a)---- | A runtime representation of type-level natural numbers.--- This can be used for performing dynamic checks on type-level natural numbers.-newtype NatRepr (n :: Nat) = NatRepr Natural---- | The underlying runtime natural number value of a type-level natural number.-natValue :: NatRepr n -> Natural-natValue (NatRepr n) = n---- | Construct a runtime representation of a type-level natural number.------ __Note:__ This function is unsafe, as it does not check that the runtime--- representation is consistent with the type-level representation.--- You should ensure the consistency yourself or the program can crash or--- generate incorrect results.-unsafeMkNatRepr :: Natural -> NatRepr n-unsafeMkNatRepr = NatRepr---- | Construct a runtime representation of a type-level natural number when its--- runtime value is known.-natRepr :: forall n. (KnownNat n) => NatRepr n-natRepr = NatRepr (natVal (Proxy @n))---- | Decrement a 'NatRepr' by 1.-decNat :: (1 <= n) => NatRepr n -> NatRepr (n - 1)-decNat (NatRepr n) = NatRepr (n - 1)---- | Predecessor of a 'NatRepr'-predNat :: NatRepr (n + 1) -> NatRepr n-predNat (NatRepr n) = NatRepr (n - 1)---- | Increment a 'NatRepr' by 1.-incNat :: NatRepr n -> NatRepr (n + 1)-incNat (NatRepr n) = NatRepr (n + 1)---- | Addition of two 'NatRepr's.-addNat :: NatRepr m -> NatRepr n -> NatRepr (m + n)-addNat (NatRepr m) (NatRepr n) = NatRepr (m + n)---- | Subtraction of two 'NatRepr's.-subNat :: (n <= m) => NatRepr m -> NatRepr n -> NatRepr (m - n)-subNat (NatRepr m) (NatRepr n) = NatRepr (m - n)---- | Division of two 'NatRepr's.-divNat :: (1 <= n) => NatRepr m -> NatRepr n -> NatRepr (Div m n)-divNat (NatRepr m) (NatRepr n) = NatRepr (m `div` n)---- | Half of a 'NatRepr'.-halfNat :: NatRepr (n + n) -> NatRepr n-halfNat (NatRepr n) = NatRepr (n `div` 2)---- | @'KnownProof n'@ is a type whose values are only inhabited when @n@ has--- a known runtime value.-data KnownProof (n :: Nat) where-  KnownProof :: (KnownNat n) => KnownProof n---- | Introduces the 'KnownNat' constraint when it's proven.-withKnownProof :: KnownProof n -> ((KnownNat n) => r) -> r-withKnownProof p r = case p of KnownProof -> r---- | Construct a 'KnownProof' given the runtime value.------ __Note:__ This function is unsafe, as it does not check that the runtime--- representation is consistent with the type-level representation.--- You should ensure the consistency yourself or the program can crash or--- generate incorrect results.-unsafeKnownProof :: Natural -> KnownProof n-unsafeKnownProof nVal = hasRepr (NatRepr nVal)---- | Construct a 'KnownProof' given the runtime representation.-hasRepr :: forall n. NatRepr n -> KnownProof n-hasRepr (NatRepr nVal) =-  case someNatVal nVal of-    SomeNat (Proxy :: Proxy n') ->-      case unsafeAxiom :: n :~: n' of-        Refl -> KnownProof---- | Adding two type-level natural numbers with known runtime values gives a--- type-level natural number with a known runtime value.-knownAdd :: forall m n. KnownProof m -> KnownProof n -> KnownProof (m + n)-knownAdd KnownProof KnownProof = hasRepr @(m + n) (NatRepr (natVal (Proxy @m) + natVal (Proxy @n)))---- | @'LeqProof m n'@ is a type whose values are only inhabited when @m <= n@.-data LeqProof (m :: Nat) (n :: Nat) where-  LeqProof :: (m <= n) => LeqProof m n---- | Introduces the @m <= n@ constraint when it's proven.-withLeqProof :: LeqProof m n -> ((m <= n) => r) -> r-withLeqProof p r = case p of LeqProof -> r---- | Construct a 'LeqProof'.------ __Note:__ This function is unsafe, as it does not check that the left-hand--- side is less than or equal to the right-hand side.--- You should ensure the consistency yourself or the program can crash or--- generate incorrect results.-unsafeLeqProof :: forall m n. LeqProof m n-unsafeLeqProof = unsafeCoerce (LeqProof @0 @0)---- | Checks if a 'NatRepr' is less than or equal to another 'NatRepr'.-testLeq :: NatRepr m -> NatRepr n -> Maybe (LeqProof m n)-testLeq (NatRepr m) (NatRepr n) =-  case compare m n of-    LT -> Nothing-    EQ -> Just unsafeLeqProof-    GT -> Just unsafeLeqProof---- | Apply reflexivity to 'LeqProof'.-leqRefl :: f n -> LeqProof n n-leqRefl _ = LeqProof---- | A natural number is less than or equal to its successor.-leqSucc :: f n -> LeqProof n (n + 1)-leqSucc _ = unsafeLeqProof---- | Apply transitivity to 'LeqProof'.-leqTrans :: LeqProof a b -> LeqProof b c -> LeqProof a c-leqTrans _ _ = unsafeLeqProof---- | Zero is less than or equal to any natural number.-leqZero :: LeqProof 0 n-leqZero = unsafeLeqProof---- | Add both sides of two inequalities.-leqAdd2 :: LeqProof xl xh -> LeqProof yl yh -> LeqProof (xl + yl) (xh + yh)-leqAdd2 _ _ = unsafeLeqProof---- | Produce proof that adding a value to the larger element in an 'LeqProof'--- is larger.-leqAdd :: LeqProof m n -> f o -> LeqProof m (n + o)-leqAdd _ _ = unsafeLeqProof---- | Adding two positive natural numbers is positive.-leqAddPos :: (1 <= m, 1 <= n) => p m -> q n -> LeqProof 1 (m + n)-leqAddPos _ _ = unsafeLeqProof
+ test/Grisette/Backend/CEGISTests.hs view
@@ -0,0 +1,520 @@+{-# LANGUAGE BinaryLiterals #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++module Grisette.Backend.CEGISTests (cegisTests) where++import Control.Monad.Except (ExceptT)+import Data.IORef (atomicModifyIORef', modifyIORef', newIORef, readIORef)+import Data.Proxy (Proxy (Proxy))+import Data.String (IsString (fromString))+import GHC.Stack (HasCallStack)+import Grisette+  ( Apply (apply),+    AsKey (AsKey),+    CEGISResult (CEGISSolverFailure, CEGISSuccess, CEGISVerifierFailure),+    EvalSym (evalSym),+    ExtractSym,+    Function ((#)),+    GrisetteSMTConfig,+    ITEOp (symIte),+    LogicalOp (symNot, symXor, true, (.&&), (.||)),+    ModelRep (buildModel),+    ModelValuePair ((::=)),+    SizedBV (sizedBVConcat, sizedBVSelect, sizedBVSext, sizedBVZext),+    Solvable (con),+    SymEq ((.==)),+    SymOrd ((.<), (.>=)),+    Union,+    VerificationConditions,+    VerifierResult (CEGISVerifierFoundCex, CEGISVerifierNoCex),+    cegis,+    cegisExceptVC,+    cegisForAll,+    cegisForAllExceptVC,+    cegisMultiInputs,+    cegisPostCond,+    mrgIf,+    solve,+    solverGenericCEGIS,+    symAssert,+    symAssume,+    withSolver,+    z3,+  )+import Grisette.SymPrim+  ( SymBool,+    SymIntN,+    SymInteger,+    type (-~>),+    type (=~>),+  )+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit (Assertion, assertFailure, (@?=))++testCegis ::+  (HasCallStack, ExtractSym a, EvalSym a, SymEq a) =>+  GrisetteSMTConfig ->+  Bool ->+  a ->+  (a -> [SymBool]) ->+  Assertion+testCegis config shouldSuccess inputs bs = do+  cegisExceptVCResult <-+    cegisExceptVC config (inputs, "internal" :: SymInteger) return $+      \(cexInputs, internal) -> buildFormula internal (bs cexInputs)+  case cegisExceptVCResult of+    (_, CEGISSuccess m) -> do+      shouldSuccess @?= True+      verify "cegisExceptVC" m (bs inputs)+    _ -> shouldSuccess @?= False+  cegisForAllExceptVCResult <-+    cegisForAllExceptVC config (inputs, "internal" :: SymInteger) return $+      buildFormula "internal" (bs inputs)+  case cegisForAllExceptVCResult of+    (_, CEGISSuccess m) -> do+      shouldSuccess @?= True+      verify "cegisForAllExceptVC" m (bs inputs)+    _ -> shouldSuccess @?= False+  where+    verify _ _ [] = return ()+    verify funName m (v : vs) = do+      y <- solve config (evalSym False m $ symNot v)+      case y of+        Left _ -> verify funName m vs+        Right _ ->+          assertFailure $+            funName+              ++ ": Failed to verify "+              ++ show v+              ++ " with the model "+              ++ show m+    buildFormula internal l = do+      symAssume (internal .>= 0)+      go l 0+      where+        go ::+          [SymBool] -> SymInteger -> ExceptT VerificationConditions Union ()+        go [] _ = return ()+        go (x : xs) i =+          mrgIf+            (internal .>= i .&& internal .< (i + 1))+            (symAssert x)+            (go xs (i + 1))++cegisTests :: Test+cegisTests =+  let unboundedConfig = z3+   in testGroup+        "CEGIS"+        [ testGroup+            "Regression"+            [ testCase "Empty symbolic inputs makes cegis work like solve" $ do+                (_, CEGISSuccess m1) <-+                  cegisMultiInputs+                    z3+                    [1 :: Integer, 2]+                    (\idx -> cegisPostCond $ fromString $ "a" ++ show idx)+                Right m2 <- solve z3 ("a1" .&& "a2")+                m1 @?= m2,+              testCase "Lowering of TabularFun" $ do+                let s1 = "s1" :: SymInteger =~> SymInteger+                let s2 = "s2" :: SymInteger =~> SymInteger+                (_, CEGISSuccess m1) <-+                  cegis unboundedConfig ("cond" :: SymBool) $+                    \cond ->+                      cegisPostCond $+                        apply (symIte cond s1 s2) (symIte cond 1 2)+                          .== 10+                          .&& apply (symIte cond s1 s2) (symIte cond 3 4)+                          .== 100+                let s1e = evalSym False m1 s1+                let s2e = evalSym False m1 s2+                AsKey (s1e # 1) @?= AsKey 10+                AsKey (s1e # 3) @?= AsKey 100+                AsKey (s2e # 2) @?= AsKey 10+                AsKey (s2e # 4) @?= AsKey 100,+              testCase "Lowering of GeneralFun" $ do+                let s1 = "s1" :: SymInteger -~> SymInteger+                let s2 = "s2" :: SymInteger -~> SymInteger+                (_, CEGISSuccess m1) <-+                  cegis unboundedConfig ("cond" :: SymBool) $+                    \cond ->+                      cegisPostCond $+                        apply (symIte cond s1 s2) (symIte cond 1 2)+                          .== 10+                          .&& apply (symIte cond s1 s2) (symIte cond 3 4)+                          .== 100+                let s1e = evalSym False m1 s1+                let s2e = evalSym False m1 s2+                AsKey (s1e # 1) @?= AsKey 10+                AsKey (s1e # 3) @?= AsKey 100+                AsKey (s2e # 2) @?= AsKey 10+                AsKey (s2e # 4) @?= AsKey 100+            ],+          testGroup+            "Boolean"+            [ testCase "Basic" $ do+                testCegis unboundedConfig True () $ const ["a", "b", "c"]+                testCegis unboundedConfig False () $ const ["a", symNot "a"],+              testCase "And" $ do+                testCegis unboundedConfig True () $+                  const ["a" .&& "b", "b" .&& symNot "c", "a", "b", symNot "c"]+                testCegis unboundedConfig False () $+                  const ["a" .&& "b", "b" .&& symNot "c", "a", "b", "c"]+                testCegis unboundedConfig True ("a" :: SymBool) $+                  \a -> [symNot $ a .&& "b", symNot "b"]+                testCegis unboundedConfig False ("a" :: SymBool) $+                  \a -> [symNot $ a .&& "b", "b"],+              testCase "Or" $ do+                testCegis unboundedConfig True () $+                  const ["a" .|| "b", "b" .|| symNot "c", "a", "b", symNot "c"]+                testCegis unboundedConfig True () $+                  const ["a" .|| "b", "b" .|| symNot "c", "a", "b", "c"]+                testCegis unboundedConfig True ("a" :: SymBool) $+                  \a -> [a .|| "b", "b"]+                testCegis unboundedConfig False ("a" :: SymBool) $+                  \a -> [a .|| "b", symNot "b"],+              testCase "And / Or should be consistent" $ do+                testCegis unboundedConfig True () $+                  const ["a" .&& "b", "a" .|| "b"]+                testCegis unboundedConfig True () $+                  const [symNot "a" .&& "b", "a" .|| "b"]+                testCegis unboundedConfig False () $+                  const ["a" .&& "b", symNot $ "a" .|| "b"]+                testCegis unboundedConfig True () $+                  const [symNot $ "a" .&& "b", symNot $ "a" .|| "b"],+              testCase "Eqv" $ do+                testCegis unboundedConfig True () $+                  const [("a" :: SymBool) .== "b", "a", "b"]+                testCegis unboundedConfig True () $+                  const [("a" :: SymBool) .== "b", symNot "a", symNot "b"]+                testCegis unboundedConfig False () $+                  const [("a" :: SymBool) .== "b", symNot "a", "b"]+                testCegis unboundedConfig False () $+                  const [("a" :: SymBool) .== "b", symNot "a", "b"]+                testCegis unboundedConfig True () $+                  const [("a" :: SymBool) .== "b", symNot "a" `symXor` "b"]+                testCegis unboundedConfig False () $+                  const [("a" :: SymBool) .== "b", "a" `symXor` "b"],+              testCase "symIte" $ do+                testCegis unboundedConfig True ("c" :: SymBool) $+                  \c -> [symIte "a" "b" c, "a", "b"]+                testCegis unboundedConfig False ("c" :: SymBool) $+                  \c -> [symIte "a" "b" c, symNot "a"]+                testCegis unboundedConfig True ("b" :: SymBool) $+                  \b -> [symIte "a" b "c", symNot "a", "c"]+                testCegis unboundedConfig False ("b" :: SymBool) $+                  \b -> [symIte "a" b "c", "a"]+                testCegis unboundedConfig True () $+                  const [symIte "a" "b" "c", "a", "b", "c"]+                testCegis unboundedConfig True () $+                  const [symIte "a" "b" "c", "a", "b", symNot "c"]+                testCegis unboundedConfig True () $+                  const [symIte "a" "b" "c", symNot "a", "b", "c"]+                testCegis unboundedConfig True () $+                  const [symIte "a" "b" "c", symNot "a", symNot "b", "c"]+                testCegis unboundedConfig False () $+                  const [symIte "a" "b" "c", "a", symNot "b", "c"]+                testCegis unboundedConfig False () $+                  const [symIte "a" "b" "c", "a", symNot "b", symNot "c"]+                testCegis unboundedConfig False () $+                  const [symIte "a" "b" "c", symNot "a", "b", symNot "c"]+                testCegis unboundedConfig False () $+                  const [symIte "a" "b" "c", symNot "a", symNot "b", symNot "c"]+            ],+          let a = "a" :: SymIntN 5+              b = "b" :: SymIntN 5+              c = "c" :: SymIntN 5+              d = "c" :: SymIntN 10+           in testGroup+                "Different sized BV"+                [ testGroup+                    "Select"+                    [ testCase "sizedBVSelect" $ do+                        testCegis unboundedConfig True () $+                          const+                            [ sizedBVSelect (Proxy @2) (Proxy @2) a+                                .== (con 1 :: SymIntN 2),+                              a .== con 0b10101+                            ]+                        testCegis unboundedConfig False () $+                          const+                            [ sizedBVSelect (Proxy @2) (Proxy @2) a+                                .== (con 1 :: SymIntN 2),+                              a .== con 0b10001+                            ],+                      testCase "sizedBVSelect when lowered twice" $ do+                        testCegis unboundedConfig True a $+                          \ca ->+                            [ sizedBVSelect+                                (Proxy @2)+                                (Proxy @2)+                                (sizedBVConcat ca b)+                                .== (con 1 :: SymIntN 2)+                            ]+                        testCegis unboundedConfig True b $+                          \cb ->+                            [ sizedBVSelect+                                (Proxy @7)+                                (Proxy @2)+                                (sizedBVConcat a cb)+                                .== (con 1 :: SymIntN 2)+                            ]+                    ],+                  testGroup+                    "Concat"+                    [ testCase "sizedBVConcat" $ do+                        testCegis unboundedConfig True () $+                          const+                            [ sizedBVConcat a b .== d,+                              a .== con 1,+                              b .== con 1,+                              d .== con 0b100001+                            ]+                        testCegis unboundedConfig False () $+                          const+                            [ sizedBVConcat a b .== d,+                              a .== con 1,+                              b .== con 1,+                              d .== con 0b100010+                            ],+                      testCase "sizedBVConcat when lowered twice" $ do+                        testCegis unboundedConfig True (a, c) $+                          \(ca, cc) ->+                            [ sizedBVConcat+                                cc+                                ( sizedBVSelect+                                    (Proxy @2)+                                    (Proxy @2)+                                    (sizedBVConcat ca b) ::+                                    SymIntN 2+                                )+                                .== sizedBVConcat cc (con 1 :: SymIntN 2)+                            ]+                        testCegis unboundedConfig True (b, c) $+                          \(cb, cc) ->+                            [ sizedBVConcat+                                cc+                                ( sizedBVSelect+                                    (Proxy @7)+                                    (Proxy @2)+                                    (sizedBVConcat a cb) ::+                                    SymIntN 2+                                )+                                .== sizedBVConcat cc (con 1 :: SymIntN 2)+                            ]+                    ],+                  testGroup+                    "Zext"+                    [ testCase "sizedBVZext" $ do+                        testCegis unboundedConfig True () $+                          const+                            [ sizedBVZext (Proxy @10) a .== d,+                              a .== con 1,+                              d .== (con 1 :: SymIntN 10)+                            ]+                        testCegis unboundedConfig True () $+                          const+                            [ sizedBVZext (Proxy @10) a .== d,+                              a .== con 0b11111,+                              d .== (con 0b11111 :: SymIntN 10)+                            ]+                        testCegis unboundedConfig False () $+                          const+                            [ sizedBVZext (Proxy @10) a .== d,+                              d .== (con 0b111111 :: SymIntN 10)+                            ]+                        testCegis unboundedConfig False () $+                          const+                            [ sizedBVZext (Proxy @10) a .== d,+                              d .== (con 0b1111111111 :: SymIntN 10)+                            ],+                      testCase "sizedBVZext when lowered twice" $ do+                        testCegis unboundedConfig True a $+                          \ca ->+                            [ sizedBVZext+                                (Proxy @10)+                                ( sizedBVSelect+                                    (Proxy @2)+                                    (Proxy @2)+                                    (sizedBVConcat ca b) ::+                                    SymIntN 2+                                )+                                .== (con 1 :: SymIntN 10)+                            ]+                        testCegis unboundedConfig True b $+                          \cb ->+                            [ sizedBVZext+                                (Proxy @10)+                                ( sizedBVSelect+                                    (Proxy @7)+                                    (Proxy @2)+                                    (sizedBVConcat a cb) ::+                                    SymIntN 2+                                )+                                .== (con 1 :: SymIntN 10)+                            ]+                    ],+                  testGroup+                    "Sext"+                    [ testCase "sizedBVSext" $ do+                        testCegis unboundedConfig True () $+                          const+                            [ sizedBVSext (Proxy @10) a .== d,+                              a .== con 1,+                              d .== (con 1 :: SymIntN 10)+                            ]+                        testCegis unboundedConfig True () $+                          const+                            [ sizedBVSext (Proxy @10) a .== d,+                              a .== con 0b11111,+                              d .== (con 0b1111111111 :: SymIntN 10)+                            ]+                        testCegis unboundedConfig False () $+                          const+                            [ sizedBVSext (Proxy @10) a .== d,+                              d .== (con 0b111111 :: SymIntN 10)+                            ]+                        testCegis unboundedConfig False () $+                          const+                            [ sizedBVSext (Proxy @10) a .== d,+                              d .== (con 0b11111 :: SymIntN 10)+                            ],+                      testCase "sizedBVSext when lowered twice" $ do+                        testCegis unboundedConfig True a $ \ca ->+                          [ sizedBVSext+                              (Proxy @10)+                              ( sizedBVSelect+                                  (Proxy @2)+                                  (Proxy @2)+                                  (sizedBVConcat ca b) ::+                                  SymIntN 2+                              )+                              .== (con 1 :: SymIntN 10)+                          ]+                        testCegis unboundedConfig True b $+                          \cb ->+                            [ sizedBVSext+                                (Proxy @10)+                                ( sizedBVSelect+                                    (Proxy @7)+                                    (Proxy @2)+                                    (sizedBVConcat a cb) ::+                                    SymIntN 2+                                )+                                .== (con 1 :: SymIntN 10)+                            ]+                    ]+                ],+          testCase "cegisMultiInputs" $ do+            r <-+              cegisMultiInputs+                unboundedConfig+                [["a" :: SymInteger], ["b", "c"]]+                ( \case+                    [a] ->+                      cegisPostCond $+                        symIte+                          (a .== 1)+                          "x"+                          ("x" .&& symNot "y")+                    [b, _] ->+                      cegisPostCond $+                        symIte+                          (b .== 1)+                          (symIte "x" "z" "w")+                          (symIte "x" (symNot "w") (symNot "z"))+                    _ -> cegisPostCond $ con True+                )+            case snd r of+              CEGISSuccess m -> do+                let expectedModel =+                      buildModel+                        ( "x" ::= True,+                          "y" ::= False,+                          "z" ::= True,+                          "w" ::= False+                        )+                m @?= expectedModel+              CEGISVerifierFailure _ -> fail "Verifier failed"+              CEGISSolverFailure failure -> fail $ show failure,+          testCase "cegisForAll" $ do+            let a = "a" :: SymInteger+            let b = "b"+            r <-+              cegisForAll+                unboundedConfig+                [a, b]+                ( cegisPostCond $+                    symIte+                      (a .== 1)+                      ( symIte+                          (b .== 1)+                          "x"+                          ("x" .&& symNot "y")+                      )+                      ( symIte+                          (b .== 1)+                          (symIte "x" "z" "w")+                          (symIte "x" (symNot "w") (symNot "z"))+                      )+                )+            case snd r of+              CEGISSuccess m -> do+                let expectedModel =+                      buildModel+                        ( "x" ::= True,+                          "y" ::= False,+                          "z" ::= True,+                          "w" ::= False+                        )+                m @?= expectedModel+              CEGISVerifierFailure _ -> fail "Verifier failed"+              CEGISSolverFailure failure -> fail $ show failure,+          testGroup "rerun" $ do+            let verifier n trace retsIORef _ = do+                  modifyIORef' trace (n :)+                  ret <- atomicModifyIORef' retsIORef (\(x : xs) -> (xs, x))+                  if ret+                    then return $ CEGISVerifierFoundCex "Found"+                    else return $ CEGISVerifierNoCex True+            let createTestCase :: String -> Bool -> [[Bool]] -> [Int] -> Test+                createTestCase name rerun rets expected = testCase name $ do+                  trace <- newIORef []+                  retsIORefs <- traverse newIORef rets+                  withSolver unboundedConfig $ \handle ->+                    solverGenericCEGIS+                      handle+                      rerun+                      true+                      (const $ return true)+                      (zipWith (`verifier` trace) [0 ..] retsIORefs)+                  tracev <- readIORef trace+                  tracev @?= expected+            [ createTestCase+                "no rerun"+                False+                [[False], [True, False], [False]]+                [2, 1, 1, 0],+              createTestCase+                "do rerun"+                True+                [[False, False], [True, False], [False]]+                [0, 2, 1, 1, 0],+              createTestCase+                "do rerun complex"+                True+                [ [False, False, False],+                  [True, False, True, False],+                  [True, False, False],+                  [False, False]+                ]+                [0, 3, 2, 1, 1, 0, 3, 2, 2, 1, 1, 0]+              ]+        ]
+ test/Grisette/Backend/LoweringTests.hs view
@@ -0,0 +1,1171 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++module Grisette.Backend.LoweringTests (loweringTests) where++import Control.Monad.Trans (MonadIO (liftIO), MonadTrans (lift))+import Data.Bits+  ( Bits (complement, xor, (.&.), (.|.)),+  )+import Data.Dynamic (Typeable, fromDynamic)+import Data.Either (isRight)+import qualified Data.HashMap.Strict as M+import Data.Proxy (Proxy (Proxy))+import qualified Data.SBV as SBV+import qualified Data.SBV.Control as SBV+import qualified Data.Text as T+import GHC.Stack (HasCallStack)+import Grisette+  ( AsKey (AsKey),+    EvalSym (evalSym),+    FP,+    FPRoundingMode,+    Function ((#)),+    IntN,+    LogicalOp ((.&&)),+    Solvable (con),+    SymEq ((.==)),+    SymInteger,+    SymRep (SymType),+    WordN,+    solve,+    type (-~>),+    type (=~>),+  )+import Grisette.Internal.Backend.QuantifiedStack+  ( emptyQuantifiedStack,+  )+import Grisette.Internal.Backend.Solving+  ( GrisetteSMTConfig (sbvConfig),+    lowerSinglePrim,+    lowerSinglePrimCached,+    z3,+  )+import Grisette.Internal.Backend.SymBiMap+  ( SymBiMap (biMapToSBV),+  )+import Grisette.Internal.Core.Data.Class.AsKey (KeyEq)+import Grisette.Internal.SymPrim.AlgReal (AlgReal)+import Grisette.Internal.SymPrim.FP (FP32)+import Grisette.Internal.SymPrim.Prim.SomeTerm+  ( SomeTerm (SomeTerm),+  )+import Grisette.Internal.SymPrim.Prim.Term+  ( FPTrait+      ( FPIsInfinite,+        FPIsNaN,+        FPIsNegative,+        FPIsNegativeInfinite,+        FPIsNegativeZero,+        FPIsNormal,+        FPIsPoint,+        FPIsPositive,+        FPIsPositiveInfinite,+        FPIsPositiveZero,+        FPIsSubnormal,+        FPIsZero+      ),+    FloatingUnaryOp+      ( FloatingAcos,+        FloatingAsin,+        FloatingAtan,+        FloatingCos,+        FloatingCosh,+        FloatingSin,+        FloatingSinh,+        FloatingTan,+        FloatingTanh+      ),+    SBVRep (SBVType),+    SupportedPrim,+    Term,+    TypedConstantSymbol,+    absNumTerm,+    addNumTerm,+    andBitsTerm,+    andTerm,+    bitCastOrTerm,+    bitCastTerm,+    bvConcatTerm,+    bvSelectTerm,+    bvsignExtendTerm,+    bvzeroExtendTerm,+    complementBitsTerm,+    conTerm,+    divIntegralTerm,+    eqTerm,+    existsTerm,+    fdivTerm,+    floatingUnaryTerm,+    forallTerm,+    fpTraitTerm,+    iteTerm,+    leOrdTerm,+    ltOrdTerm,+    modIntegralTerm,+    mulNumTerm,+    negNumTerm,+    notTerm,+    orBitsTerm,+    orTerm,+    pevalAndTerm,+    pevalFPTraitTerm,+    pevalNotTerm,+    quotIntegralTerm,+    recipTerm,+    remIntegralTerm,+    rotateLeftTerm,+    rotateRightTerm,+    shiftLeftTerm,+    shiftRightTerm,+    signumNumTerm,+    ssymTerm,+    xorBitsTerm,+  )+import Test.Framework (Test, TestOptions' (topt_timeout), plusTestOptions, testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.HUnit (Assertion, assertBool, assertFailure, (@?=))+import Test.QuickCheck (Arbitrary, ioProperty)+import Type.Reflection (typeRep)++testUnaryOpLowering ::+  forall a b as.+  ( HasCallStack,+    SupportedPrim a,+    SBV.EqSymbolic (SBVType b),+    Typeable (SBVType a),+    SBV.SymVal as,+    SBVType a ~ SBV.SBV as,+    Show as+  ) =>+  GrisetteSMTConfig ->+  (Term a -> Term b) ->+  String ->+  (SBVType a -> SBVType b) ->+  Assertion+testUnaryOpLowering = testUnaryOpLowering' Nothing++testUnaryOpLowering' ::+  forall a b as.+  ( HasCallStack,+    SupportedPrim a,+    SBV.EqSymbolic (SBVType b),+    Typeable (SBVType a),+    SBV.SymVal as,+    SBVType a ~ SBV.SBV as,+    Show as+  ) =>+  (Maybe (SBVType a -> SBVType Bool)) ->+  GrisetteSMTConfig ->+  (Term a -> Term b) ->+  String ->+  (SBVType a -> SBVType b) ->+  Assertion+testUnaryOpLowering' precond config f name sbvfun = do+  let a :: Term a = ssymTerm "a"+  let fa :: Term b = f a+  SBV.runSMTWith (sbvConfig config) $ do+    (m, lt, _) <- lowerSinglePrim fa+    let sbva :: Maybe (SBVType a) =+          M.lookup (SomeTerm a) (biMapToSBV m)+            >>= \f -> fromDynamic (f emptyQuantifiedStack)+    case sbva of+      Nothing -> lift $ assertFailure "Failed to extract the term"+      Just sbvav -> SBV.query $ do+        SBV.constrain $ lt emptyQuantifiedStack SBV..== sbvfun sbvav+        satres <- SBV.checkSat+        case satres of+          SBV.Sat -> return ()+          _ -> lift $ assertFailure $ "Lowering for " ++ name ++ " generated unsolvable formula"+  SBV.runSMTWith (sbvConfig config) $ do+    (m, lt, _) <- lowerSinglePrim fa+    let sbvv :: Maybe (SBVType a) =+          M.lookup (SomeTerm a) (biMapToSBV m)+            >>= \f -> fromDynamic (f emptyQuantifiedStack)+    case sbvv of+      Nothing -> lift $ assertFailure "Failed to extract the term"+      Just sbvvv -> SBV.query $ do+        case precond of+          Just p -> SBV.constrain $ p sbvvv+          Nothing -> return ()+        SBV.constrain $ lt emptyQuantifiedStack SBV../= sbvfun sbvvv+        r <- SBV.checkSat+        case r of+          SBV.Sat -> do+            counterExample <- SBV.getValue sbvvv+            lift $ assertFailure $ "Translation counter example found: " ++ show counterExample+          SBV.Unsat -> return ()+          _ -> lift $ assertFailure $ "Lowering for " ++ name ++ " generated unknown formula"++testBinaryOpLowering ::+  forall a b c as bs.+  ( HasCallStack,+    SupportedPrim a,+    SupportedPrim b,+    SBV.EqSymbolic (SBVType c),+    Typeable (SBVType a),+    Typeable (SBVType b),+    SBV.SymVal as,+    SBV.SymVal bs,+    Show as,+    Show bs,+    SBVType a ~ SBV.SBV as,+    SBVType b ~ SBV.SBV bs+  ) =>+  GrisetteSMTConfig ->+  (Term a -> Term b -> Term c) ->+  String ->+  (SBVType a -> SBVType b -> SBVType c) ->+  Assertion+testBinaryOpLowering config f name sbvfun = do+  let a :: Term a = ssymTerm "a"+  let b :: Term b = ssymTerm "b"+  let fab :: Term c = f a b+  SBV.runSMTWith (sbvConfig config) $ do+    (m, lt, _) <- lowerSinglePrim fab+    let sbva :: Maybe (SBVType a) =+          M.lookup (SomeTerm a) (biMapToSBV m)+            >>= \f -> fromDynamic (f emptyQuantifiedStack)+    let sbvb :: Maybe (SBVType b) =+          M.lookup (SomeTerm b) (biMapToSBV m)+            >>= \f -> fromDynamic (f emptyQuantifiedStack)+    case (sbva, sbvb) of+      (Just sbvav, Just sbvbv) -> SBV.query $ do+        SBV.constrain $ lt emptyQuantifiedStack SBV..== sbvfun sbvav sbvbv+        satres <- SBV.checkSat+        case satres of+          SBV.Sat -> return ()+          _ -> lift $ assertFailure $ "Lowering for " ++ name ++ " generated unsolvable formula"+      _ -> lift $ assertFailure "Failed to extract the term"+  SBV.runSMTWith (sbvConfig config) $ do+    (m, lt, _) <- lowerSinglePrim fab+    let sbva :: Maybe (SBVType a) =+          M.lookup (SomeTerm a) (biMapToSBV m)+            >>= \f -> fromDynamic (f emptyQuantifiedStack)+    let sbvb :: Maybe (SBVType b) =+          M.lookup (SomeTerm b) (biMapToSBV m)+            >>= \f -> fromDynamic (f emptyQuantifiedStack)+    case (sbva, sbvb) of+      (Just sbvav, Just sbvbv) -> SBV.query $ do+        SBV.constrain $ lt emptyQuantifiedStack SBV../= sbvfun sbvav sbvbv+        r <- SBV.checkSat+        case r of+          SBV.Sat -> do+            counterExampleA <- SBV.getValue sbvav+            counterExampleB <- SBV.getValue sbvbv+            lift $ assertFailure $ "Translation counter example found: " ++ show (counterExampleA, counterExampleB)+          SBV.Unsat -> return ()+          _ -> lift $ assertFailure $ "Lowering for " ++ name ++ " generated unknown formula"+      _ -> lift $ assertFailure "Failed to extract the term"++testTernaryOpLowering ::+  forall a b c d as bs cs.+  ( HasCallStack,+    SupportedPrim a,+    SupportedPrim b,+    SupportedPrim c,+    SBV.EqSymbolic (SBVType d),+    Typeable (SBVType a),+    Typeable (SBVType b),+    Typeable (SBVType c),+    SBV.SymVal as,+    SBV.SymVal bs,+    SBV.SymVal cs,+    Show as,+    Show bs,+    Show cs,+    SBVType a ~ SBV.SBV as,+    SBVType b ~ SBV.SBV bs,+    SBVType c ~ SBV.SBV cs+  ) =>+  GrisetteSMTConfig ->+  (Term a -> Term b -> Term c -> Term Bool) ->+  (Term a -> Term b -> Term c -> Term d) ->+  T.Text ->+  (SBVType a -> SBVType b -> SBVType c -> SBVType d) ->+  Assertion+testTernaryOpLowering config precond f name sbvfun = do+  let a :: Term a = ssymTerm "a"+  let b :: Term b = ssymTerm "b"+  let c :: Term c = ssymTerm "c"+  let fabc :: Term d = f a b c+  SBV.runSMTWith (sbvConfig config) $ do+    (m, lt, _) <- lowerSinglePrim fabc+    let sbva :: Maybe (SBVType a) =+          M.lookup (SomeTerm a) (biMapToSBV m)+            >>= \f -> fromDynamic (f emptyQuantifiedStack)+    let sbvb :: Maybe (SBVType b) =+          M.lookup (SomeTerm b) (biMapToSBV m)+            >>= \f -> fromDynamic (f emptyQuantifiedStack)+    let sbvc :: Maybe (SBVType c) =+          M.lookup (SomeTerm c) (biMapToSBV m)+            >>= \f -> fromDynamic (f emptyQuantifiedStack)+    case (sbva, sbvb, sbvc) of+      (Just sbvav, Just sbvbv, Just sbvcv) -> SBV.query $ do+        SBV.constrain $ lt emptyQuantifiedStack SBV..== sbvfun sbvav sbvbv sbvcv+        satres <- SBV.checkSat+        case satres of+          SBV.Sat -> return ()+          _ -> lift $ assertFailure $ T.unpack $ "Lowering for " <> name <> " generated unsolvable formula"+      _ -> lift $ assertFailure "Failed to extract the term"+  SBV.runSMTWith (sbvConfig config) $ do+    (m, lt, _) <- lowerSinglePrim fabc+    (m2, p, _) <- lowerSinglePrimCached (precond a b c) m+    let sbva :: Maybe (SBVType a) =+          M.lookup (SomeTerm a) (biMapToSBV m2)+            >>= \f -> fromDynamic (f emptyQuantifiedStack)+    let sbvb :: Maybe (SBVType b) =+          M.lookup (SomeTerm b) (biMapToSBV m2)+            >>= \f -> fromDynamic (f emptyQuantifiedStack)+    let sbvc :: Maybe (SBVType c) =+          M.lookup (SomeTerm c) (biMapToSBV m2)+            >>= \f -> fromDynamic (f emptyQuantifiedStack)+    case (sbva, sbvb, sbvc) of+      (Just sbvav, Just sbvbv, Just sbvcv) -> SBV.query $ do+        SBV.constrain $+          (lt emptyQuantifiedStack SBV../= sbvfun sbvav sbvbv sbvcv)+            SBV..&& p emptyQuantifiedStack+        r <- SBV.checkSat+        case r of+          SBV.Sat -> do+            counterExampleA <- SBV.getValue sbvav+            counterExampleB <- SBV.getValue sbvbv+            counterExampleC <- SBV.getValue sbvcv+            lift $+              assertFailure $+                "Translation counter example found: "+                  ++ show (counterExampleA, counterExampleB, counterExampleC)+          SBV.Unsat -> return ()+          _ -> lift $ assertFailure $ T.unpack $ "Lowering for " <> name <> " generated unknown formula"+      _ -> lift $ assertFailure "Failed to extract the term"++modelParseTestBody ::+  forall t.+  ( Solvable t (SymType t),+    SymEq (SymType t),+    EvalSym (SymType t),+    KeyEq (SymType t),+    Show (SymType t)+  ) =>+  t ->+  Assertion+modelParseTestBody v = do+  let a = "a" :: SymType t+  r <- solve z3 $ a .== con v+  case r of+    Left err -> assertFailure $ "Failed to solve: " ++ show err+    Right m -> AsKey (evalSym False m a) @?= AsKey (con v)++testModelParse ::+  forall t.+  ( Show t,+    Arbitrary t,+    Solvable t (SymType t),+    SymEq (SymType t),+    EvalSym (SymType t),+    Show (SymType t),+    Typeable t,+    KeyEq (SymType t)+  ) =>+  Test+testModelParse = testProperty ("Model parse(" ++ show (typeRep @t) ++ ")") $+  \(v :: t) -> ioProperty $ modelParseTestBody v++loweringTests :: Test+loweringTests =+  let unboundedConfig = z3 {sbvConfig = SBV.z3 {SBV.solverSetOptions = [SBV.SetLogic SBV.Logic_ALL]}}+   in testGroup+        "Lowering"+        [ plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $+            testCase "proper memo" $ do+              let pair = ("a" :: SymInteger, "b" :: SymInteger)+              let iter (x, y) = (y, x + y)+              let r = iterate iter pair !! 100+              m <- solve z3 $ snd r .== 0+              assertBool "should success" $ isRight m,+          testGroup+            "Bool Lowering"+            [ testModelParse @Bool,+              testCase "Not" $ do+                testUnaryOpLowering @Bool @Bool unboundedConfig notTerm "not" SBV.sNot,+              testCase "And" $ do+                testBinaryOpLowering @Bool @Bool @Bool unboundedConfig andTerm "and" (SBV..&&)+                testBinaryOpLowering @Bool @Bool @Bool+                  unboundedConfig+                  andTerm+                  "and"+                  (\x y -> SBV.sNot (x SBV..<+> y) SBV..&& (x SBV..|| y)),+              testCase "Or" $ do+                testBinaryOpLowering @Bool @Bool @Bool unboundedConfig orTerm "or" (SBV..||)+                testBinaryOpLowering @Bool @Bool @Bool+                  unboundedConfig+                  orTerm+                  "or"+                  (\x y -> (x SBV..<+> y) SBV..|| (x SBV..&& y)),+              testCase "Eqv" $ do+                testBinaryOpLowering @Bool @Bool @Bool unboundedConfig eqTerm "eqv" (SBV..==)+                testBinaryOpLowering @Bool @Bool @Bool+                  unboundedConfig+                  eqTerm+                  "eqv"+                  (\x y -> SBV.sNot (x SBV..<+> y)),+              testCase "ITE" $ do+                let truePrecond _ _ _ = conTerm True+                testTernaryOpLowering @Bool @Bool @Bool @Bool+                  unboundedConfig+                  truePrecond+                  iteTerm+                  "ite"+                  SBV.ite+                testTernaryOpLowering @Bool @Bool @Bool @Bool+                  unboundedConfig+                  truePrecond+                  iteTerm+                  "ite"+                  (\c x y -> (c SBV..=> x) SBV..&& (SBV.sNot c SBV..=> y))+            ],+          testGroup+            "Integer Lowering"+            [ testModelParse @Integer,+              testCase "Add" $ do+                testBinaryOpLowering @Integer @Integer @Integer unboundedConfig addNumTerm "(+)" (+)+                testBinaryOpLowering @Integer @Integer @Integer+                  unboundedConfig+                  addNumTerm+                  "(+)"+                  (\x y -> (x + 1) * (y + 1) - x * y - 1),+              testCase "Uminus" $ do+                testUnaryOpLowering @Integer @Integer unboundedConfig negNumTerm "negate" negate+                testUnaryOpLowering @Integer @Integer+                  unboundedConfig+                  negNumTerm+                  "negate"+                  (\x -> (x + 1) * (x + 1) - 3 * x - x * x - 1),+              testCase "Abs" $ do+                testUnaryOpLowering @Integer @Integer unboundedConfig absNumTerm "abs" abs,+              testCase "Signum" $ do+                testUnaryOpLowering @Integer @Integer unboundedConfig signumNumTerm "signum" signum,+              testCase "Times" $ do+                testBinaryOpLowering @Integer @Integer @Integer unboundedConfig mulNumTerm "(*)" (*)+                testBinaryOpLowering @Integer @Integer @Integer+                  unboundedConfig+                  mulNumTerm+                  "(*)"+                  (\x y -> (x + 1) * (y + 1) - x - y - 1),+              testCase "Lt" $ do+                testBinaryOpLowering @Integer @Integer @Bool unboundedConfig ltOrdTerm "(<)" (SBV..<)+                testBinaryOpLowering @Integer @Integer @Bool+                  unboundedConfig+                  ltOrdTerm+                  "(<)"+                  (\x y -> x * 2 - x SBV..< y * 2 - y),+              testCase "Le" $ do+                testBinaryOpLowering @Integer @Integer @Bool unboundedConfig leOrdTerm "(<=)" (SBV..<=)+                testBinaryOpLowering @Integer @Integer @Bool+                  unboundedConfig+                  leOrdTerm+                  "(<=)"+                  (\x y -> x * 2 - x SBV..<= y * 2 - y),+              testCase "Div" $ do+                testBinaryOpLowering @Integer @Integer @Integer unboundedConfig divIntegralTerm "div" SBV.sDiv,+              testCase "Mod" $ do+                testBinaryOpLowering @Integer @Integer @Integer unboundedConfig modIntegralTerm "mod" SBV.sMod,+              testCase "Quot" $ do+                testBinaryOpLowering @Integer @Integer @Integer unboundedConfig quotIntegralTerm "quot" SBV.sQuot,+              testCase "Rem" $ do+                testBinaryOpLowering @Integer @Integer @Integer unboundedConfig remIntegralTerm "rem" SBV.sRem+            ],+          testGroup+            "IntN Lowering"+            [ testModelParse @(IntN 4),+              testCase "Add" $ do+                testBinaryOpLowering @(IntN 5) @(IntN 5) unboundedConfig addNumTerm "(+)" (+)+                testBinaryOpLowering @(IntN 5) @(IntN 5)+                  unboundedConfig+                  addNumTerm+                  "(+)"+                  (\x y -> (x + 1) * (y + 1) - x * y - 1),+              testCase "Uminus" $ do+                testUnaryOpLowering @(IntN 5) unboundedConfig negNumTerm "negate" negate+                testUnaryOpLowering @(IntN 5)+                  unboundedConfig+                  negNumTerm+                  "negate"+                  (\x -> (x + 1) * (x + 1) - 3 * x - x * x - 1),+              testCase "Abs" $ do+                testUnaryOpLowering @(IntN 5) unboundedConfig absNumTerm "abs" abs,+              testCase "Signum" $ do+                testUnaryOpLowering @(IntN 5) unboundedConfig signumNumTerm "signum" signum,+              testCase "Times" $ do+                testBinaryOpLowering @(IntN 5) @(IntN 5) unboundedConfig mulNumTerm "(*)" (*)+                testBinaryOpLowering @(IntN 5) @(IntN 5)+                  unboundedConfig+                  mulNumTerm+                  "(*)"+                  (\x y -> (x + 1) * (y + 1) - x - y - 1),+              testCase "Lt" $ do+                testBinaryOpLowering @(IntN 5) @(IntN 5) unboundedConfig ltOrdTerm "(<)" (SBV..<)+                testBinaryOpLowering @(IntN 5) @(IntN 5)+                  unboundedConfig+                  ltOrdTerm+                  "(<)"+                  (\x y -> x * 2 - x SBV..< y * 2 - y),+              testCase "Le" $ do+                testBinaryOpLowering @(IntN 5) @(IntN 5) unboundedConfig leOrdTerm "(<=)" (SBV..<=)+                testBinaryOpLowering @(IntN 5) @(IntN 5)+                  unboundedConfig+                  leOrdTerm+                  "(<=)"+                  (\x y -> x * 2 - x SBV..<= y * 2 - y),+              testCase "Extract" $ do+                testUnaryOpLowering @(IntN 5) @(IntN 1)+                  unboundedConfig+                  (bvSelectTerm (Proxy @0) (Proxy @1))+                  "select"+                  (SBV.bvExtract @0 @0 @5 Proxy Proxy)+                testUnaryOpLowering @(IntN 5) @(IntN 1)+                  unboundedConfig+                  (bvSelectTerm (Proxy @1) (Proxy @1))+                  "select"+                  (SBV.bvExtract @1 @1 @5 Proxy Proxy)+                testUnaryOpLowering @(IntN 5) @(IntN 1)+                  unboundedConfig+                  (bvSelectTerm (Proxy @2) (Proxy @1))+                  "select"+                  (SBV.bvExtract @2 @2 @5 Proxy Proxy)+                testUnaryOpLowering @(IntN 5) @(IntN 1)+                  unboundedConfig+                  (bvSelectTerm (Proxy @3) (Proxy @1))+                  "select"+                  (SBV.bvExtract @3 @3 @5 Proxy Proxy)+                testUnaryOpLowering @(IntN 5) @(IntN 1)+                  unboundedConfig+                  (bvSelectTerm (Proxy @4) (Proxy @1))+                  "select"+                  (SBV.bvExtract @4 @4 @5 Proxy Proxy)+                testUnaryOpLowering @(IntN 5) @(IntN 2)+                  unboundedConfig+                  (bvSelectTerm (Proxy @0) (Proxy @2))+                  "select"+                  (SBV.bvExtract @1 @0 @5 Proxy Proxy)+                testUnaryOpLowering @(IntN 5) @(IntN 2)+                  unboundedConfig+                  (bvSelectTerm (Proxy @1) (Proxy @2))+                  "select"+                  (SBV.bvExtract @2 @1 @5 Proxy Proxy)+                testUnaryOpLowering @(IntN 5) @(IntN 2)+                  unboundedConfig+                  (bvSelectTerm (Proxy @2) (Proxy @2))+                  "select"+                  (SBV.bvExtract @3 @2 @5 Proxy Proxy)+                testUnaryOpLowering @(IntN 5) @(IntN 2)+                  unboundedConfig+                  (bvSelectTerm (Proxy @3) (Proxy @2))+                  "select"+                  (SBV.bvExtract @4 @3 @5 Proxy Proxy)+                testUnaryOpLowering @(IntN 5) @(IntN 3)+                  unboundedConfig+                  (bvSelectTerm (Proxy @0) (Proxy @3))+                  "select"+                  (SBV.bvExtract @2 @0 @5 Proxy Proxy)+                testUnaryOpLowering @(IntN 5) @(IntN 3)+                  unboundedConfig+                  (bvSelectTerm (Proxy @1) (Proxy @3))+                  "select"+                  (SBV.bvExtract @3 @1 @5 Proxy Proxy)+                testUnaryOpLowering @(IntN 5) @(IntN 3)+                  unboundedConfig+                  (bvSelectTerm (Proxy @2) (Proxy @3))+                  "select"+                  (SBV.bvExtract @4 @2 @5 Proxy Proxy)+                testUnaryOpLowering @(IntN 5) @(IntN 4)+                  unboundedConfig+                  (bvSelectTerm (Proxy @0) (Proxy @4))+                  "select"+                  (SBV.bvExtract @3 @0 @5 Proxy Proxy)+                testUnaryOpLowering @(IntN 5) @(IntN 4)+                  unboundedConfig+                  (bvSelectTerm (Proxy @1) (Proxy @4))+                  "select"+                  (SBV.bvExtract @4 @1 @5 Proxy Proxy)+                testUnaryOpLowering @(IntN 5) @(IntN 5)+                  unboundedConfig+                  (bvSelectTerm (Proxy @0) (Proxy @5))+                  "select"+                  id,+              testCase "Extension" $ do+                testUnaryOpLowering @(IntN 5) @(IntN 6)+                  unboundedConfig+                  (bvzeroExtendTerm (Proxy @6))+                  "bvzeroExtend"+                  SBV.zeroExtend+                testUnaryOpLowering @(IntN 5) @(IntN 10)+                  unboundedConfig+                  (bvzeroExtendTerm (Proxy @10))+                  "bvzeroExtend"+                  SBV.zeroExtend+                testUnaryOpLowering @(IntN 5) @(IntN 6)+                  unboundedConfig+                  (bvsignExtendTerm (Proxy @6))+                  "bvsignExtend"+                  SBV.signExtend+                testUnaryOpLowering @(IntN 5) @(IntN 10)+                  unboundedConfig+                  (bvsignExtendTerm (Proxy @10))+                  "bvsignExtend"+                  SBV.signExtend,+              testCase "Concat" $ do+                testBinaryOpLowering @(IntN 4) @(IntN 5) @(IntN 9)+                  unboundedConfig+                  bvConcatTerm+                  "bvconcat"+                  (SBV.#),+              testCase "AndBits" $ do+                testBinaryOpLowering @(IntN 5) @(IntN 5) unboundedConfig andBitsTerm "(.&.)" (.&.),+              testCase "OrBits" $ do+                testBinaryOpLowering @(IntN 5) @(IntN 5) unboundedConfig orBitsTerm "(.|.)" (.|.),+              testCase "XorBits" $ do+                testBinaryOpLowering @(IntN 5) @(IntN 5) unboundedConfig xorBitsTerm "xor" xor,+              testCase "ComplementBits" $ do+                testUnaryOpLowering @(IntN 5) unboundedConfig complementBitsTerm "complement" complement,+              testCase "ShiftLeft" $ do+                testBinaryOpLowering @(IntN 5) unboundedConfig shiftLeftTerm "shiftLeft" SBV.sShiftLeft,+              testCase "ShiftRight" $ do+                testBinaryOpLowering @(IntN 5) unboundedConfig shiftRightTerm "shiftRight" SBV.sShiftRight,+              testCase "RotateLeft" $ do+                testBinaryOpLowering @(IntN 5)+                  unboundedConfig+                  rotateLeftTerm+                  "rotateLeft"+                  ( \a b ->+                      SBV.sFromIntegral $+                        SBV.sRotateLeft+                          (SBV.sFromIntegral a :: SBV.SWord 5)+                          (SBV.sFromIntegral b :: SBV.SWord 5)+                  ),+              testCase "RotateRight" $ do+                testBinaryOpLowering @(IntN 5)+                  unboundedConfig+                  rotateRightTerm+                  "rotateRight"+                  ( \a b ->+                      SBV.sFromIntegral $+                        SBV.sRotateRight+                          (SBV.sFromIntegral a :: SBV.SWord 5)+                          (SBV.sFromIntegral b :: SBV.SWord 5)+                  ),+              testCase "Div - bounded" $ do+                testBinaryOpLowering @(IntN 5) @(IntN 5) @(IntN 5) unboundedConfig divIntegralTerm "div" SBV.sDiv,+              testCase "Mod - bounded" $ do+                testBinaryOpLowering @(IntN 5) @(IntN 5) @(IntN 5) unboundedConfig modIntegralTerm "mod" SBV.sMod,+              testCase "Quot - bounded" $ do+                testBinaryOpLowering @(IntN 5) @(IntN 5) @(IntN 5) unboundedConfig quotIntegralTerm "quot" SBV.sQuot,+              testCase "Rem - bounded" $ do+                testBinaryOpLowering @(IntN 5) @(IntN 5) @(IntN 5) unboundedConfig remIntegralTerm "rem" SBV.sRem,+              testCase "BitCast" $ do+                testUnaryOpLowering @(IntN 5) @(WordN 5) unboundedConfig bitCastTerm "bitCast" SBV.sFromIntegral+                testUnaryOpLowering @(IntN 1) @Bool unboundedConfig bitCastTerm "bitCast" (`SBV.sTestBit` 0)+                testUnaryOpLowering @Bool @(IntN 1) unboundedConfig bitCastTerm "bitCast" (\x -> SBV.ite x 1 0)+            ],+          testGroup+            "WordN"+            [ testModelParse @(WordN 4),+              testCase "Add" $ do+                testBinaryOpLowering @(WordN 5) @(WordN 5) unboundedConfig addNumTerm "(+)" (+)+                testBinaryOpLowering @(WordN 5) @(WordN 5)+                  unboundedConfig+                  addNumTerm+                  "(+)"+                  (\x y -> (x + 1) * (y + 1) - x * y - 1),+              testCase "Uminus" $ do+                testUnaryOpLowering @(WordN 5) unboundedConfig negNumTerm "negate" negate+                testUnaryOpLowering @(WordN 5)+                  unboundedConfig+                  negNumTerm+                  "negate"+                  (\x -> (x + 1) * (x + 1) - 3 * x - x * x - 1),+              testCase "Abs" $ do+                testUnaryOpLowering @(WordN 5) unboundedConfig absNumTerm "abs" abs,+              testCase "Signum" $ do+                testUnaryOpLowering @(WordN 5) unboundedConfig signumNumTerm "signum" signum,+              testCase "Times" $ do+                testBinaryOpLowering @(WordN 5) @(WordN 5) unboundedConfig mulNumTerm "(*)" (*)+                testBinaryOpLowering @(WordN 5) @(WordN 5)+                  unboundedConfig+                  mulNumTerm+                  "(*)"+                  (\x y -> (x + 1) * (y + 1) - x - y - 1),+              testCase "Lt" $ do+                testBinaryOpLowering @(WordN 5) @(WordN 5) unboundedConfig ltOrdTerm "(<)" (SBV..<)+                testBinaryOpLowering @(WordN 5) @(WordN 5)+                  unboundedConfig+                  ltOrdTerm+                  "(<)"+                  (\x y -> x * 2 - x SBV..< y * 2 - y),+              testCase "Le" $ do+                testBinaryOpLowering @(WordN 5) @(WordN 5) unboundedConfig leOrdTerm "(<=)" (SBV..<=)+                testBinaryOpLowering @(WordN 5) @(WordN 5)+                  unboundedConfig+                  leOrdTerm+                  "(<=)"+                  (\x y -> x * 2 - x SBV..<= y * 2 - y),+              testCase "Extract" $ do+                testUnaryOpLowering @(WordN 5) @(WordN 1)+                  unboundedConfig+                  (bvSelectTerm (Proxy @0) (Proxy @1))+                  "select"+                  (SBV.bvExtract @0 @0 @5 Proxy Proxy)+                testUnaryOpLowering @(WordN 5) @(WordN 1)+                  unboundedConfig+                  (bvSelectTerm (Proxy @1) (Proxy @1))+                  "select"+                  (SBV.bvExtract @1 @1 @5 Proxy Proxy)+                testUnaryOpLowering @(WordN 5) @(WordN 1)+                  unboundedConfig+                  (bvSelectTerm (Proxy @2) (Proxy @1))+                  "select"+                  (SBV.bvExtract @2 @2 @5 Proxy Proxy)+                testUnaryOpLowering @(WordN 5) @(WordN 1)+                  unboundedConfig+                  (bvSelectTerm (Proxy @3) (Proxy @1))+                  "select"+                  (SBV.bvExtract @3 @3 @5 Proxy Proxy)+                testUnaryOpLowering @(WordN 5) @(WordN 1)+                  unboundedConfig+                  (bvSelectTerm (Proxy @4) (Proxy @1))+                  "select"+                  (SBV.bvExtract @4 @4 @5 Proxy Proxy)+                testUnaryOpLowering @(WordN 5) @(WordN 2)+                  unboundedConfig+                  (bvSelectTerm (Proxy @0) (Proxy @2))+                  "select"+                  (SBV.bvExtract @1 @0 @5 Proxy Proxy)+                testUnaryOpLowering @(WordN 5) @(WordN 2)+                  unboundedConfig+                  (bvSelectTerm (Proxy @1) (Proxy @2))+                  "select"+                  (SBV.bvExtract @2 @1 @5 Proxy Proxy)+                testUnaryOpLowering @(WordN 5) @(WordN 2)+                  unboundedConfig+                  (bvSelectTerm (Proxy @2) (Proxy @2))+                  "select"+                  (SBV.bvExtract @3 @2 @5 Proxy Proxy)+                testUnaryOpLowering @(WordN 5) @(WordN 2)+                  unboundedConfig+                  (bvSelectTerm (Proxy @3) (Proxy @2))+                  "select"+                  (SBV.bvExtract @4 @3 @5 Proxy Proxy)+                testUnaryOpLowering @(WordN 5) @(WordN 3)+                  unboundedConfig+                  (bvSelectTerm (Proxy @0) (Proxy @3))+                  "select"+                  (SBV.bvExtract @2 @0 @5 Proxy Proxy)+                testUnaryOpLowering @(WordN 5) @(WordN 3)+                  unboundedConfig+                  (bvSelectTerm (Proxy @1) (Proxy @3))+                  "select"+                  (SBV.bvExtract @3 @1 @5 Proxy Proxy)+                testUnaryOpLowering @(WordN 5) @(WordN 3)+                  unboundedConfig+                  (bvSelectTerm (Proxy @2) (Proxy @3))+                  "select"+                  (SBV.bvExtract @4 @2 @5 Proxy Proxy)+                testUnaryOpLowering @(WordN 5) @(WordN 4)+                  unboundedConfig+                  (bvSelectTerm (Proxy @0) (Proxy @4))+                  "select"+                  (SBV.bvExtract @3 @0 @5 Proxy Proxy)+                testUnaryOpLowering @(WordN 5) @(WordN 4)+                  unboundedConfig+                  (bvSelectTerm (Proxy @1) (Proxy @4))+                  "select"+                  (SBV.bvExtract @4 @1 @5 Proxy Proxy)+                testUnaryOpLowering @(WordN 5) @(WordN 5)+                  unboundedConfig+                  (bvSelectTerm (Proxy @0) (Proxy @5))+                  "select"+                  id,+              testCase "Extension" $ do+                testUnaryOpLowering @(WordN 5) @(WordN 6)+                  unboundedConfig+                  (bvzeroExtendTerm (Proxy @6))+                  "bvzeroExtend"+                  SBV.zeroExtend+                testUnaryOpLowering @(WordN 5) @(WordN 10)+                  unboundedConfig+                  (bvzeroExtendTerm (Proxy @10))+                  "bvzeroExtend"+                  SBV.zeroExtend+                testUnaryOpLowering @(WordN 5) @(WordN 6)+                  unboundedConfig+                  (bvsignExtendTerm (Proxy @6))+                  "bvsignExtend"+                  SBV.signExtend+                testUnaryOpLowering @(WordN 5) @(WordN 10)+                  unboundedConfig+                  (bvsignExtendTerm (Proxy @10))+                  "bvsignExtend"+                  SBV.signExtend,+              testCase "Concat" $ do+                testBinaryOpLowering @(WordN 4) @(WordN 5) @(WordN 9)+                  unboundedConfig+                  bvConcatTerm+                  "bvconcat"+                  (SBV.#),+              testCase "AndBits" $ do+                testBinaryOpLowering @(WordN 5) @(WordN 5) unboundedConfig andBitsTerm "(.&.)" (.&.),+              testCase "OrBits" $ do+                testBinaryOpLowering @(WordN 5) @(WordN 5) unboundedConfig orBitsTerm "(.|.)" (.|.),+              testCase "XorBits" $ do+                testBinaryOpLowering @(WordN 5) @(WordN 5) unboundedConfig xorBitsTerm "xor" xor,+              testCase "ComplementBits" $ do+                testUnaryOpLowering @(WordN 5) unboundedConfig complementBitsTerm "complement" complement,+              testCase "ShiftLeft" $ do+                testBinaryOpLowering @(WordN 5) unboundedConfig shiftLeftTerm "shiftLeft" SBV.sShiftLeft,+              testCase "ShiftRight" $ do+                testBinaryOpLowering @(WordN 5) unboundedConfig shiftRightTerm "shiftRight" SBV.sShiftRight,+              testCase "RotateLeft" $ do+                testBinaryOpLowering @(WordN 5) unboundedConfig rotateLeftTerm "rotateLeft" SBV.sRotateLeft,+              testCase "RotateRight" $ do+                testBinaryOpLowering @(WordN 5) unboundedConfig rotateRightTerm "rotateRight" SBV.sRotateRight,+              testCase "Div" $ do+                testBinaryOpLowering @(WordN 5) @(WordN 5) @(WordN 5) unboundedConfig divIntegralTerm "div" SBV.sDiv,+              testCase "Mod" $ do+                testBinaryOpLowering @(WordN 5) @(WordN 5) @(WordN 5) unboundedConfig modIntegralTerm "mod" SBV.sMod,+              testCase "Quot" $ do+                testBinaryOpLowering @(WordN 5) @(WordN 5) @(WordN 5) unboundedConfig quotIntegralTerm "quot" SBV.sQuot,+              testCase "Rem" $ do+                testBinaryOpLowering @(WordN 5) @(WordN 5) @(WordN 5) unboundedConfig remIntegralTerm "rem" SBV.sRem,+              testCase "BitCast" $ do+                testUnaryOpLowering @(WordN 5) @(IntN 5) unboundedConfig bitCastTerm "bitCast" SBV.sFromIntegral+                testUnaryOpLowering @(WordN 1) @Bool unboundedConfig bitCastTerm "bitCast" (`SBV.sTestBit` 0)+                testUnaryOpLowering @Bool @(WordN 1) unboundedConfig bitCastTerm "bitCast" (\x -> SBV.ite x 1 0)+            ],+          testGroup+            "FP"+            [ testCase "Model parse (float)" $ modelParseTestBody (10.012 :: FP32),+              testModelParse @FPRoundingMode,+              testCase "Eqv" $+                testBinaryOpLowering @FP32 @FP32 @Bool unboundedConfig eqTerm "eqv" (SBV..==),+              testCase "ITE" $ do+                let precond _ l r =+                      pevalAndTerm+                        ( pevalNotTerm $+                            pevalFPTraitTerm FPIsNaN (l :: Term FP32)+                        )+                        ( pevalNotTerm $+                            pevalFPTraitTerm FPIsNaN (r :: Term FP32)+                        )+                testTernaryOpLowering @Bool @FP32 @FP32 @FP32+                  unboundedConfig+                  precond+                  iteTerm+                  "ite"+                  SBV.ite,+              testGroup "FPTrait" $ do+                (name, trait, op) <-+                  [ ("isNaN", FPIsNaN, SBV.fpIsNaN),+                    ("isPositive", FPIsPositive, SBV.fpIsPositive),+                    ("isNegative", FPIsNegative, SBV.fpIsNegative),+                    ( "isPositiveInfinite",+                      FPIsPositiveInfinite,+                      \x -> SBV.fpIsPositive x SBV..&& SBV.fpIsInfinite x+                    ),+                    ( "isNegativeInfinite",+                      FPIsNegativeInfinite,+                      \x -> SBV.fpIsNegative x SBV..&& SBV.fpIsInfinite x+                    ),+                    ("isInfinite", FPIsInfinite, SBV.fpIsInfinite),+                    ("isPositiveZero", FPIsPositiveZero, SBV.fpIsPositiveZero),+                    ("isNegativeZero", FPIsNegativeZero, SBV.fpIsNegativeZero),+                    ("isZero", FPIsZero, SBV.fpIsZero),+                    ("isNormal", FPIsNormal, SBV.fpIsNormal),+                    ("isSubnormal", FPIsSubnormal, SBV.fpIsSubnormal),+                    ("isPoint", FPIsPoint, SBV.fpIsPoint)+                  ]+                return $ testCase name $ do+                  testUnaryOpLowering @FP32 @Bool+                    unboundedConfig+                    (fpTraitTerm trait)+                    "isNaN"+                    op,+              testCase "BitCastOr" $ do+                testBinaryOpLowering @(WordN 8) @(FP 3 5)+                  unboundedConfig+                  bitCastOrTerm+                  "bitCastOr"+                  ( \d v ->+                      SBV.ite+                        (SBV.fpIsNaN v)+                        d+                        (SBV.sFloatingPointAsSWord v)+                  )+                testBinaryOpLowering @(IntN 8) @(FP 3 5)+                  unboundedConfig+                  bitCastOrTerm+                  "bitCastOr"+                  ( \d v ->+                      SBV.ite+                        (SBV.fpIsNaN v)+                        d+                        (SBV.sFromIntegral $ SBV.sFloatingPointAsSWord v)+                  ),+              testCase "BitCast" $ do+                testUnaryOpLowering' @(WordN 8) @(FP 3 5)+                  ( Just $ \x ->+                      SBV.sNot $+                        SBV.fpIsNaN+                          ( SBV.sWordAsSFloatingPoint x ::+                              SBV.SFloatingPoint 3 5+                          )+                  )+                  unboundedConfig+                  bitCastTerm+                  "bitCast"+                  SBV.sWordAsSFloatingPoint+                testUnaryOpLowering' @(IntN 8) @(FP 3 5)+                  ( Just $ \x ->+                      SBV.sNot $+                        SBV.fpIsNaN+                          ( SBV.sWordAsSFloatingPoint . SBV.sFromIntegral $ x ::+                              SBV.SFloatingPoint 3 5+                          )+                  )+                  unboundedConfig+                  bitCastTerm+                  "bitCast"+                  (SBV.sWordAsSFloatingPoint . SBV.sFromIntegral)+            ],+          testGroup+            "AlgReal"+            [ testModelParse @AlgReal,+              testCase "Eqv" $+                testBinaryOpLowering @AlgReal @AlgReal @Bool+                  unboundedConfig+                  eqTerm+                  "eqv"+                  (SBV..==),+              testCase "ITE" $ do+                let truePrecond _ _ _ = conTerm True+                testTernaryOpLowering @Bool @AlgReal @AlgReal @AlgReal+                  unboundedConfig+                  truePrecond+                  iteTerm+                  "ite"+                  SBV.ite,+              testCase "Add" $ do+                testBinaryOpLowering @AlgReal @AlgReal @AlgReal unboundedConfig addNumTerm "(+)" (+)+                testBinaryOpLowering @AlgReal @AlgReal @AlgReal+                  unboundedConfig+                  addNumTerm+                  "(+)"+                  (\x y -> (x + 1) * (y + 1) - x * y - 1),+              testCase "Uminus" $ do+                testUnaryOpLowering @AlgReal @AlgReal unboundedConfig negNumTerm "negate" negate+                testUnaryOpLowering @AlgReal @AlgReal+                  unboundedConfig+                  negNumTerm+                  "negate"+                  (\x -> (x + 1) * (x + 1) - 3 * x - x * x - 1),+              testCase "Abs" $+                testUnaryOpLowering @AlgReal @AlgReal unboundedConfig absNumTerm "abs" abs,+              testCase "Signum" $+                testUnaryOpLowering @AlgReal @AlgReal unboundedConfig signumNumTerm "signum" signum,+              testCase "Times" $ do+                testBinaryOpLowering @AlgReal @AlgReal @AlgReal unboundedConfig mulNumTerm "(*)" (*)+                testBinaryOpLowering @AlgReal @AlgReal @AlgReal+                  unboundedConfig+                  mulNumTerm+                  "(*)"+                  (\x y -> (x + 1) * (y + 1) - x - y - 1),+              testCase "Lt" $ do+                testBinaryOpLowering @Integer @Integer @Bool unboundedConfig ltOrdTerm "(<)" (SBV..<)+                testBinaryOpLowering @Integer @Integer @Bool+                  unboundedConfig+                  ltOrdTerm+                  "(<)"+                  (\x y -> x * 2 - x SBV..< y * 2 - y),+              testCase "Le" $ do+                testBinaryOpLowering @Integer @Integer @Bool unboundedConfig leOrdTerm "(<=)" (SBV..<=)+                testBinaryOpLowering @Integer @Integer @Bool+                  unboundedConfig+                  leOrdTerm+                  "(<=)"+                  (\x y -> x * 2 - x SBV..<= y * 2 - y),+              testCase "fdiv" $ do+                testBinaryOpLowering @AlgReal @AlgReal @AlgReal+                  unboundedConfig+                  fdivTerm+                  "fdiv"+                  (/),+              testCase "recip" $ do+                testUnaryOpLowering @AlgReal @AlgReal+                  unboundedConfig+                  recipTerm+                  "recip"+                  recip,+              testGroup "Floating unary" $ do+                (name, f, op) <-+                  -- Those unsupported by z3 are commented out+                  [ -- ("exp", exp, FloatingExp),+                    -- ("log", log, FloatingLog),+                    -- ("sqrt", sqrt, FloatingSqrt),+                    ("sin", sin, FloatingSin),+                    ("cos", cos, FloatingCos),+                    ("tan", tan, FloatingTan),+                    ("asin", asin, FloatingAsin),+                    ("acos", acos, FloatingAcos),+                    ("atan", atan, FloatingAtan),+                    ("sinh", sinh, FloatingSinh),+                    ("cosh", cosh, FloatingCosh),+                    ("tanh", tanh, FloatingTanh)+                  ]+                return $+                  testCase name $+                    testUnaryOpLowering @AlgReal @AlgReal+                      unboundedConfig+                      (floatingUnaryTerm op)+                      name+                      f {-,+                        testCase "**" $ do+                          testBinaryOpLowering @AlgReal @AlgReal @AlgReal+                            unboundedConfig+                            powerTerm+                            "(**)"+                            (**)-}+            ],+          testCase "TabularFun" $ do+            let f = "f" :: SymInteger =~> SymInteger =~> SymInteger+            let a = "a" :: SymInteger+            let b = "b" :: SymInteger+            let c = "c" :: SymInteger+            let d = "d" :: SymInteger+            Right m <-+              solve unboundedConfig $+                (f # a # b .== a + b)+                  .&& (f # a # c .== a + c)+                  .&& (f # a # d .== a + d)+                  .&& (f # b # d .== b + d)+                  .&& (a .== 10 .&& b .== 20 .&& c .== 30 .&& d .== 40)+            AsKey (evalSym False m (f # a # b .== a + b)) @?= con True+            AsKey (evalSym False m (f # a # c .== a + c)) @?= con True+            AsKey (evalSym False m (f # a # d .== a + d)) @?= con True+            AsKey (evalSym False m (f # b # d .== b + d)) @?= con True,+          testCase "GeneralFun" $ do+            let f = "f" :: SymInteger -~> SymInteger -~> SymInteger+            let a = "a" :: SymInteger+            let b = "b" :: SymInteger+            let c = "c" :: SymInteger+            let d = "d" :: SymInteger+            r <-+              solve unboundedConfig $+                (f # a # b .== a + b)+                  .&& (f # a # c .== a + c)+                  .&& (f # a # d .== a + d)+                  .&& (f # b # d .== b + d)+                  .&& (a .== 10 .&& b .== 20 .&& c .== 30 .&& d .== 40)+            case r of+              Left err -> fail $ show err+              Right m -> do+                AsKey (evalSym False m (f # a # b .== a + b)) @?= con True+                AsKey (evalSym False m (f # a # c .== a + c)) @?= con True+                AsKey (evalSym False m (f # a # d .== a + d)) @?= con True+                AsKey (evalSym False m (f # b # d .== b + d)) @?= con True,+          sbvVersionCheck $+            testGroup+              "Quantifiers"+              [ testCase "Forall" $ do+                  let asym :: TypedConstantSymbol Integer = "a"+                  let a :: Term Integer = ssymTerm "a"+                  let xsym :: TypedConstantSymbol Integer = "x"+                  let x :: Term Integer = ssymTerm "x"+                  let xterm =+                        forallTerm+                          xsym+                          (eqTerm (addNumTerm a x) (addNumTerm x $ conTerm 10))+                  let yterm =+                        forallTerm+                          asym+                          (eqTerm (addNumTerm a x) (addNumTerm a $ conTerm 20))+                  SBV.runSMTWith SBV.z3 $ do+                    (m, v, _) <- lowerSinglePrim (andTerm xterm yterm)+                    let sbva =+                          M.lookup (SomeTerm a) (biMapToSBV m)+                            >>= \f -> fromDynamic (f emptyQuantifiedStack)+                    let sbvx =+                          M.lookup (SomeTerm x) (biMapToSBV m)+                            >>= \f -> fromDynamic (f emptyQuantifiedStack)+                    case (sbva, sbvx) of+                      (Just (sbvav :: SBV.SInteger), Just (sbvxv :: SBV.SInteger)) ->+                        SBV.query $ do+                          SBV.constrain $ v emptyQuantifiedStack+                          satres <- SBV.checkSat+                          case satres of+                            SBV.Sat -> do+                              av <- SBV.getValue sbvav+                              liftIO $ av @?= 10+                              xv <- SBV.getValue sbvxv+                              liftIO $ xv @?= 20+                            _ -> liftIO $ assertFailure "Unsat"+                      _ -> liftIO $ assertFailure "Failed to find a",+                testCase "Forall failed" $ do+                  let xsym :: TypedConstantSymbol Integer = "x"+                  let x :: Term Integer = ssymTerm "x"+                  let xterm = forallTerm xsym (eqTerm x (conTerm 10))+                  SBV.runSMTWith SBV.z3 $ do+                    (_, v, _) <- lowerSinglePrim xterm+                    SBV.query $ do+                      SBV.constrain $ v emptyQuantifiedStack+                      satres <- SBV.checkSat+                      case satres of+                        SBV.Unsat -> return ()+                        _ -> liftIO $ assertFailure "Should be unsat",+                testCase "Forall-Exists" $ do+                  let asym :: TypedConstantSymbol Integer = "a"+                  let a :: Term Integer = ssymTerm "a"+                  let xsym :: TypedConstantSymbol Integer = "x"+                  let x :: Term Integer = ssymTerm "x"+                  let xterm =+                        forallTerm xsym $ existsTerm asym (ltOrdTerm x a)+                  SBV.runSMTWith SBV.z3 $ do+                    (_, v, _) <- lowerSinglePrim xterm+                    SBV.query $ do+                      SBV.constrain $ v emptyQuantifiedStack+                      satres <- SBV.checkSat+                      case satres of+                        SBV.Sat -> return ()+                        _ -> liftIO $ assertFailure "Unsat",+                testCase "Exists-Forall" $ do+                  let asym :: TypedConstantSymbol Integer = "a"+                  let a :: Term Integer = ssymTerm "a"+                  let xsym :: TypedConstantSymbol Integer = "x"+                  let x :: Term Integer = ssymTerm "x"+                  let xterm =+                        existsTerm asym $ forallTerm xsym (ltOrdTerm x a)+                  SBV.runSMTWith SBV.z3 $ do+                    (_, v, _) <- lowerSinglePrim xterm+                    SBV.query $ do+                      SBV.constrain $ v emptyQuantifiedStack+                      satres <- SBV.checkSat+                      case satres of+                        SBV.Unsat -> return ()+                        _ -> liftIO $ assertFailure "should be unsat"+              ]+        ]++#if MIN_VERSION_sbv(10,1,0)+sbvVersionCheck :: Test -> Test+sbvVersionCheck = id+#else+sbvVersionCheck :: Test -> Test+sbvVersionCheck _ = testGroup "Quantifiers" []+#endif
− test/Grisette/Backend/SBV/Data/SMT/CEGISTests.hs 
@@ -1,415 +0,0 @@-{-# LANGUAGE BinaryLiterals #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeOperators #-}--module Grisette.Backend.SBV.Data.SMT.CEGISTests (cegisTests) where--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.Backend.SBV (GrisetteSMTConfig, precise, z3)-import Grisette.Core.Control.Exception-  ( VerificationConditions,-  )-import Grisette.Core.Control.Monad.UnionM (UnionM)-import Grisette.Core.Data.Class.BitVector-  ( SizedBV (sizedBVConcat, sizedBVSelect, sizedBVSext, sizedBVZext),-  )-import Grisette.Core.Data.Class.CEGISSolver-  ( CEGISResult (CEGISSuccess),-    cegis,-    cegisExceptVC,-    cegisForAllExceptVC,-    cegisMultiInputs,-    cegisPostCond,-  )-import Grisette.Core.Data.Class.Error-  ( symAssert,-    symAssume,-  )-import Grisette.Core.Data.Class.EvaluateSym (EvaluateSym (evaluateSym))-import Grisette.Core.Data.Class.ExtractSymbolics-  ( ExtractSymbolics,-  )-import Grisette.Core.Data.Class.Function (Apply (apply), Function ((#)))-import Grisette.Core.Data.Class.ITEOp (ITEOp (symIte))-import Grisette.Core.Data.Class.LogicalOp-  ( LogicalOp (symNot, symXor, (.&&), (.||)),-  )-import Grisette.Core.Data.Class.SEq (SEq ((.==)))-import Grisette.Core.Data.Class.SOrd (SOrd ((.<), (.>=)))-import Grisette.Core.Data.Class.SimpleMergeable (mrgIf)-import Grisette.Core.Data.Class.Solvable (Solvable (con))-import Grisette.Core.Data.Class.Solver (solve)-import Grisette.IR.SymPrim.Data.SymPrim-  ( SymBool,-    SymIntN,-    SymInteger,-    type (-~>),-    type (=~>),-  )-import Test.Framework (Test, testGroup)-import Test.Framework.Providers.HUnit (testCase)-import Test.HUnit (Assertion, assertFailure, (@=?))--testCegis ::-  (HasCallStack, ExtractSymbolics a, EvaluateSym a, Show a, SEq a) =>-  GrisetteSMTConfig i ->-  Bool ->-  a ->-  (a -> [SymBool]) ->-  Assertion-testCegis config shouldSuccess inputs bs = do-  cegisExceptVCResult <--    cegisExceptVC config (inputs, "internal" :: SymInteger) return $-      \(cexInputs, internal) -> buildFormula internal (bs cexInputs)-  case cegisExceptVCResult of-    (_, CEGISSuccess m) -> do-      shouldSuccess @=? True-      verify "cegisExceptVC" m (bs inputs)-    _ -> shouldSuccess @=? False-  cegisForAllExceptVCResult <--    cegisForAllExceptVC config (inputs, "internal" :: SymInteger) return $-      buildFormula "internal" (bs inputs)-  case cegisForAllExceptVCResult of-    (_, CEGISSuccess m) -> do-      shouldSuccess @=? True-      verify "cegisForAllExceptVC" m (bs inputs)-    _ -> shouldSuccess @=? False-  where-    verify _ _ [] = return ()-    verify funName m (v : vs) = do-      y <- solve config (evaluateSym False m $ symNot v)-      case y of-        Left _ -> verify funName m vs-        Right _ ->-          assertFailure $-            funName-              ++ ": Failed to verify "-              ++ show v-              ++ " with the model "-              ++ show m-    buildFormula internal l = do-      symAssume (internal .>= 0)-      go l 0-      where-        go ::-          [SymBool] -> SymInteger -> ExceptT VerificationConditions UnionM ()-        go [] _ = return ()-        go (x : xs) i =-          mrgIf-            (internal .>= i .&& internal .< (i + 1))-            (symAssert x)-            (go xs (i + 1))--cegisTests :: Test-cegisTests =-  let unboundedConfig = precise SBV.z3-   in testGroup-        "CEGIS"-        [ testGroup-            "Regression"-            [ testCase "Empty symbolic inputs makes cegis work like solve" $ do-                (_, CEGISSuccess m1) <--                  cegisMultiInputs-                    (precise z3)-                    [1 :: Integer, 2]-                    (\idx -> cegisPostCond $ fromString $ "a" ++ show idx)-                Right m2 <- solve (precise z3) ("a1" .&& "a2")-                m1 @=? m2,-              testCase "Lowering of TabularFun" $ do-                let s1 = "s1" :: SymInteger =~> SymInteger-                let s2 = "s2" :: SymInteger =~> SymInteger-                (_, CEGISSuccess m1) <--                  cegis unboundedConfig ("cond" :: SymBool) $-                    \cond ->-                      cegisPostCond $-                        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-                s1e # 1 @=? 10-                s1e # 3 @=? 100-                s2e # 2 @=? 10-                s2e # 4 @=? 100,-              testCase "Lowering of GeneralFun" $ do-                let s1 = "s1" :: SymInteger -~> SymInteger-                let s2 = "s2" :: SymInteger -~> SymInteger-                (_, CEGISSuccess m1) <--                  cegis unboundedConfig ("cond" :: SymBool) $-                    \cond ->-                      cegisPostCond $-                        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-                s1e # 1 @=? 10-                s1e # 3 @=? 100-                s2e # 2 @=? 10-                s2e # 4 @=? 100-            ],-          testGroup-            "Boolean"-            [ testCase "Basic" $ do-                testCegis unboundedConfig True () $ const ["a", "b", "c"]-                testCegis unboundedConfig False () $ const ["a", symNot "a"],-              testCase "And" $ do-                testCegis unboundedConfig True () $-                  const ["a" .&& "b", "b" .&& symNot "c", "a", "b", symNot "c"]-                testCegis unboundedConfig False () $-                  const ["a" .&& "b", "b" .&& symNot "c", "a", "b", "c"]-                testCegis unboundedConfig True ("a" :: SymBool) $-                  \a -> [symNot $ a .&& "b", symNot "b"]-                testCegis unboundedConfig False ("a" :: SymBool) $-                  \a -> [symNot $ a .&& "b", "b"],-              testCase "Or" $ do-                testCegis unboundedConfig True () $-                  const ["a" .|| "b", "b" .|| symNot "c", "a", "b", symNot "c"]-                testCegis unboundedConfig True () $-                  const ["a" .|| "b", "b" .|| symNot "c", "a", "b", "c"]-                testCegis unboundedConfig True ("a" :: SymBool) $-                  \a -> [a .|| "b", "b"]-                testCegis unboundedConfig False ("a" :: SymBool) $-                  \a -> [a .|| "b", symNot "b"],-              testCase "And / Or should be consistent" $ do-                testCegis unboundedConfig True () $-                  const ["a" .&& "b", "a" .|| "b"]-                testCegis unboundedConfig True () $-                  const [symNot "a" .&& "b", "a" .|| "b"]-                testCegis unboundedConfig False () $-                  const ["a" .&& "b", symNot $ "a" .|| "b"]-                testCegis unboundedConfig True () $-                  const [symNot $ "a" .&& "b", symNot $ "a" .|| "b"],-              testCase "Eqv" $ do-                testCegis unboundedConfig True () $-                  const [("a" :: SymBool) .== "b", "a", "b"]-                testCegis unboundedConfig True () $-                  const [("a" :: SymBool) .== "b", symNot "a", symNot "b"]-                testCegis unboundedConfig False () $-                  const [("a" :: SymBool) .== "b", symNot "a", "b"]-                testCegis unboundedConfig False () $-                  const [("a" :: SymBool) .== "b", symNot "a", "b"]-                testCegis unboundedConfig True () $-                  const [("a" :: SymBool) .== "b", symNot "a" `symXor` "b"]-                testCegis unboundedConfig False () $-                  const [("a" :: SymBool) .== "b", "a" `symXor` "b"],-              testCase "symIte" $ do-                testCegis unboundedConfig True ("c" :: SymBool) $-                  \c -> [symIte "a" "b" c, "a", "b"]-                testCegis unboundedConfig False ("c" :: SymBool) $-                  \c -> [symIte "a" "b" c, symNot "a"]-                testCegis unboundedConfig True ("b" :: SymBool) $-                  \b -> [symIte "a" b "c", symNot "a", "c"]-                testCegis unboundedConfig False ("b" :: SymBool) $-                  \b -> [symIte "a" b "c", "a"]-                testCegis unboundedConfig True () $-                  const [symIte "a" "b" "c", "a", "b", "c"]-                testCegis unboundedConfig True () $-                  const [symIte "a" "b" "c", "a", "b", symNot "c"]-                testCegis unboundedConfig True () $-                  const [symIte "a" "b" "c", symNot "a", "b", "c"]-                testCegis unboundedConfig True () $-                  const [symIte "a" "b" "c", symNot "a", symNot "b", "c"]-                testCegis unboundedConfig False () $-                  const [symIte "a" "b" "c", "a", symNot "b", "c"]-                testCegis unboundedConfig False () $-                  const [symIte "a" "b" "c", "a", symNot "b", symNot "c"]-                testCegis unboundedConfig False () $-                  const [symIte "a" "b" "c", symNot "a", "b", symNot "c"]-                testCegis unboundedConfig False () $-                  const [symIte "a" "b" "c", symNot "a", symNot "b", symNot "c"]-            ],-          let a = "a" :: SymIntN 5-              b = "b" :: SymIntN 5-              c = "c" :: SymIntN 5-              d = "c" :: SymIntN 10-           in testGroup-                "Different sized BV"-                [ testGroup-                    "Select"-                    [ testCase "sizedBVSelect" $ do-                        testCegis unboundedConfig True () $-                          const-                            [ sizedBVSelect (Proxy @2) (Proxy @2) a-                                .== (con 1 :: SymIntN 2),-                              a .== con 0b10101-                            ]-                        testCegis unboundedConfig False () $-                          const-                            [ sizedBVSelect (Proxy @2) (Proxy @2) a-                                .== (con 1 :: SymIntN 2),-                              a .== con 0b10001-                            ],-                      testCase "sizedBVSelect when lowered twice" $ do-                        testCegis unboundedConfig True a $-                          \ca ->-                            [ sizedBVSelect-                                (Proxy @2)-                                (Proxy @2)-                                (sizedBVConcat ca b)-                                .== (con 1 :: SymIntN 2)-                            ]-                        testCegis unboundedConfig True b $-                          \cb ->-                            [ sizedBVSelect-                                (Proxy @7)-                                (Proxy @2)-                                (sizedBVConcat a cb)-                                .== (con 1 :: SymIntN 2)-                            ]-                    ],-                  testGroup-                    "Concat"-                    [ testCase "sizedBVConcat" $ do-                        testCegis unboundedConfig True () $-                          const-                            [ sizedBVConcat a b .== d,-                              a .== con 1,-                              b .== con 1,-                              d .== con 0b100001-                            ]-                        testCegis unboundedConfig False () $-                          const-                            [ sizedBVConcat a b .== d,-                              a .== con 1,-                              b .== con 1,-                              d .== con 0b100010-                            ],-                      testCase "sizedBVConcat when lowered twice" $ do-                        testCegis unboundedConfig True (a, c) $-                          \(ca, cc) ->-                            [ sizedBVConcat-                                cc-                                ( sizedBVSelect-                                    (Proxy @2)-                                    (Proxy @2)-                                    (sizedBVConcat ca b) ::-                                    SymIntN 2-                                )-                                .== sizedBVConcat cc (con 1 :: SymIntN 2)-                            ]-                        testCegis unboundedConfig True (b, c) $-                          \(cb, cc) ->-                            [ sizedBVConcat-                                cc-                                ( sizedBVSelect-                                    (Proxy @7)-                                    (Proxy @2)-                                    (sizedBVConcat a cb) ::-                                    SymIntN 2-                                )-                                .== sizedBVConcat cc (con 1 :: SymIntN 2)-                            ]-                    ],-                  testGroup-                    "Zext"-                    [ testCase "sizedBVZext" $ do-                        testCegis unboundedConfig True () $-                          const-                            [ sizedBVZext (Proxy @10) a .== d,-                              a .== con 1,-                              d .== (con 1 :: SymIntN 10)-                            ]-                        testCegis unboundedConfig True () $-                          const-                            [ sizedBVZext (Proxy @10) a .== d,-                              a .== con 0b11111,-                              d .== (con 0b11111 :: SymIntN 10)-                            ]-                        testCegis unboundedConfig False () $-                          const-                            [ sizedBVZext (Proxy @10) a .== d,-                              d .== (con 0b111111 :: SymIntN 10)-                            ]-                        testCegis unboundedConfig False () $-                          const-                            [ sizedBVZext (Proxy @10) a .== d,-                              d .== (con 0b1111111111 :: SymIntN 10)-                            ],-                      testCase "sizedBVZext when lowered twice" $ do-                        testCegis unboundedConfig True a $-                          \ca ->-                            [ sizedBVZext-                                (Proxy @10)-                                ( sizedBVSelect-                                    (Proxy @2)-                                    (Proxy @2)-                                    (sizedBVConcat ca b) ::-                                    SymIntN 2-                                )-                                .== (con 1 :: SymIntN 10)-                            ]-                        testCegis unboundedConfig True b $-                          \cb ->-                            [ sizedBVZext-                                (Proxy @10)-                                ( sizedBVSelect-                                    (Proxy @7)-                                    (Proxy @2)-                                    (sizedBVConcat a cb) ::-                                    SymIntN 2-                                )-                                .== (con 1 :: SymIntN 10)-                            ]-                    ],-                  testGroup-                    "Sext"-                    [ testCase "sizedBVSext" $ do-                        testCegis unboundedConfig True () $-                          const-                            [ sizedBVSext (Proxy @10) a .== d,-                              a .== con 1,-                              d .== (con 1 :: SymIntN 10)-                            ]-                        testCegis unboundedConfig True () $-                          const-                            [ sizedBVSext (Proxy @10) a .== d,-                              a .== con 0b11111,-                              d .== (con 0b1111111111 :: SymIntN 10)-                            ]-                        testCegis unboundedConfig False () $-                          const-                            [ sizedBVSext (Proxy @10) a .== d,-                              d .== (con 0b111111 :: SymIntN 10)-                            ]-                        testCegis unboundedConfig False () $-                          const-                            [ sizedBVSext (Proxy @10) a .== d,-                              d .== (con 0b11111 :: SymIntN 10)-                            ],-                      testCase "sizedBVSext when lowered twice" $ do-                        testCegis unboundedConfig True a $ \ca ->-                          [ sizedBVSext-                              (Proxy @10)-                              ( sizedBVSelect-                                  (Proxy @2)-                                  (Proxy @2)-                                  (sizedBVConcat ca b) ::-                                  SymIntN 2-                              )-                              .== (con 1 :: SymIntN 10)-                          ]-                        testCegis unboundedConfig True b $-                          \cb ->-                            [ sizedBVSext-                                (Proxy @10)-                                ( sizedBVSelect-                                    (Proxy @7)-                                    (Proxy @2)-                                    (sizedBVConcat a cb) ::-                                    SymIntN 2-                                )-                                .== (con 1 :: SymIntN 10)-                            ]-                    ]-                ]-        ]
− test/Grisette/Backend/SBV/Data/SMT/LoweringTests.hs 
@@ -1,800 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeOperators #-}--module Grisette.Backend.SBV.Data.SMT.LoweringTests (loweringTests) where--import Control.Monad.Trans (MonadTrans (lift))-import Data.Bits-  ( Bits (complement, xor, (.&.), (.|.)),-  )-import Data.Dynamic (Typeable, fromDynamic)-import qualified Data.HashMap.Strict as M-import Data.Proxy (Proxy (Proxy))-import qualified Data.SBV as SBV-import qualified Data.SBV.Control as SBV-import qualified Data.Text as T-import GHC.Stack (HasCallStack)-import Grisette.Backend.SBV.Data.SMT.Lowering (lowerSinglePrim)-import Grisette.Backend.SBV.Data.SMT.Solving-  ( GrisetteSMTConfig (sbvConfig),-    TermTy,-    approx,-    precise,-  )-import Grisette.Backend.SBV.Data.SMT.SymBiMap-  ( SymBiMap (biMapToSBV),-  )-import Grisette.Core.Data.BV (IntN, WordN)-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors-  ( absNumTerm,-    addNumTerm,-    andBitsTerm,-    andTerm,-    bvconcatTerm,-    bvselectTerm,-    bvsignExtendTerm,-    bvzeroExtendTerm,-    complementBitsTerm,-    divBoundedIntegralTerm,-    divIntegralTerm,-    eqvTerm,-    iteTerm,-    leNumTerm,-    ltNumTerm,-    modBoundedIntegralTerm,-    modIntegralTerm,-    notTerm,-    orBitsTerm,-    orTerm,-    quotBoundedIntegralTerm,-    quotIntegralTerm,-    remBoundedIntegralTerm,-    remIntegralTerm,-    rotateLeftTerm,-    rotateRightTerm,-    shiftLeftTerm,-    shiftRightTerm,-    signumNumTerm,-    ssymTerm,-    timesNumTerm,-    toSignedTerm,-    toUnsignedTerm,-    uminusNumTerm,-    xorBitsTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.SomeTerm-  ( SomeTerm (SomeTerm),-  )-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term-  ( SupportedPrim,-    Term,-  )-import Test.Framework (Test, testGroup)-import Test.Framework.Providers.HUnit (testCase)-import Test.HUnit (Assertion, assertFailure)--testUnaryOpLowering ::-  forall a b as n.-  ( HasCallStack,-    SupportedPrim a,-    SBV.EqSymbolic (TermTy n b),-    Typeable (TermTy n a),-    SBV.SymVal as,-    TermTy n a ~ SBV.SBV as,-    Show as-  ) =>-  GrisetteSMTConfig n ->-  (Term a -> Term b) ->-  String ->-  (TermTy n a -> TermTy n b) ->-  Assertion-testUnaryOpLowering config f name sbvfun = do-  let a :: Term a = ssymTerm "a"-  let fa :: Term b = f a-  SBV.runSMTWith (sbvConfig config) $ do-    (m, lt) <- lowerSinglePrim config fa-    let sbva :: Maybe (TermTy n a) = M.lookup (SomeTerm a) (biMapToSBV m) >>= fromDynamic-    case sbva of-      Nothing -> lift $ assertFailure "Failed to extract the term"-      Just sbvav -> SBV.query $ do-        SBV.constrain $ lt SBV..== sbvfun sbvav-        satres <- SBV.checkSat-        case satres of-          SBV.Sat -> return ()-          _ -> lift $ assertFailure $ "Lowering for " ++ name ++ " generated unsolvable formula"-  SBV.runSMTWith (sbvConfig config) $ do-    (m, lt) <- lowerSinglePrim config fa-    let sbvv :: Maybe (TermTy n a) = M.lookup (SomeTerm a) (biMapToSBV m) >>= fromDynamic-    case sbvv of-      Nothing -> lift $ assertFailure "Failed to extract the term"-      Just sbvvv -> SBV.query $ do-        SBV.constrain $ lt SBV../= sbvfun sbvvv-        r <- SBV.checkSat-        case r of-          SBV.Sat -> do-            counterExample <- SBV.getValue sbvvv-            lift $ assertFailure $ "Translation counter example found: " ++ show counterExample-          SBV.Unsat -> return ()-          _ -> lift $ assertFailure $ "Lowering for " ++ name ++ " generated unknown formula"---- testUnaryOpLowering' ::---   forall a b as n tag.---   ( HasCallStack,---     UnaryOp tag a b,---     SBV.EqSymbolic (TermTy n b),---     Typeable (TermTy n a),---     SBV.SymVal as,---     TermTy n a ~ SBV.SBV as,---     Show as---   ) =>---   GrisetteSMTConfig n ->---   tag ->---   (TermTy n a -> TermTy n b) ->---   Assertion--- testUnaryOpLowering' config t = testUnaryOpLowering @a @b @as config (constructUnary t) (show t)--testBinaryOpLowering ::-  forall a b c as bs n.-  ( HasCallStack,-    SupportedPrim a,-    SupportedPrim b,-    SBV.EqSymbolic (TermTy n c),-    Typeable (TermTy n a),-    Typeable (TermTy n b),-    SBV.SymVal as,-    SBV.SymVal bs,-    Show as,-    Show bs,-    TermTy n a ~ SBV.SBV as,-    TermTy n b ~ SBV.SBV bs-  ) =>-  GrisetteSMTConfig n ->-  (Term a -> Term b -> Term c) ->-  String ->-  (TermTy n a -> TermTy n b -> TermTy n c) ->-  Assertion-testBinaryOpLowering config f name sbvfun = do-  let a :: Term a = ssymTerm "a"-  let b :: Term b = ssymTerm "b"-  let fab :: Term c = f a b-  SBV.runSMTWith (sbvConfig config) $ do-    (m, lt) <- lowerSinglePrim config fab-    let sbva :: Maybe (TermTy n a) = M.lookup (SomeTerm a) (biMapToSBV m) >>= fromDynamic-    let sbvb :: Maybe (TermTy n b) = M.lookup (SomeTerm b) (biMapToSBV m) >>= fromDynamic-    case (sbva, sbvb) of-      (Just sbvav, Just sbvbv) -> SBV.query $ do-        SBV.constrain $ lt SBV..== sbvfun sbvav sbvbv-        satres <- SBV.checkSat-        case satres of-          SBV.Sat -> return ()-          _ -> lift $ assertFailure $ "Lowering for " ++ name ++ " generated unsolvable formula"-      _ -> lift $ assertFailure "Failed to extract the term"-  SBV.runSMTWith (sbvConfig config) $ do-    (m, lt) <- lowerSinglePrim config fab-    let sbva :: Maybe (TermTy n a) = M.lookup (SomeTerm a) (biMapToSBV m) >>= fromDynamic-    let sbvb :: Maybe (TermTy n b) = M.lookup (SomeTerm b) (biMapToSBV m) >>= fromDynamic-    case (sbva, sbvb) of-      (Just sbvav, Just sbvbv) -> SBV.query $ do-        SBV.constrain $ lt SBV../= sbvfun sbvav sbvbv-        r <- SBV.checkSat-        case r of-          SBV.Sat -> do-            counterExampleA <- SBV.getValue sbvav-            counterExampleB <- SBV.getValue sbvbv-            lift $ assertFailure $ "Translation counter example found: " ++ show (counterExampleA, counterExampleB)-          SBV.Unsat -> return ()-          _ -> lift $ assertFailure $ "Lowering for " ++ name ++ " generated unknown formula"-      _ -> lift $ assertFailure "Failed to extract the term"---- testBinaryOpLowering' ::---   forall a b c as bs n tag.---   ( HasCallStack,---     BinaryOp tag a b c,---     SBV.EqSymbolic (TermTy n c),---     Typeable (TermTy n a),---     Typeable (TermTy n b),---     SBV.SymVal as,---     SBV.SymVal bs,---     Show as,---     Show bs,---     TermTy n a ~ SBV.SBV as,---     TermTy n b ~ SBV.SBV bs---   ) =>---   GrisetteSMTConfig n ->---   tag ->---   (TermTy n a -> TermTy n b -> TermTy n c) ->---   Assertion--- testBinaryOpLowering' config t = testBinaryOpLowering @a @b @c @as @bs config (constructBinary t) (show t)--testTernaryOpLowering ::-  forall a b c d as bs cs n.-  ( HasCallStack,-    SupportedPrim a,-    SupportedPrim b,-    SupportedPrim c,-    SBV.EqSymbolic (TermTy n d),-    Typeable (TermTy n a),-    Typeable (TermTy n b),-    Typeable (TermTy n c),-    SBV.SymVal as,-    SBV.SymVal bs,-    SBV.SymVal cs,-    Show as,-    Show bs,-    Show cs,-    TermTy n a ~ SBV.SBV as,-    TermTy n b ~ SBV.SBV bs,-    TermTy n c ~ SBV.SBV cs-  ) =>-  GrisetteSMTConfig n ->-  (Term a -> Term b -> Term c -> Term d) ->-  T.Text ->-  (TermTy n a -> TermTy n b -> TermTy n c -> TermTy n d) ->-  Assertion-testTernaryOpLowering config f name sbvfun = do-  let a :: Term a = ssymTerm "a"-  let b :: Term b = ssymTerm "b"-  let c :: Term c = ssymTerm "c"-  let fabc :: Term d = f a b c-  SBV.runSMTWith (sbvConfig config) $ do-    (m, lt) <- lowerSinglePrim config fabc-    let sbva :: Maybe (TermTy n a) = M.lookup (SomeTerm a) (biMapToSBV m) >>= fromDynamic-    let sbvb :: Maybe (TermTy n b) = M.lookup (SomeTerm b) (biMapToSBV m) >>= fromDynamic-    let sbvc :: Maybe (TermTy n c) = M.lookup (SomeTerm c) (biMapToSBV m) >>= fromDynamic-    case (sbva, sbvb, sbvc) of-      (Just sbvav, Just sbvbv, Just sbvcv) -> SBV.query $ do-        SBV.constrain $ lt SBV..== sbvfun sbvav sbvbv sbvcv-        satres <- SBV.checkSat-        case satres of-          SBV.Sat -> return ()-          _ -> lift $ assertFailure $ T.unpack $ "Lowering for " <> name <> " generated unsolvable formula"-      _ -> lift $ assertFailure "Failed to extract the term"-  SBV.runSMTWith (sbvConfig config) $ do-    (m, lt) <- lowerSinglePrim config fabc-    let sbva :: Maybe (TermTy n a) = M.lookup (SomeTerm a) (biMapToSBV m) >>= fromDynamic-    let sbvb :: Maybe (TermTy n b) = M.lookup (SomeTerm b) (biMapToSBV m) >>= fromDynamic-    let sbvc :: Maybe (TermTy n c) = M.lookup (SomeTerm c) (biMapToSBV m) >>= fromDynamic-    case (sbva, sbvb, sbvc) of-      (Just sbvav, Just sbvbv, Just sbvcv) -> SBV.query $ do-        SBV.constrain $ lt SBV../= sbvfun sbvav sbvbv sbvcv-        r <- SBV.checkSat-        case r of-          SBV.Sat -> do-            counterExampleA <- SBV.getValue sbvav-            counterExampleB <- SBV.getValue sbvbv-            counterExampleC <- SBV.getValue sbvcv-            lift $-              assertFailure $-                "Translation counter example found: "-                  ++ show (counterExampleA, counterExampleB, counterExampleC)-          SBV.Unsat -> return ()-          _ -> lift $ assertFailure $ T.unpack $ "Lowering for " <> name <> " generated unknown formula"-      _ -> lift $ assertFailure "Failed to extract the term"---- testTernaryOpLowering' ::---   forall a b c d as bs cs n tag.---   ( HasCallStack,---     TernaryOp tag a b c d,---     SBV.EqSymbolic (TermTy n d),---     Typeable (TermTy n a),---     Typeable (TermTy n b),---     Typeable (TermTy n c),---     SBV.SymVal as,---     SBV.SymVal bs,---     SBV.SymVal cs,---     Show as,---     Show bs,---     Show cs,---     TermTy n a ~ SBV.SBV as,---     TermTy n b ~ SBV.SBV bs,---     TermTy n c ~ SBV.SBV cs---   ) =>---   GrisetteSMTConfig n ->---   tag ->---   (TermTy n a -> TermTy n b -> TermTy n c -> TermTy n d) ->---   Assertion--- testTernaryOpLowering' config t = testTernaryOpLowering @a @b @c @d @as @bs @cs config (constructTernary t) (show t)--loweringTests :: Test-loweringTests =-  let unboundedConfig = precise SBV.z3-      boundedConfig = approx (Proxy @5) SBV.z3-   in testGroup-        "Lowering"-        [ testGroup-            "Bool Lowering"-            [ testCase "Not" $ do-                testUnaryOpLowering @Bool @Bool unboundedConfig notTerm "not" SBV.sNot,-              testCase "And" $ do-                testBinaryOpLowering @Bool @Bool @Bool unboundedConfig andTerm "and" (SBV..&&)-                testBinaryOpLowering @Bool @Bool @Bool-                  unboundedConfig-                  andTerm-                  "and"-                  (\x y -> SBV.sNot (x SBV..<+> y) SBV..&& (x SBV..|| y)),-              testCase "Or" $ do-                testBinaryOpLowering @Bool @Bool @Bool unboundedConfig orTerm "or" (SBV..||)-                testBinaryOpLowering @Bool @Bool @Bool-                  unboundedConfig-                  orTerm-                  "or"-                  (\x y -> (x SBV..<+> y) SBV..|| (x SBV..&& y)),-              testCase "Eqv" $ do-                testBinaryOpLowering @Bool @Bool @Bool unboundedConfig eqvTerm "eqv" (SBV..==)-                testBinaryOpLowering @Bool @Bool @Bool-                  unboundedConfig-                  eqvTerm-                  "eqv"-                  (\x y -> SBV.sNot (x SBV..<+> y)),-              testCase "ITE" $ do-                testTernaryOpLowering @Bool @Bool @Bool @Bool unboundedConfig iteTerm "ite" SBV.ite-                testTernaryOpLowering @Bool @Bool @Bool @Bool-                  unboundedConfig-                  iteTerm-                  "ite"-                  (\c x y -> (c SBV..=> x) SBV..&& (SBV.sNot c SBV..=> y))-            ],-          testGroup-            "Integer Lowering"-            [ testCase "Add" $ do-                testBinaryOpLowering @Integer @Integer @Integer unboundedConfig addNumTerm "(+)" (+)-                testBinaryOpLowering @Integer @Integer @Integer-                  unboundedConfig-                  addNumTerm-                  "(+)"-                  (\x y -> (x + 1) * (y + 1) - x * y - 1)-                testBinaryOpLowering @Integer @Integer @Integer boundedConfig addNumTerm "(+)" (+)-                testBinaryOpLowering @Integer @Integer @Integer-                  boundedConfig-                  addNumTerm-                  "(+)"-                  (\x y -> (x + 1) * (y + 1) - x * y - 1),-              testCase "Uminus" $ do-                testUnaryOpLowering @Integer @Integer unboundedConfig uminusNumTerm "negate" negate-                testUnaryOpLowering @Integer @Integer-                  unboundedConfig-                  uminusNumTerm-                  "negate"-                  (\x -> (x + 1) * (x + 1) - 3 * x - x * x - 1)-                testUnaryOpLowering @Integer @Integer boundedConfig uminusNumTerm "negate" negate-                testUnaryOpLowering @Integer @Integer-                  boundedConfig-                  uminusNumTerm-                  "negate"-                  (\x -> (x + 1) * (x + 1) - 3 * x - x * x - 1),-              testCase "Abs" $ do-                testUnaryOpLowering @Integer @Integer unboundedConfig absNumTerm "abs" abs-                testUnaryOpLowering @Integer @Integer boundedConfig absNumTerm "abs" abs,-              testCase "Signum" $ do-                testUnaryOpLowering @Integer @Integer unboundedConfig signumNumTerm "signum" signum-                testUnaryOpLowering @Integer @Integer boundedConfig signumNumTerm "signum" signum,-              testCase "Times" $ do-                testBinaryOpLowering @Integer @Integer @Integer unboundedConfig timesNumTerm "(*)" (*)-                testBinaryOpLowering @Integer @Integer @Integer-                  unboundedConfig-                  timesNumTerm-                  "(*)"-                  (\x y -> (x + 1) * (y + 1) - x - y - 1)-                testBinaryOpLowering @Integer @Integer @Integer boundedConfig timesNumTerm "(*)" (*)-                testBinaryOpLowering @Integer @Integer @Integer-                  boundedConfig-                  timesNumTerm-                  "(*)"-                  (\x y -> (x + 1) * (y + 1) - x - y - 1),-              testCase "Lt" $ do-                testBinaryOpLowering @Integer @Integer @Bool unboundedConfig ltNumTerm "(<)" (SBV..<)-                testBinaryOpLowering @Integer @Integer @Bool-                  unboundedConfig-                  ltNumTerm-                  "(<)"-                  (\x y -> x * 2 - x SBV..< y * 2 - y)-                testBinaryOpLowering @Integer @Integer @Bool boundedConfig ltNumTerm "(<)" (SBV..<)-                testBinaryOpLowering @Integer @Integer @Bool-                  boundedConfig-                  ltNumTerm-                  "(<=)"-                  (\x y -> x * 2 - x SBV..< y * 2 - y),-              testCase "Le" $ do-                testBinaryOpLowering @Integer @Integer @Bool unboundedConfig leNumTerm "(<=)" (SBV..<=)-                testBinaryOpLowering @Integer @Integer @Bool-                  unboundedConfig-                  leNumTerm-                  "(<=)"-                  (\x y -> x * 2 - x SBV..<= y * 2 - y)-                testBinaryOpLowering @Integer @Integer @Bool boundedConfig leNumTerm "(<=)" (SBV..<=)-                testBinaryOpLowering @Integer @Integer @Bool-                  boundedConfig-                  leNumTerm-                  "(<=)"-                  (\x y -> x * 2 - x SBV..<= y * 2 - y),-              testCase "Div" $ do-                testBinaryOpLowering @Integer @Integer @Integer unboundedConfig divIntegralTerm "div" SBV.sDiv-                testBinaryOpLowering @Integer @Integer @Integer boundedConfig divIntegralTerm "div" SBV.sDiv,-              testCase "Mod" $ do-                testBinaryOpLowering @Integer @Integer @Integer unboundedConfig modIntegralTerm "mod" SBV.sMod-                testBinaryOpLowering @Integer @Integer @Integer boundedConfig modIntegralTerm "mod" SBV.sMod,-              testCase "Quot" $ do-                testBinaryOpLowering @Integer @Integer @Integer unboundedConfig quotIntegralTerm "quot" SBV.sQuot-                testBinaryOpLowering @Integer @Integer @Integer boundedConfig quotIntegralTerm "quot" SBV.sQuot,-              testCase "Rem" $ do-                testBinaryOpLowering @Integer @Integer @Integer unboundedConfig remIntegralTerm "rem" SBV.sRem-                testBinaryOpLowering @Integer @Integer @Integer boundedConfig remIntegralTerm "rem" SBV.sRem-            ],-          testGroup-            "IntN Lowering"-            [ testCase "Add" $ do-                testBinaryOpLowering @(IntN 5) @(IntN 5) unboundedConfig addNumTerm "(+)" (+)-                testBinaryOpLowering @(IntN 5) @(IntN 5)-                  unboundedConfig-                  addNumTerm-                  "(+)"-                  (\x y -> (x + 1) * (y + 1) - x * y - 1),-              testCase "Uminus" $ do-                testUnaryOpLowering @(IntN 5) unboundedConfig uminusNumTerm "negate" negate-                testUnaryOpLowering @(IntN 5)-                  unboundedConfig-                  uminusNumTerm-                  "negate"-                  (\x -> (x + 1) * (x + 1) - 3 * x - x * x - 1),-              testCase "Abs" $ do-                testUnaryOpLowering @(IntN 5) unboundedConfig absNumTerm "abs" abs,-              testCase "Signum" $ do-                testUnaryOpLowering @(IntN 5) unboundedConfig signumNumTerm "signum" signum,-              testCase "Times" $ do-                testBinaryOpLowering @(IntN 5) @(IntN 5) unboundedConfig timesNumTerm "(*)" (*)-                testBinaryOpLowering @(IntN 5) @(IntN 5)-                  unboundedConfig-                  timesNumTerm-                  "(*)"-                  (\x y -> (x + 1) * (y + 1) - x - y - 1),-              testCase "Lt" $ do-                testBinaryOpLowering @(IntN 5) @(IntN 5) unboundedConfig ltNumTerm "(<)" (SBV..<)-                testBinaryOpLowering @(IntN 5) @(IntN 5)-                  unboundedConfig-                  ltNumTerm-                  "(<)"-                  (\x y -> x * 2 - x SBV..< y * 2 - y),-              testCase "Le" $ do-                testBinaryOpLowering @(IntN 5) @(IntN 5) unboundedConfig leNumTerm "(<=)" (SBV..<=)-                testBinaryOpLowering @(IntN 5) @(IntN 5)-                  unboundedConfig-                  leNumTerm-                  "(<=)"-                  (\x y -> x * 2 - x SBV..<= y * 2 - y),-              testCase "Extract" $ do-                testUnaryOpLowering @(IntN 5) @(IntN 1)-                  unboundedConfig-                  (bvselectTerm (Proxy @0) (Proxy @1))-                  "select"-                  (SBV.bvExtract @0 @0 @5 Proxy Proxy)-                testUnaryOpLowering @(IntN 5) @(IntN 1)-                  unboundedConfig-                  (bvselectTerm (Proxy @1) (Proxy @1))-                  "select"-                  (SBV.bvExtract @1 @1 @5 Proxy Proxy)-                testUnaryOpLowering @(IntN 5) @(IntN 1)-                  unboundedConfig-                  (bvselectTerm (Proxy @2) (Proxy @1))-                  "select"-                  (SBV.bvExtract @2 @2 @5 Proxy Proxy)-                testUnaryOpLowering @(IntN 5) @(IntN 1)-                  unboundedConfig-                  (bvselectTerm (Proxy @3) (Proxy @1))-                  "select"-                  (SBV.bvExtract @3 @3 @5 Proxy Proxy)-                testUnaryOpLowering @(IntN 5) @(IntN 1)-                  unboundedConfig-                  (bvselectTerm (Proxy @4) (Proxy @1))-                  "select"-                  (SBV.bvExtract @4 @4 @5 Proxy Proxy)-                testUnaryOpLowering @(IntN 5) @(IntN 2)-                  unboundedConfig-                  (bvselectTerm (Proxy @0) (Proxy @2))-                  "select"-                  (SBV.bvExtract @1 @0 @5 Proxy Proxy)-                testUnaryOpLowering @(IntN 5) @(IntN 2)-                  unboundedConfig-                  (bvselectTerm (Proxy @1) (Proxy @2))-                  "select"-                  (SBV.bvExtract @2 @1 @5 Proxy Proxy)-                testUnaryOpLowering @(IntN 5) @(IntN 2)-                  unboundedConfig-                  (bvselectTerm (Proxy @2) (Proxy @2))-                  "select"-                  (SBV.bvExtract @3 @2 @5 Proxy Proxy)-                testUnaryOpLowering @(IntN 5) @(IntN 2)-                  unboundedConfig-                  (bvselectTerm (Proxy @3) (Proxy @2))-                  "select"-                  (SBV.bvExtract @4 @3 @5 Proxy Proxy)-                testUnaryOpLowering @(IntN 5) @(IntN 3)-                  unboundedConfig-                  (bvselectTerm (Proxy @0) (Proxy @3))-                  "select"-                  (SBV.bvExtract @2 @0 @5 Proxy Proxy)-                testUnaryOpLowering @(IntN 5) @(IntN 3)-                  unboundedConfig-                  (bvselectTerm (Proxy @1) (Proxy @3))-                  "select"-                  (SBV.bvExtract @3 @1 @5 Proxy Proxy)-                testUnaryOpLowering @(IntN 5) @(IntN 3)-                  unboundedConfig-                  (bvselectTerm (Proxy @2) (Proxy @3))-                  "select"-                  (SBV.bvExtract @4 @2 @5 Proxy Proxy)-                testUnaryOpLowering @(IntN 5) @(IntN 4)-                  unboundedConfig-                  (bvselectTerm (Proxy @0) (Proxy @4))-                  "select"-                  (SBV.bvExtract @3 @0 @5 Proxy Proxy)-                testUnaryOpLowering @(IntN 5) @(IntN 4)-                  unboundedConfig-                  (bvselectTerm (Proxy @1) (Proxy @4))-                  "select"-                  (SBV.bvExtract @4 @1 @5 Proxy Proxy)-                testUnaryOpLowering @(IntN 5) @(IntN 5)-                  unboundedConfig-                  (bvselectTerm (Proxy @0) (Proxy @5))-                  "select"-                  id,-              testCase "Extension" $ do-                testUnaryOpLowering @(IntN 5) @(IntN 6)-                  unboundedConfig-                  (bvzeroExtendTerm (Proxy @6))-                  "bvzeroExtend"-                  SBV.zeroExtend-                testUnaryOpLowering @(IntN 5) @(IntN 10)-                  unboundedConfig-                  (bvzeroExtendTerm (Proxy @10))-                  "bvzeroExtend"-                  SBV.zeroExtend-                testUnaryOpLowering @(IntN 5) @(IntN 6)-                  unboundedConfig-                  (bvsignExtendTerm (Proxy @6))-                  "bvsignExtend"-                  SBV.signExtend-                testUnaryOpLowering @(IntN 5) @(IntN 10)-                  unboundedConfig-                  (bvsignExtendTerm (Proxy @10))-                  "bvsignExtend"-                  SBV.signExtend,-              testCase "Concat" $ do-                testBinaryOpLowering @(IntN 4) @(IntN 5) @(IntN 9)-                  unboundedConfig-                  bvconcatTerm-                  "bvconcat"-                  (SBV.#),-              testCase "AndBits" $ do-                testBinaryOpLowering @(IntN 5) @(IntN 5) unboundedConfig andBitsTerm "(.&.)" (.&.),-              testCase "OrBits" $ do-                testBinaryOpLowering @(IntN 5) @(IntN 5) unboundedConfig orBitsTerm "(.|.)" (.|.),-              testCase "XorBits" $ do-                testBinaryOpLowering @(IntN 5) @(IntN 5) unboundedConfig xorBitsTerm "xor" xor,-              testCase "ComplementBits" $ do-                testUnaryOpLowering @(IntN 5) unboundedConfig complementBitsTerm "complement" complement,-              testCase "ShiftLeft" $ do-                testBinaryOpLowering @(IntN 5) unboundedConfig shiftLeftTerm "shiftLeft" SBV.sShiftLeft,-              testCase "ShiftRight" $ do-                testBinaryOpLowering @(IntN 5) unboundedConfig shiftRightTerm "shiftRight" SBV.sShiftRight,-              testCase "RotateLeft" $ do-                testBinaryOpLowering @(IntN 5)-                  unboundedConfig-                  rotateLeftTerm-                  "rotateLeft"-                  ( \a b ->-                      SBV.sFromIntegral $-                        SBV.sRotateLeft-                          (SBV.sFromIntegral a :: SBV.SWord 5)-                          (SBV.sFromIntegral b :: SBV.SWord 5)-                  ),-              testCase "RotateRight" $ do-                testBinaryOpLowering @(IntN 5)-                  unboundedConfig-                  rotateRightTerm-                  "rotateRight"-                  ( \a b ->-                      SBV.sFromIntegral $-                        SBV.sRotateRight-                          (SBV.sFromIntegral a :: SBV.SWord 5)-                          (SBV.sFromIntegral b :: SBV.SWord 5)-                  ),-              testCase "Div - bounded" $ do-                testBinaryOpLowering @(IntN 5) @(IntN 5) @(IntN 5) unboundedConfig divBoundedIntegralTerm "div" SBV.sDiv-                testBinaryOpLowering @(IntN 5) @(IntN 5) @(IntN 5) boundedConfig divBoundedIntegralTerm "div" SBV.sDiv,-              testCase "Mod - bounded" $ do-                testBinaryOpLowering @(IntN 5) @(IntN 5) @(IntN 5) unboundedConfig modBoundedIntegralTerm "mod" SBV.sMod-                testBinaryOpLowering @(IntN 5) @(IntN 5) @(IntN 5) boundedConfig modBoundedIntegralTerm "mod" SBV.sMod,-              testCase "Quot - bounded" $ do-                testBinaryOpLowering @(IntN 5) @(IntN 5) @(IntN 5) unboundedConfig quotBoundedIntegralTerm "quot" SBV.sQuot-                testBinaryOpLowering @(IntN 5) @(IntN 5) @(IntN 5) boundedConfig quotBoundedIntegralTerm "quot" SBV.sQuot,-              testCase "Rem - bounded" $ do-                testBinaryOpLowering @(IntN 5) @(IntN 5) @(IntN 5) unboundedConfig remBoundedIntegralTerm "rem" SBV.sRem-                testBinaryOpLowering @(IntN 5) @(IntN 5) @(IntN 5) boundedConfig remBoundedIntegralTerm "rem" SBV.sRem,-              testCase "ToUnsigned" $ do-                testUnaryOpLowering @(IntN 5) @(WordN 5) unboundedConfig toUnsignedTerm "toUnsigned" SBV.sFromIntegral-                testUnaryOpLowering @(IntN 5) @(WordN 5) boundedConfig toUnsignedTerm "toUnsigned" SBV.sFromIntegral-            ],-          testGroup-            "WordN"-            [ testCase "Add" $ do-                testBinaryOpLowering @(WordN 5) @(WordN 5) unboundedConfig addNumTerm "(+)" (+)-                testBinaryOpLowering @(WordN 5) @(WordN 5)-                  unboundedConfig-                  addNumTerm-                  "(+)"-                  (\x y -> (x + 1) * (y + 1) - x * y - 1),-              testCase "Uminus" $ do-                testUnaryOpLowering @(WordN 5) unboundedConfig uminusNumTerm "negate" negate-                testUnaryOpLowering @(WordN 5)-                  unboundedConfig-                  uminusNumTerm-                  "negate"-                  (\x -> (x + 1) * (x + 1) - 3 * x - x * x - 1),-              testCase "Abs" $ do-                testUnaryOpLowering @(WordN 5) unboundedConfig absNumTerm "abs" abs,-              testCase "Signum" $ do-                testUnaryOpLowering @(WordN 5) unboundedConfig signumNumTerm "signum" signum,-              testCase "Times" $ do-                testBinaryOpLowering @(WordN 5) @(WordN 5) unboundedConfig timesNumTerm "(*)" (*)-                testBinaryOpLowering @(WordN 5) @(WordN 5)-                  unboundedConfig-                  timesNumTerm-                  "(*)"-                  (\x y -> (x + 1) * (y + 1) - x - y - 1),-              testCase "Lt" $ do-                testBinaryOpLowering @(WordN 5) @(WordN 5) unboundedConfig ltNumTerm "(<)" (SBV..<)-                testBinaryOpLowering @(WordN 5) @(WordN 5)-                  unboundedConfig-                  ltNumTerm-                  "(<)"-                  (\x y -> x * 2 - x SBV..< y * 2 - y),-              testCase "Le" $ do-                testBinaryOpLowering @(WordN 5) @(WordN 5) unboundedConfig leNumTerm "(<=)" (SBV..<=)-                testBinaryOpLowering @(WordN 5) @(WordN 5)-                  unboundedConfig-                  leNumTerm-                  "(<=)"-                  (\x y -> x * 2 - x SBV..<= y * 2 - y),-              testCase "Extract" $ do-                testUnaryOpLowering @(WordN 5) @(WordN 1)-                  unboundedConfig-                  (bvselectTerm (Proxy @0) (Proxy @1))-                  "select"-                  (SBV.bvExtract @0 @0 @5 Proxy Proxy)-                testUnaryOpLowering @(WordN 5) @(WordN 1)-                  unboundedConfig-                  (bvselectTerm (Proxy @1) (Proxy @1))-                  "select"-                  (SBV.bvExtract @1 @1 @5 Proxy Proxy)-                testUnaryOpLowering @(WordN 5) @(WordN 1)-                  unboundedConfig-                  (bvselectTerm (Proxy @2) (Proxy @1))-                  "select"-                  (SBV.bvExtract @2 @2 @5 Proxy Proxy)-                testUnaryOpLowering @(WordN 5) @(WordN 1)-                  unboundedConfig-                  (bvselectTerm (Proxy @3) (Proxy @1))-                  "select"-                  (SBV.bvExtract @3 @3 @5 Proxy Proxy)-                testUnaryOpLowering @(WordN 5) @(WordN 1)-                  unboundedConfig-                  (bvselectTerm (Proxy @4) (Proxy @1))-                  "select"-                  (SBV.bvExtract @4 @4 @5 Proxy Proxy)-                testUnaryOpLowering @(WordN 5) @(WordN 2)-                  unboundedConfig-                  (bvselectTerm (Proxy @0) (Proxy @2))-                  "select"-                  (SBV.bvExtract @1 @0 @5 Proxy Proxy)-                testUnaryOpLowering @(WordN 5) @(WordN 2)-                  unboundedConfig-                  (bvselectTerm (Proxy @1) (Proxy @2))-                  "select"-                  (SBV.bvExtract @2 @1 @5 Proxy Proxy)-                testUnaryOpLowering @(WordN 5) @(WordN 2)-                  unboundedConfig-                  (bvselectTerm (Proxy @2) (Proxy @2))-                  "select"-                  (SBV.bvExtract @3 @2 @5 Proxy Proxy)-                testUnaryOpLowering @(WordN 5) @(WordN 2)-                  unboundedConfig-                  (bvselectTerm (Proxy @3) (Proxy @2))-                  "select"-                  (SBV.bvExtract @4 @3 @5 Proxy Proxy)-                testUnaryOpLowering @(WordN 5) @(WordN 3)-                  unboundedConfig-                  (bvselectTerm (Proxy @0) (Proxy @3))-                  "select"-                  (SBV.bvExtract @2 @0 @5 Proxy Proxy)-                testUnaryOpLowering @(WordN 5) @(WordN 3)-                  unboundedConfig-                  (bvselectTerm (Proxy @1) (Proxy @3))-                  "select"-                  (SBV.bvExtract @3 @1 @5 Proxy Proxy)-                testUnaryOpLowering @(WordN 5) @(WordN 3)-                  unboundedConfig-                  (bvselectTerm (Proxy @2) (Proxy @3))-                  "select"-                  (SBV.bvExtract @4 @2 @5 Proxy Proxy)-                testUnaryOpLowering @(WordN 5) @(WordN 4)-                  unboundedConfig-                  (bvselectTerm (Proxy @0) (Proxy @4))-                  "select"-                  (SBV.bvExtract @3 @0 @5 Proxy Proxy)-                testUnaryOpLowering @(WordN 5) @(WordN 4)-                  unboundedConfig-                  (bvselectTerm (Proxy @1) (Proxy @4))-                  "select"-                  (SBV.bvExtract @4 @1 @5 Proxy Proxy)-                testUnaryOpLowering @(WordN 5) @(WordN 5)-                  unboundedConfig-                  (bvselectTerm (Proxy @0) (Proxy @5))-                  "select"-                  id,-              testCase "Extension" $ do-                testUnaryOpLowering @(WordN 5) @(WordN 6)-                  unboundedConfig-                  (bvzeroExtendTerm (Proxy @6))-                  "bvzeroExtend"-                  SBV.zeroExtend-                testUnaryOpLowering @(WordN 5) @(WordN 10)-                  unboundedConfig-                  (bvzeroExtendTerm (Proxy @10))-                  "bvzeroExtend"-                  SBV.zeroExtend-                testUnaryOpLowering @(WordN 5) @(WordN 6)-                  unboundedConfig-                  (bvsignExtendTerm (Proxy @6))-                  "bvsignExtend"-                  SBV.signExtend-                testUnaryOpLowering @(WordN 5) @(WordN 10)-                  unboundedConfig-                  (bvsignExtendTerm (Proxy @10))-                  "bvsignExtend"-                  SBV.signExtend,-              testCase "Concat" $ do-                testBinaryOpLowering @(WordN 4) @(WordN 5) @(WordN 9)-                  unboundedConfig-                  bvconcatTerm-                  "bvconcat"-                  (SBV.#),-              testCase "AndBits" $ do-                testBinaryOpLowering @(WordN 5) @(WordN 5) unboundedConfig andBitsTerm "(.&.)" (.&.),-              testCase "OrBits" $ do-                testBinaryOpLowering @(WordN 5) @(WordN 5) unboundedConfig orBitsTerm "(.|.)" (.|.),-              testCase "XorBits" $ do-                testBinaryOpLowering @(WordN 5) @(WordN 5) unboundedConfig xorBitsTerm "xor" xor,-              testCase "ComplementBits" $ do-                testUnaryOpLowering @(WordN 5) unboundedConfig complementBitsTerm "complement" complement,-              testCase "ShiftLeft" $ do-                testBinaryOpLowering @(WordN 5) unboundedConfig shiftLeftTerm "shiftLeft" SBV.sShiftLeft,-              testCase "ShiftRight" $ do-                testBinaryOpLowering @(WordN 5) unboundedConfig shiftRightTerm "shiftRight" SBV.sShiftRight,-              testCase "RotateLeft" $ do-                testBinaryOpLowering @(WordN 5) unboundedConfig rotateLeftTerm "rotateLeft" SBV.sRotateLeft,-              testCase "RotateRight" $ do-                testBinaryOpLowering @(WordN 5) unboundedConfig rotateRightTerm "rotateRight" SBV.sRotateRight,-              testCase "Div" $ do-                testBinaryOpLowering @(WordN 5) @(WordN 5) @(WordN 5) unboundedConfig divIntegralTerm "div" SBV.sDiv-                testBinaryOpLowering @(WordN 5) @(WordN 5) @(WordN 5) boundedConfig divIntegralTerm "div" SBV.sDiv,-              testCase "Mod" $ do-                testBinaryOpLowering @(WordN 5) @(WordN 5) @(WordN 5) unboundedConfig modIntegralTerm "mod" SBV.sMod-                testBinaryOpLowering @(WordN 5) @(WordN 5) @(WordN 5) boundedConfig modIntegralTerm "mod" SBV.sMod,-              testCase "Quot" $ do-                testBinaryOpLowering @(WordN 5) @(WordN 5) @(WordN 5) unboundedConfig quotIntegralTerm "quot" SBV.sQuot-                testBinaryOpLowering @(WordN 5) @(WordN 5) @(WordN 5) boundedConfig quotIntegralTerm "quot" SBV.sQuot,-              testCase "Rem" $ do-                testBinaryOpLowering @(WordN 5) @(WordN 5) @(WordN 5) unboundedConfig remIntegralTerm "rem" SBV.sRem-                testBinaryOpLowering @(WordN 5) @(WordN 5) @(WordN 5) boundedConfig remIntegralTerm "rem" SBV.sRem,-              testCase "ToSigned" $ do-                testUnaryOpLowering @(WordN 5) @(IntN 5) unboundedConfig toSignedTerm "toSigned" SBV.sFromIntegral-                testUnaryOpLowering @(WordN 5) @(IntN 5) boundedConfig toSignedTerm "toSigned" SBV.sFromIntegral-            ]-        ]
− test/Grisette/Backend/SBV/Data/SMT/TermRewritingGen.hs 
@@ -1,863 +0,0 @@-{-# LANGUAGE BinaryLiterals #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuantifiedConstraints #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}--module Grisette.Backend.SBV.Data.SMT.TermRewritingGen-  ( TermRewritingSpec (..),-    GeneralSpec (..),-    DifferentSizeBVSpec (..),-    FixedSizedBVWithBoolSpec (..),-    BoolWithLIASpec (..),-    LIAWithBoolSpec (..),-    BoolOnlySpec (..),-    constructUnarySpec',-    constructBinarySpec',-    constructTernarySpec',-    divIntegralSpec,-    modIntegralSpec,-    quotIntegralSpec,-    remIntegralSpec,-    divBoundedIntegralSpec,-    modBoundedIntegralSpec,-    quotBoundedIntegralSpec,-    remBoundedIntegralSpec,-    uminusNumSpec,-    timesNumSpec,-    addNumSpec,-    absNumSpec,-    iteSpec,-    eqvSpec,-    notSpec,-    andSpec,-    orSpec,-    shiftLeftSpec,-    shiftRightSpec,-    rotateLeftSpec,-    rotateRightSpec,-    xorBitsSpec,-  )-where--import Data.Bits (Bits, FiniteBits)-import Data.Data (Proxy (Proxy), Typeable)-import Data.Kind (Type)-import qualified Data.Text as T-import GHC.TypeLits (KnownNat, Nat, type (+), type (<=))-import Grisette.Core.Data.Class.BitVector (SizedBV)-import Grisette.Core.Data.Class.SymRotate (SymRotate)-import Grisette.Core.Data.Class.SymShift (SymShift)-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors-  ( absNumTerm,-    addNumTerm,-    andBitsTerm,-    andTerm,-    bvconcatTerm,-    bvextendTerm,-    bvselectTerm,-    complementBitsTerm,-    conTerm,-    constructBinary,-    constructTernary,-    constructUnary,-    divBoundedIntegralTerm,-    divIntegralTerm,-    eqvTerm,-    iteTerm,-    leNumTerm,-    ltNumTerm,-    modBoundedIntegralTerm,-    modIntegralTerm,-    notTerm,-    orBitsTerm,-    orTerm,-    quotBoundedIntegralTerm,-    quotIntegralTerm,-    remBoundedIntegralTerm,-    remIntegralTerm,-    rotateLeftTerm,-    rotateRightTerm,-    shiftLeftTerm,-    shiftRightTerm,-    signumNumTerm,-    ssymTerm,-    timesNumTerm,-    uminusNumTerm,-    xorBitsTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term-  ( BinaryOp (partialEvalBinary),-    SupportedPrim,-    Term,-    TernaryOp (partialEvalTernary),-    UnaryOp (partialEvalUnary),-  )-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermUtils-  ( pformat,-  )-import Grisette.IR.SymPrim.Data.Prim.PartialEval.BV-  ( pevalBVConcatTerm,-    pevalBVExtendTerm,-    pevalBVSelectTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bits-  ( pevalAndBitsTerm,-    pevalComplementBitsTerm,-    pevalOrBitsTerm,-    pevalRotateLeftTerm,-    pevalRotateRightTerm,-    pevalShiftLeftTerm,-    pevalShiftRightTerm,-    pevalXorBitsTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool-  ( pevalAndTerm,-    pevalEqvTerm,-    pevalITETerm,-    pevalNotTerm,-    pevalOrTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.PartialEval.Integral-  ( pevalDivBoundedIntegralTerm,-    pevalDivIntegralTerm,-    pevalModBoundedIntegralTerm,-    pevalModIntegralTerm,-    pevalQuotBoundedIntegralTerm,-    pevalQuotIntegralTerm,-    pevalRemBoundedIntegralTerm,-    pevalRemIntegralTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.PartialEval.Num-  ( pevalAbsNumTerm,-    pevalAddNumTerm,-    pevalLeNumTerm,-    pevalLtNumTerm,-    pevalSignumNumTerm,-    pevalTimesNumTerm,-    pevalUMinusNumTerm,-  )-import Test.QuickCheck (Arbitrary (arbitrary), Gen, frequency, oneof, sized)--class (SupportedPrim b) => TermRewritingSpec a b | a -> b where-  norewriteVer :: a -> Term b-  rewriteVer :: a -> Term b-  wrap :: Term b -> Term b -> a-  same :: a -> Term Bool-  counterExample :: a -> Term Bool-  counterExample = notTerm . same-  symSpec :: T.Text -> a-  symSpec s = wrap (ssymTerm s) (ssymTerm s)-  conSpec :: b -> a-  conSpec v = wrap (conTerm v) (conTerm v)--constructUnarySpec ::-  forall a av b bv.-  ( TermRewritingSpec a av,-    TermRewritingSpec b bv-  ) =>-  (Term av -> Term bv) ->-  (Term av -> Term bv) ->-  a ->-  b-constructUnarySpec construct partial a =-  wrap (construct $ norewriteVer a) (partial $ rewriteVer a)--constructUnarySpec' ::-  forall a av b bv tag.-  ( TermRewritingSpec a av,-    TermRewritingSpec b bv,-    UnaryOp tag av bv-  ) =>-  tag ->-  a ->-  b-constructUnarySpec' tag = constructUnarySpec @a @av @b @bv (constructUnary tag) (partialEvalUnary tag)--constructBinarySpec ::-  forall a av b bv c cv.-  ( TermRewritingSpec a av,-    TermRewritingSpec b bv,-    TermRewritingSpec c cv-  ) =>-  (Term av -> Term bv -> Term cv) ->-  (Term av -> Term bv -> Term cv) ->-  a ->-  b ->-  c-constructBinarySpec construct partial a b =-  wrap-    (construct (norewriteVer a) (norewriteVer b))-    (partial (rewriteVer a) (rewriteVer b))--constructBinarySpec' ::-  forall a av b bv c cv tag.-  ( TermRewritingSpec a av,-    TermRewritingSpec b bv,-    TermRewritingSpec c cv,-    BinaryOp tag av bv cv-  ) =>-  tag ->-  a ->-  b ->-  c-constructBinarySpec' tag = constructBinarySpec @a @av @b @bv @c @cv (constructBinary tag) (partialEvalBinary tag)--constructTernarySpec ::-  forall a av b bv c cv d dv.-  ( TermRewritingSpec a av,-    TermRewritingSpec b bv,-    TermRewritingSpec c cv,-    TermRewritingSpec d dv-  ) =>-  (Term av -> Term bv -> Term cv -> Term dv) ->-  (Term av -> Term bv -> Term cv -> Term dv) ->-  a ->-  b ->-  c ->-  d-constructTernarySpec construct partial a b c =-  wrap-    (construct (norewriteVer a) (norewriteVer b) (norewriteVer c))-    (partial (rewriteVer a) (rewriteVer b) (rewriteVer c))--constructTernarySpec' ::-  forall a av b bv c cv d dv tag.-  ( TermRewritingSpec a av,-    TermRewritingSpec b bv,-    TermRewritingSpec c cv,-    TermRewritingSpec d dv,-    TernaryOp tag av bv cv dv-  ) =>-  tag ->-  a ->-  b ->-  c ->-  d-constructTernarySpec' tag =-  constructTernarySpec @a @av @b @bv @c @cv @d @dv-    (constructTernary tag)-    (partialEvalTernary tag)--notSpec :: (TermRewritingSpec a Bool) => a -> a-notSpec = constructUnarySpec notTerm pevalNotTerm--andSpec :: (TermRewritingSpec a Bool) => a -> a -> a-andSpec = constructBinarySpec andTerm pevalAndTerm--orSpec :: (TermRewritingSpec a Bool) => a -> a -> a-orSpec = constructBinarySpec orTerm pevalOrTerm--eqvSpec :: (TermRewritingSpec a av, TermRewritingSpec b Bool) => a -> a -> b-eqvSpec = constructBinarySpec eqvTerm pevalEqvTerm--iteSpec :: (TermRewritingSpec a Bool, TermRewritingSpec b bv) => a -> b -> b -> b-iteSpec = constructTernarySpec iteTerm pevalITETerm--addNumSpec :: (TermRewritingSpec a av, Num av) => a -> a -> a-addNumSpec = constructBinarySpec addNumTerm pevalAddNumTerm--uminusNumSpec :: (TermRewritingSpec a av, Num av) => a -> a-uminusNumSpec = constructUnarySpec uminusNumTerm pevalUMinusNumTerm--timesNumSpec :: (TermRewritingSpec a av, Num av) => a -> a -> a-timesNumSpec = constructBinarySpec timesNumTerm pevalTimesNumTerm--absNumSpec :: (TermRewritingSpec a av, Num av) => a -> a-absNumSpec = constructUnarySpec absNumTerm pevalAbsNumTerm--signumNumSpec :: (TermRewritingSpec a av, Num av) => a -> a-signumNumSpec = constructUnarySpec signumNumTerm pevalSignumNumTerm--ltNumSpec :: (TermRewritingSpec a av, Num av, Ord av, TermRewritingSpec b Bool) => a -> a -> b-ltNumSpec = constructBinarySpec ltNumTerm pevalLtNumTerm--leNumSpec :: (TermRewritingSpec a av, Num av, Ord av, TermRewritingSpec b Bool) => a -> a -> b-leNumSpec = constructBinarySpec leNumTerm pevalLeNumTerm--andBitsSpec :: (TermRewritingSpec a av, Bits av) => a -> a -> a-andBitsSpec = constructBinarySpec andBitsTerm pevalAndBitsTerm--orBitsSpec :: (TermRewritingSpec a av, Bits av) => a -> a -> a-orBitsSpec = constructBinarySpec orBitsTerm pevalOrBitsTerm--xorBitsSpec :: (TermRewritingSpec a av, Bits av) => a -> a -> a-xorBitsSpec = constructBinarySpec xorBitsTerm pevalXorBitsTerm--complementBitsSpec :: (TermRewritingSpec a av, Bits av) => a -> a-complementBitsSpec = constructUnarySpec complementBitsTerm pevalComplementBitsTerm--shiftLeftSpec :: (TermRewritingSpec a av, Integral av, FiniteBits av, SymShift av) => a -> a -> a-shiftLeftSpec = constructBinarySpec shiftLeftTerm pevalShiftLeftTerm--shiftRightSpec :: (TermRewritingSpec a av, Integral av, FiniteBits av, SymShift av) => a -> a -> a-shiftRightSpec = constructBinarySpec shiftRightTerm pevalShiftRightTerm--rotateLeftSpec :: (TermRewritingSpec a av, Integral av, FiniteBits av, SymRotate av) => a -> a -> a-rotateLeftSpec = constructBinarySpec rotateLeftTerm pevalRotateLeftTerm--rotateRightSpec :: (TermRewritingSpec a av, Integral av, FiniteBits av, SymRotate av) => a -> a -> a-rotateRightSpec = constructBinarySpec rotateRightTerm pevalRotateRightTerm--bvconcatSpec ::-  ( TermRewritingSpec a (bv an),-    TermRewritingSpec b (bv bn),-    TermRewritingSpec c (bv (an + bn)),-    forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n),-    Typeable bv,-    KnownNat an,-    KnownNat bn,-    KnownNat (an + bn),-    1 <= an,-    1 <= bn,-    1 <= an + bn,-    SizedBV bv-  ) =>-  a ->-  b ->-  c-bvconcatSpec = constructBinarySpec bvconcatTerm pevalBVConcatTerm--bvselectSpec ::-  ( TermRewritingSpec a (bv an),-    TermRewritingSpec b (bv bn),-    forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n),-    Typeable bv,-    KnownNat an,-    KnownNat ix,-    KnownNat bn,-    1 <= an,-    1 <= bn,-    0 <= ix,-    ix + bn <= an,-    SizedBV bv-  ) =>-  proxy ix ->-  proxy bn ->-  a ->-  b-bvselectSpec p1 p2 = constructUnarySpec (bvselectTerm p1 p2) (pevalBVSelectTerm p1 p2)--bvextendSpec ::-  ( TermRewritingSpec a (bv an),-    TermRewritingSpec b (bv bn),-    forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n),-    Typeable bv,-    KnownNat an,-    KnownNat bn,-    1 <= an,-    1 <= bn,-    an <= bn,-    SizedBV bv-  ) =>-  Bool ->-  proxy bn ->-  a ->-  b-bvextendSpec signed p = constructUnarySpec (bvextendTerm signed p) (pevalBVExtendTerm signed p)--divIntegralSpec :: (TermRewritingSpec a b, Integral b) => a -> a -> a-divIntegralSpec = constructBinarySpec divIntegralTerm pevalDivIntegralTerm--modIntegralSpec :: (TermRewritingSpec a b, Integral b) => a -> a -> a-modIntegralSpec = constructBinarySpec modIntegralTerm pevalModIntegralTerm--quotIntegralSpec :: (TermRewritingSpec a b, Integral b) => a -> a -> a-quotIntegralSpec = constructBinarySpec quotIntegralTerm pevalQuotIntegralTerm--remIntegralSpec :: (TermRewritingSpec a b, Integral b) => a -> a -> a-remIntegralSpec = constructBinarySpec remIntegralTerm pevalRemIntegralTerm--divBoundedIntegralSpec :: (TermRewritingSpec a b, Bounded b, Integral b) => a -> a -> a-divBoundedIntegralSpec = constructBinarySpec divBoundedIntegralTerm pevalDivBoundedIntegralTerm--modBoundedIntegralSpec :: (TermRewritingSpec a b, Bounded b, Integral b) => a -> a -> a-modBoundedIntegralSpec = constructBinarySpec modBoundedIntegralTerm pevalModBoundedIntegralTerm--quotBoundedIntegralSpec :: (TermRewritingSpec a b, Bounded b, Integral b) => a -> a -> a-quotBoundedIntegralSpec = constructBinarySpec quotBoundedIntegralTerm pevalQuotBoundedIntegralTerm--remBoundedIntegralSpec :: (TermRewritingSpec a b, Bounded b, Integral b) => a -> a -> a-remBoundedIntegralSpec = constructBinarySpec remBoundedIntegralTerm pevalRemBoundedIntegralTerm--data BoolOnlySpec = BoolOnlySpec (Term Bool) (Term Bool)--instance Show BoolOnlySpec where-  show (BoolOnlySpec n r) = "BoolOnlySpec { no: " ++ pformat n ++ ", re: " ++ pformat r ++ " }"--instance TermRewritingSpec BoolOnlySpec Bool where-  norewriteVer (BoolOnlySpec n _) = n-  rewriteVer (BoolOnlySpec _ r) = r-  wrap = BoolOnlySpec-  same s = eqvTerm (norewriteVer s) (rewriteVer s)--boolonly :: Int -> Gen BoolOnlySpec-boolonly 0 =-  let s =-        oneof $-          return . symSpec . (<> "bool")-            <$> ["a", "b", "c", "d", "e", "f", "g"]-      r = oneof $ return . conSpec <$> [True, False]-   in oneof [r, s]-boolonly n | n > 0 = do-  v1 <- boolonly (n - 1)-  v2 <- boolonly (n - 1)-  v3 <- boolonly (n - 1)-  oneof-    [ return $ notSpec v1,-      return $ andSpec v1 v2,-      return $ orSpec v1 v2,-      return $ eqvSpec v1 v2,-      return $ iteSpec v1 v2 v3-    ]-boolonly _ = error "Should never be called"--instance Arbitrary BoolOnlySpec where-  arbitrary = sized boolonly--data BoolWithLIASpec = BoolWithLIASpec (Term Bool) (Term Bool)--instance Show BoolWithLIASpec where-  show (BoolWithLIASpec n r) = "BoolWithLIASpec { no: " ++ pformat n ++ ", re: " ++ pformat r ++ " }"--instance TermRewritingSpec BoolWithLIASpec Bool where-  norewriteVer (BoolWithLIASpec n _) = n-  rewriteVer (BoolWithLIASpec _ r) = r-  wrap = BoolWithLIASpec-  same s = eqvTerm (norewriteVer s) (rewriteVer s)--data LIAWithBoolSpec = LIAWithBoolSpec (Term Integer) (Term Integer)--instance Show LIAWithBoolSpec where-  show (LIAWithBoolSpec n r) =-    "LIAWithBoolSpec { no: " ++ pformat n ++ ", re: " ++ pformat r ++ " }"--instance TermRewritingSpec LIAWithBoolSpec Integer where-  norewriteVer (LIAWithBoolSpec n _) = n-  rewriteVer (LIAWithBoolSpec _ r) = r-  wrap = LIAWithBoolSpec-  same s = eqvTerm (norewriteVer s) (rewriteVer s)--boolWithLIA :: Int -> Gen BoolWithLIASpec-boolWithLIA 0 =-  let s =-        oneof $-          return . symSpec . (<> "bool")-            <$> ["a", "b", "c", "d", "e", "f", "g"]-      r = oneof $ return . conSpec <$> [True, False]-   in oneof [r, s]-boolWithLIA n | n > 0 = do-  v1 <- boolWithLIA (n - 1)-  v2 <- boolWithLIA (n - 1)-  v3 <- boolWithLIA (n - 1)-  v1i <- liaWithBool (n - 1)-  v2i <- liaWithBool (n - 1)-  frequency-    [ (1, return $ notSpec v1),-      (1, return $ andSpec v1 v2),-      (1, return $ orSpec v1 v2),-      (1, return $ eqvSpec v1 v2),-      (5, return $ eqvSpec v1i v2i),-      (5, return $ ltNumSpec v1i v2i),-      (5, return $ leNumSpec v1i v2i),-      (1, return $ iteSpec v1 v2 v3)-    ]-boolWithLIA _ = error "Should never be called"--liaWithBool :: Int -> Gen LIAWithBoolSpec-liaWithBool 0 =-  let s =-        oneof $-          return . symSpec . (<> "int")-            <$> ["a", "b", "c", "d", "e", "f", "g"]-      r = conSpec <$> arbitrary-   in oneof [r, s]-liaWithBool n | n > 0 = do-  v1b <- boolWithLIA (n - 1)-  v1i <- liaWithBool (n - 1)-  v2i <- liaWithBool (n - 1)-  oneof-    [ return $ uminusNumSpec v1i,-      return $ absNumSpec v1i,-      return $ signumNumSpec v1i,-      return $ addNumSpec v1i v2i,-      return $ iteSpec v1b v1i v2i-    ]-liaWithBool _ = error "Should never be called"--instance Arbitrary BoolWithLIASpec where-  arbitrary = sized boolWithLIA--instance Arbitrary LIAWithBoolSpec where-  arbitrary = sized liaWithBool--data FixedSizedBVWithBoolSpec (bv :: Nat -> Type) (n :: Nat) = FixedSizedBVWithBoolSpec (Term (bv n)) (Term (bv n))--instance (SupportedPrim (bv n)) => Show (FixedSizedBVWithBoolSpec bv n) where-  show (FixedSizedBVWithBoolSpec n r) = "FixedSizedBVWithBoolSpec { no: " ++ pformat n ++ ", re: " ++ pformat r ++ " }"--instance (SupportedPrim (bv n)) => TermRewritingSpec (FixedSizedBVWithBoolSpec bv n) (bv n) where-  norewriteVer (FixedSizedBVWithBoolSpec n _) = n-  rewriteVer (FixedSizedBVWithBoolSpec _ r) = r-  wrap = FixedSizedBVWithBoolSpec-  same s = eqvTerm (norewriteVer s) (rewriteVer s)--data BoolWithFixedSizedBVSpec (bv :: Nat -> Type) (n :: Nat) = BoolWithFixedSizedBVSpec (Term Bool) (Term Bool)--instance Show (BoolWithFixedSizedBVSpec bv n) where-  show (BoolWithFixedSizedBVSpec n r) =-    "BoolWithFixedSizedBVSpec { no: " ++ pformat n ++ ", re: " ++ pformat r ++ " }"--instance TermRewritingSpec (BoolWithFixedSizedBVSpec bv n) Bool where-  norewriteVer (BoolWithFixedSizedBVSpec n _) = n-  rewriteVer (BoolWithFixedSizedBVSpec _ r) = r-  wrap = BoolWithFixedSizedBVSpec-  same s = eqvTerm (norewriteVer s) (rewriteVer s)--boolWithFSBV ::-  forall p1 p2 bv n.-  (SupportedBV bv n) =>-  p1 bv ->-  p2 n ->-  Int ->-  Gen (BoolWithFixedSizedBVSpec bv n)-boolWithFSBV _ _ 0 =-  let s =-        oneof $-          return . symSpec . (<> "bool")-            <$> ["a", "b", "c", "d", "e", "f", "g"]-      r = oneof $ return . conSpec <$> [True, False]-   in oneof [r, s]-boolWithFSBV pbv pn n | n > 0 = do-  v1 <- boolWithFSBV pbv pn (n - 1)-  v2 <- boolWithFSBV pbv pn (n - 1)-  v3 <- boolWithFSBV pbv pn (n - 1)-  v1i <- fsbvWithBool pbv pn (n - 1)-  v2i <- fsbvWithBool pbv pn (n - 1)-  frequency-    [ (1, return $ notSpec v1),-      (1, return $ andSpec v1 v2),-      (1, return $ orSpec v1 v2),-      (1, return $ eqvSpec v1 v2),-      (5, return $ eqvSpec v1i v2i),-      (5, return $ ltNumSpec v1i v2i),-      (5, return $ leNumSpec v1i v2i),-      (1, return $ iteSpec v1 v2 v3)-    ]-boolWithFSBV _ _ _ = error "Should never be called"--fsbvWithBool ::-  forall p1 p2 bv n.-  (SupportedBV bv n) =>-  p1 bv ->-  p2 n ->-  Int ->-  Gen (FixedSizedBVWithBoolSpec bv n)-fsbvWithBool _ _ 0 =-  let s =-        oneof $-          return . symSpec . (<> "int")-            <$> ["a", "b", "c", "d", "e", "f", "g"]-      r =-        conSpec-          <$> oneof-            [ return minBound,-              return maxBound,-              fromInteger <$> arbitrary-            ]-   in oneof [r, s]-fsbvWithBool pbv pn n | n > 0 = do-  v1b <- boolWithFSBV pbv pn (n - 1)-  v1i <- fsbvWithBool pbv pn (n - 1)-  v2i <- fsbvWithBool pbv pn (n - 1)-  oneof-    [ return $ uminusNumSpec v1i,-      return $ absNumSpec v1i,-      return $ signumNumSpec v1i,-      return $ addNumSpec v1i v2i,-      return $ timesNumSpec v1i v2i,-      return $ andBitsSpec v1i v2i,-      return $ orBitsSpec v1i v2i,-      return $ xorBitsSpec v1i v2i,-      return $ complementBitsSpec v1i,-      return $ shiftLeftSpec v1i v2i,-      return $ rotateLeftSpec v1i v2i,-      return $ shiftRightSpec v1i v2i,-      return $ rotateRightSpec v1i v2i,-      return $ iteSpec v1b v1i v2i-    ]-fsbvWithBool _ _ _ = error "Should never be called"--instance (SupportedBV bv n) => Arbitrary (BoolWithFixedSizedBVSpec bv n) where-  arbitrary = sized (boolWithFSBV (Proxy @bv) (Proxy @n))--instance (SupportedBV bv n) => Arbitrary (FixedSizedBVWithBoolSpec bv n) where-  arbitrary = sized (fsbvWithBool Proxy Proxy)--data DifferentSizeBVSpec bv (n :: Nat) = DifferentSizeBVSpec (Term (bv n)) (Term (bv n))--instance (SupportedPrim (bv n)) => Show (DifferentSizeBVSpec bv n) where-  show (DifferentSizeBVSpec n r) = "DSizeBVSpec { no: " ++ pformat n ++ ", re: " ++ pformat r ++ " }"--instance (SupportedPrim (bv n)) => TermRewritingSpec (DifferentSizeBVSpec bv n) (bv n) where-  norewriteVer (DifferentSizeBVSpec n _) = n-  rewriteVer (DifferentSizeBVSpec _ r) = r-  wrap = DifferentSizeBVSpec-  same s = eqvTerm (norewriteVer s) (rewriteVer s)--type SupportedBV bv (n :: Nat) =-  ( SupportedPrim (bv n),-    Ord (bv n),-    Num (bv n),-    FiniteBits (bv n),-    Integral (bv n),-    Bounded (bv n),-    SymShift (bv n),-    SymRotate (bv n)-  )--dsbv1 ::-  forall proxy bv.-  ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n),-    SupportedBV bv 1,-    SupportedBV bv 2,-    SupportedBV bv 3,-    SupportedBV bv 4,-    Typeable bv,-    SizedBV bv-  ) =>-  proxy bv ->-  Int ->-  Gen (DifferentSizeBVSpec bv 1)-dsbv1 _ 0 =-  let s =-        oneof $-          return . symSpec . (<> "bv1")-            <$> ["a", "b", "c", "d", "e", "f", "g"]-      r = conSpec . fromInteger <$> arbitrary-   in oneof [r, s]-dsbv1 p depth | depth > 0 = do-  v1 <- dsbv1 p (depth - 1)-  v1' <- dsbv1 p (depth - 1)-  v2 <- dsbv2 p (depth - 1)-  v3 <- dsbv3 p (depth - 1)-  v4 <- dsbv4 p (depth - 1)-  oneof-    [ return $ uminusNumSpec v1,-      return $ absNumSpec v1,-      return $ signumNumSpec v1,-      return $ addNumSpec v1 v1',-      return $ timesNumSpec v1 v1',-      return $ andBitsSpec v1 v1',-      return $ orBitsSpec v1 v1',-      return $ xorBitsSpec v1 v1',-      return $ complementBitsSpec v1,-      return $ shiftLeftSpec v1 v1',-      return $ rotateLeftSpec v1 v1',-      return $ shiftRightSpec v1 v1',-      return $ rotateRightSpec v1 v1',-      return $ bvselectSpec (Proxy @0) (Proxy @1) v4,-      return $ bvselectSpec (Proxy @1) (Proxy @1) v4,-      return $ bvselectSpec (Proxy @2) (Proxy @1) v4,-      return $ bvselectSpec (Proxy @3) (Proxy @1) v4,-      return $ bvselectSpec (Proxy @0) (Proxy @1) v3,-      return $ bvselectSpec (Proxy @1) (Proxy @1) v3,-      return $ bvselectSpec (Proxy @2) (Proxy @1) v3,-      return $ bvselectSpec (Proxy @0) (Proxy @1) v2,-      return $ bvselectSpec (Proxy @1) (Proxy @1) v2,-      return $ bvselectSpec (Proxy @0) (Proxy @1) v1-    ]-dsbv1 _ _ = error "Should never be called"--dsbv2 ::-  forall proxy bv.-  ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n),-    SupportedBV bv 1,-    SupportedBV bv 2,-    SupportedBV bv 3,-    SupportedBV bv 4,-    Typeable bv,-    SizedBV bv-  ) =>-  proxy bv ->-  Int ->-  Gen (DifferentSizeBVSpec bv 2)-dsbv2 _ 0 =-  let s =-        oneof $-          return . symSpec . (<> "bv2")-            <$> ["a", "b", "c", "d", "e", "f", "g"]-      r = conSpec . fromInteger <$> arbitrary-   in oneof [r, s]-dsbv2 p depth | depth > 0 = do-  v1 <- dsbv1 p (depth - 1)-  v1' <- dsbv1 p (depth - 1)-  v2 <- dsbv2 p (depth - 1)-  v2' <- dsbv2 p (depth - 1)-  v3 <- dsbv3 p (depth - 1)-  v4 <- dsbv4 p (depth - 1)-  oneof-    [ return $ uminusNumSpec v2,-      return $ absNumSpec v2,-      return $ signumNumSpec v2,-      return $ addNumSpec v2 v2',-      return $ timesNumSpec v2 v2',-      return $ andBitsSpec v2 v2',-      return $ orBitsSpec v2 v2',-      return $ xorBitsSpec v2 v2',-      return $ complementBitsSpec v2,-      return $ shiftLeftSpec v2 v2',-      return $ rotateLeftSpec v2 v2',-      return $ shiftRightSpec v2 v2',-      return $ rotateRightSpec v2 v2',-      return $ bvselectSpec (Proxy @0) (Proxy @2) v4,-      return $ bvselectSpec (Proxy @1) (Proxy @2) v4,-      return $ bvselectSpec (Proxy @2) (Proxy @2) v4,-      return $ bvselectSpec (Proxy @0) (Proxy @2) v3,-      return $ bvselectSpec (Proxy @1) (Proxy @2) v3,-      return $ bvselectSpec (Proxy @0) (Proxy @2) v2,-      return $ bvconcatSpec v1 v1',-      return $ bvextendSpec False (Proxy @2) v1,-      return $ bvextendSpec True (Proxy @2) v1-    ]-dsbv2 _ _ = error "Should never be called"--dsbv3 ::-  forall proxy bv.-  ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n),-    SupportedBV bv 1,-    SupportedBV bv 2,-    SupportedBV bv 3,-    SupportedBV bv 4,-    Typeable bv,-    SizedBV bv-  ) =>-  proxy bv ->-  Int ->-  Gen (DifferentSizeBVSpec bv 3)-dsbv3 _ 0 =-  let s =-        oneof $-          return . symSpec . (<> "bv3")-            <$> ["a", "b", "c", "d", "e", "f", "g"]-      r = conSpec . fromInteger <$> arbitrary-   in oneof [r, s]-dsbv3 p depth | depth > 0 = do-  v1 <- dsbv1 p (depth - 1)-  v2 <- dsbv2 p (depth - 1)-  v3 <- dsbv3 p (depth - 1)-  v3' <- dsbv3 p (depth - 1)-  v4 <- dsbv4 p (depth - 1)-  oneof-    [ return $ uminusNumSpec v3,-      return $ absNumSpec v3,-      return $ signumNumSpec v3,-      return $ addNumSpec v3 v3',-      return $ timesNumSpec v3 v3',-      return $ andBitsSpec v3 v3',-      return $ orBitsSpec v3 v3',-      return $ xorBitsSpec v3 v3',-      return $ complementBitsSpec v3,-      return $ shiftLeftSpec v3 v3',-      return $ rotateLeftSpec v3 v3',-      return $ shiftRightSpec v3 v3',-      return $ rotateRightSpec v3 v3',-      return $ bvselectSpec (Proxy @0) (Proxy @3) v4,-      return $ bvselectSpec (Proxy @1) (Proxy @3) v4,-      return $ bvselectSpec (Proxy @0) (Proxy @3) v3,-      return $ bvconcatSpec v1 v2,-      return $ bvconcatSpec v2 v1,-      return $ bvextendSpec False (Proxy @3) v1,-      return $ bvextendSpec True (Proxy @3) v1,-      return $ bvextendSpec False (Proxy @3) v2,-      return $ bvextendSpec True (Proxy @3) v2-    ]-dsbv3 _ _ = error "Should never be called"--dsbv4 ::-  forall proxy bv.-  ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n),-    SupportedBV bv 1,-    SupportedBV bv 2,-    SupportedBV bv 3,-    SupportedBV bv 4,-    Typeable bv,-    SizedBV bv-  ) =>-  proxy bv ->-  Int ->-  Gen (DifferentSizeBVSpec bv 4)-dsbv4 _ 0 =-  let s =-        oneof $-          return . symSpec . (<> "bv4")-            <$> ["a", "b", "c", "d", "e", "f", "g"]-      r = conSpec . fromInteger <$> arbitrary-   in oneof [r, s]-dsbv4 p depth | depth > 0 = do-  v1 <- dsbv1 p (depth - 1)-  v2 <- dsbv2 p (depth - 1)-  v2' <- dsbv2 p (depth - 1)-  v3 <- dsbv3 p (depth - 1)-  v4 <- dsbv4 p (depth - 1)-  v4' <- dsbv4 p (depth - 1)-  oneof-    [ return $ uminusNumSpec v4,-      return $ absNumSpec v4,-      return $ signumNumSpec v4,-      return $ addNumSpec v4 v4',-      return $ timesNumSpec v4 v4',-      return $ andBitsSpec v4 v4',-      return $ orBitsSpec v4 v4',-      return $ xorBitsSpec v4 v4',-      return $ complementBitsSpec v4,-      return $ shiftLeftSpec v4 v4',-      return $ rotateLeftSpec v4 v4',-      return $ shiftRightSpec v4 v4',-      return $ rotateRightSpec v4 v4',-      return $ bvselectSpec (Proxy @0) (Proxy @4) v4,-      return $ bvconcatSpec v1 v3,-      return $ bvconcatSpec v2 v2',-      return $ bvconcatSpec v3 v1,-      return $ bvextendSpec False (Proxy @4) v1,-      return $ bvextendSpec True (Proxy @4) v1,-      return $ bvextendSpec False (Proxy @4) v2,-      return $ bvextendSpec True (Proxy @4) v2,-      return $ bvextendSpec False (Proxy @4) v3,-      return $ bvextendSpec True (Proxy @4) v3-    ]-dsbv4 _ _ = error "Should never be called"--instance-  ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n),-    SupportedBV bv 1,-    SupportedBV bv 2,-    SupportedBV bv 3,-    SupportedBV bv 4,-    Typeable bv,-    SizedBV bv-  ) =>-  Arbitrary (DifferentSizeBVSpec bv 4)-  where-  arbitrary = sized (dsbv4 Proxy)--data GeneralSpec s = GeneralSpec (Term s) (Term s)--instance (SupportedPrim s) => Show (GeneralSpec s) where-  show (GeneralSpec n r) = "GeneralSpec { no: " ++ pformat n ++ ", re: " ++ pformat r ++ " }"--instance (SupportedPrim s) => TermRewritingSpec (GeneralSpec s) s where-  norewriteVer (GeneralSpec n _) = n-  rewriteVer (GeneralSpec _ r) = r-  wrap = GeneralSpec-  same s = eqvTerm (norewriteVer s) (rewriteVer s)
− test/Grisette/Backend/SBV/Data/SMT/TermRewritingTests.hs 
@@ -1,331 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE UndecidableInstances #-}--module Grisette.Backend.SBV.Data.SMT.TermRewritingTests-  ( termRewritingTests,-    validateSpec,-  )-where--import Data.Foldable (traverse_)-import qualified Data.SBV as SBV-import Grisette.Backend.SBV.Data.SMT.Solving-  ( GrisetteSMTConfig,-    precise,-  )-import Grisette.Backend.SBV.Data.SMT.TermRewritingGen-  ( BoolOnlySpec,-    BoolWithLIASpec,-    DifferentSizeBVSpec,-    FixedSizedBVWithBoolSpec,-    GeneralSpec,-    LIAWithBoolSpec,-    TermRewritingSpec-      ( conSpec,-        counterExample,-        norewriteVer,-        rewriteVer,-        same,-        symSpec-      ),-    absNumSpec,-    addNumSpec,-    andSpec,-    divBoundedIntegralSpec,-    divIntegralSpec,-    eqvSpec,-    iteSpec,-    modBoundedIntegralSpec,-    modIntegralSpec,-    notSpec,-    orSpec,-    quotBoundedIntegralSpec,-    quotIntegralSpec,-    remBoundedIntegralSpec,-    remIntegralSpec,-    shiftRightSpec,-    timesNumSpec,-    uminusNumSpec,-  )-import Grisette.Core.Data.BV (IntN, WordN)-import Grisette.Core.Data.Class.Solver (solve)-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term-  ( SupportedPrim,-  )-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermUtils-  ( pformat,-  )-import Grisette.IR.SymPrim.Data.SymPrim (SymBool (SymBool))-import Test.Framework (Test, TestName, testGroup)-import Test.Framework.Providers.HUnit (testCase)-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.HUnit (Assertion, assertFailure)-import Test.QuickCheck (ioProperty, mapSize, withMaxSuccess)--validateSpec :: (TermRewritingSpec a av, Show a, SupportedPrim av) => GrisetteSMTConfig n -> a -> Assertion-validateSpec config a = do-  r <- solve config (SymBool $ counterExample a)-  rs <- solve config (SymBool $ same a)-  case (r, rs) of-    (Left _, Right _) -> do-      return ()-    (Left _, Left _) -> do-      assertFailure $ "Bad rewriting with unsolvable formula: " ++ pformat (norewriteVer a) ++ " was rewritten to " ++ pformat (rewriteVer a)-    (Right m, _) -> do-      assertFailure $ "With model" ++ show m ++ "Bad rewriting: " ++ pformat (norewriteVer a) ++ " was rewritten to " ++ pformat (rewriteVer a)--unboundedConfig = precise SBV.z3--divisionTest ::-  forall a b.-  (TermRewritingSpec a b, Show a, Enum b, Num b, SupportedPrim b) =>-  TestName ->-  (a -> a -> a) ->-  Test-divisionTest name f =-  testGroup-    name-    [ testCase "on concrete" $ do-        traverse_-          ( \(x :: b, y :: b) -> do-              validateSpec @a unboundedConfig $ f (conSpec x) (conSpec y)-          )-          [(i, j) | i <- [-3 .. 3], j <- [-3 .. 3]],-      testCase "on single concrete" $ do-        traverse_-          ( \x -> do-              validateSpec @a unboundedConfig $ f (conSpec x) (symSpec "a")-              validateSpec @a unboundedConfig $ f (symSpec "a") (conSpec x)-          )-          [-3 .. 3]-    ]--termRewritingTests :: Test-termRewritingTests =-  testGroup-    "TermRewriting"-    [ testGroup-        "Bool only"-        [ testProperty "Bool only random test" $-            mapSize (`min` 10) $-              ioProperty . \(x :: BoolOnlySpec) -> do-                validateSpec unboundedConfig x,-          testCase "Regression nested ite with (ite a (ite b c d) e) with b is true" $ do-            validateSpec @BoolOnlySpec-              unboundedConfig-              ( iteSpec-                  (symSpec "a" :: BoolOnlySpec)-                  ( iteSpec-                      (orSpec (notSpec (andSpec (symSpec "b1") (symSpec "b2"))) (symSpec "b2") :: BoolOnlySpec)-                      (symSpec "c")-                      (symSpec "d")-                  )-                  (symSpec "e")-              ),-          testCase "Regression for pevalImpliesTerm _ false should be false" $ do-            validateSpec @BoolOnlySpec-              unboundedConfig-              ( iteSpec-                  (symSpec "fbool" :: BoolOnlySpec)-                  ( notSpec-                      ( orSpec-                          (orSpec (notSpec (andSpec (symSpec "gbool" :: BoolOnlySpec) (symSpec "fbool" :: BoolOnlySpec))) (symSpec "gbool" :: BoolOnlySpec))-                          (orSpec (symSpec "abool" :: BoolOnlySpec) (notSpec (andSpec (symSpec "gbool" :: BoolOnlySpec) (symSpec "bbool" :: BoolOnlySpec))))-                      )-                  )-                  (symSpec "xxx" :: BoolOnlySpec)-              )-        ],-      testGroup-        "LIA"-        [ testProperty "LIA random test" $-            mapSize (`min` 10) $-              ioProperty . \(x :: LIAWithBoolSpec) -> do-                validateSpec unboundedConfig x,-          testCase "Regression nested ite with (ite a b (ite c d e)) with c implies a" $ do-            validateSpec @LIAWithBoolSpec-              unboundedConfig-              ( iteSpec-                  (notSpec (eqvSpec (symSpec "v" :: LIAWithBoolSpec) (conSpec 1 :: LIAWithBoolSpec) :: BoolWithLIASpec))-                  (symSpec "b")-                  ( iteSpec-                      (eqvSpec (symSpec "v" :: LIAWithBoolSpec) (conSpec 2 :: LIAWithBoolSpec) :: BoolWithLIASpec)-                      (symSpec "d")-                      (symSpec "d")-                  )-              )-        ],-      testGroup-        "Different sized signed BV"-        [ testProperty "Random test" $-            withMaxSuccess 1000 . mapSize (`min` 5) $-              ioProperty . \(x :: (DifferentSizeBVSpec IntN 4)) -> do-                validateSpec unboundedConfig x-        ],-      testGroup-        "Fixed sized signed BV"-        [ testProperty "Random test on IntN 1" $-            withMaxSuccess 200 . mapSize (`min` 5) $-              ioProperty . \(x :: (FixedSizedBVWithBoolSpec IntN 1)) -> do-                validateSpec unboundedConfig x,-          testProperty "Random test on IntN 2" $-            withMaxSuccess 200 . mapSize (`min` 5) $-              ioProperty . \(x :: (FixedSizedBVWithBoolSpec IntN 2)) -> do-                validateSpec unboundedConfig x,-          testProperty "Random test on IntN 4" $-            withMaxSuccess 200 . mapSize (`min` 5) $-              ioProperty . \(x :: (FixedSizedBVWithBoolSpec IntN 4)) -> do-                validateSpec unboundedConfig x,-          testProperty "Random test on IntN 63" $-            withMaxSuccess 200 . mapSize (`min` 1) $-              ioProperty . \(x :: (FixedSizedBVWithBoolSpec IntN 63)) -> do-                validateSpec unboundedConfig x,-          testProperty "Random test on IntN 64" $-            withMaxSuccess 200 . mapSize (`min` 1) $-              ioProperty . \(x :: (FixedSizedBVWithBoolSpec IntN 64)) -> do-                validateSpec unboundedConfig x,-          testProperty "Random test on IntN 65" $-            withMaxSuccess 200 . mapSize (`min` 1) $-              ioProperty . \(x :: (FixedSizedBVWithBoolSpec IntN 65)) -> do-                validateSpec unboundedConfig x,-          testProperty "Random test on IntN 128" $-            withMaxSuccess 200 . mapSize (`min` 1) $-              ioProperty . \(x :: (FixedSizedBVWithBoolSpec IntN 128)) -> do-                validateSpec unboundedConfig x-        ],-      testGroup-        "Different sized unsigned BV"-        [ testProperty "random test" $-            withMaxSuccess 1000 . mapSize (`min` 5) $-              ioProperty . \(x :: (DifferentSizeBVSpec WordN 4)) -> do-                validateSpec unboundedConfig x-        ],-      testGroup-        "Fixed sized unsigned BV"-        [ testProperty "Random test on WordN 1" $-            withMaxSuccess 200 . mapSize (`min` 5) $-              ioProperty . \(x :: (FixedSizedBVWithBoolSpec WordN 1)) -> do-                validateSpec unboundedConfig x,-          testProperty "Random test on WordN 2" $-            withMaxSuccess 200 . mapSize (`min` 5) $-              ioProperty . \(x :: (FixedSizedBVWithBoolSpec WordN 2)) -> do-                validateSpec unboundedConfig x,-          testProperty "Random test on WordN 4" $-            withMaxSuccess 200 . mapSize (`min` 5) $-              ioProperty . \(x :: (FixedSizedBVWithBoolSpec WordN 4)) -> do-                validateSpec unboundedConfig x,-          testProperty "Random test on WordN 63" $-            withMaxSuccess 200 . mapSize (`min` 1) $-              ioProperty . \(x :: (FixedSizedBVWithBoolSpec WordN 63)) -> do-                validateSpec unboundedConfig x,-          testProperty "Random test on WordN 64" $-            withMaxSuccess 200 . mapSize (`min` 1) $-              ioProperty . \(x :: (FixedSizedBVWithBoolSpec WordN 64)) -> do-                validateSpec unboundedConfig x,-          testProperty "Random test on WordN 65" $-            withMaxSuccess 200 . mapSize (`min` 1) $-              ioProperty . \(x :: (FixedSizedBVWithBoolSpec WordN 65)) -> do-                validateSpec unboundedConfig x,-          testProperty "Random test on WordN 128" $-            withMaxSuccess 200 . mapSize (`min` 1) $-              ioProperty . \(x :: (FixedSizedBVWithBoolSpec WordN 128)) -> do-                validateSpec unboundedConfig x-        ],-      testCase "Regression: shift twice and the sum of shift amount overflows" $ do-        validateSpec @(FixedSizedBVWithBoolSpec IntN 4)-          unboundedConfig-          ( shiftRightSpec-              (shiftRightSpec (symSpec "fint") (conSpec 0x5))-              (conSpec 0x5)-          ),-      testGroup-        "Regression for abs on unsigned BV"-        [ testCase "abs on negate" $-            validateSpec @(FixedSizedBVWithBoolSpec WordN 4)-              unboundedConfig-              (absNumSpec (uminusNumSpec (symSpec "a"))),-          testCase "abs on times negate" $-            validateSpec @(FixedSizedBVWithBoolSpec WordN 4)-              unboundedConfig-              (absNumSpec (timesNumSpec (symSpec "a") (uminusNumSpec (symSpec "b"))))-        ],-      testGroup-        "timesNumSpec on integer"-        [ testCase "times on both concrete" $ do-            traverse_-              (\(x, y) -> validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (conSpec x) (conSpec y))-              [(i, j) | i <- [-3 .. 3], j <- [-3 .. 3]],-          testCase "times on single concrete" $ do-            traverse_-              ( \x -> do-                  validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (conSpec x) (symSpec "a")-                  validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (symSpec "a") (conSpec x)-              )-              [-3 .. 3],-          testCase "Two times with two concrete combined" $ do-            traverse_-              ( \(x, y) -> do-                  validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (conSpec x) $ timesNumSpec (conSpec y) (symSpec "a")-                  validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (conSpec x) $ timesNumSpec (symSpec "a") (conSpec y)-                  validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (timesNumSpec (conSpec x) (symSpec "a")) (conSpec y)-                  validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (timesNumSpec (symSpec "a") (conSpec x)) (conSpec y)-              )-              [(i, j) | i <- [-3 .. 3], j <- [-3 .. 3]],-          testCase "Two times with one concrete" $ do-            traverse_-              ( \x -> do-                  validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (conSpec x) $ timesNumSpec (symSpec "b") (symSpec "a")-                  validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (symSpec "b") $ timesNumSpec (symSpec "a") (conSpec x)-                  validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (symSpec "b") $ timesNumSpec (conSpec x) (symSpec "a")-                  validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (timesNumSpec (conSpec x) (symSpec "a")) (symSpec "b")-                  validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (timesNumSpec (symSpec "a") (conSpec x)) (symSpec "b")-                  validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (timesNumSpec (symSpec "a") (symSpec "b")) (conSpec x)-              )-              [-3 .. 3],-          testCase "times and add with two concretes combined" $ do-            traverse_-              ( \(x, y) -> do-                  validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (conSpec x) $ addNumSpec (conSpec y) (symSpec "a")-                  validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (conSpec x) $ addNumSpec (symSpec "a") (conSpec y)-                  validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (addNumSpec (conSpec x) (symSpec "a")) (conSpec y)-                  validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (addNumSpec (symSpec "a") (conSpec x)) (conSpec y)-                  validateSpec @(GeneralSpec Integer) unboundedConfig $ addNumSpec (conSpec x) $ timesNumSpec (conSpec y) (symSpec "a")-                  validateSpec @(GeneralSpec Integer) unboundedConfig $ addNumSpec (conSpec x) $ timesNumSpec (symSpec "a") (conSpec y)-                  validateSpec @(GeneralSpec Integer) unboundedConfig $ addNumSpec (timesNumSpec (conSpec x) (symSpec "a")) (conSpec y)-                  validateSpec @(GeneralSpec Integer) unboundedConfig $ addNumSpec (timesNumSpec (symSpec "a") (conSpec x)) (conSpec y)-              )-              [(i, j) | i <- [-3 .. 3], j <- [-3 .. 3]],-          testCase "times concrete with uminusNumSpec symbolic" $ do-            traverse_-              ( \x -> do-                  validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (conSpec x) (uminusNumSpec $ symSpec "a")-                  validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (uminusNumSpec $ symSpec "a") (conSpec x)-              )-              [-3 .. 3]-        ],-      testGroup-        "divisions on integer"-        [ divisionTest @(GeneralSpec Integer) "div" divIntegralSpec,-          divisionTest @(GeneralSpec Integer) "mod" modIntegralSpec,-          divisionTest @(GeneralSpec Integer) "quot" quotIntegralSpec,-          divisionTest @(GeneralSpec Integer) "rem" remIntegralSpec-        ],-      testGroup-        "divisions on signed bv"-        [ divisionTest @(GeneralSpec (IntN 4)) "div" divBoundedIntegralSpec,-          divisionTest @(GeneralSpec (IntN 4)) "mod" modBoundedIntegralSpec,-          divisionTest @(GeneralSpec (IntN 4)) "quot" quotBoundedIntegralSpec,-          divisionTest @(GeneralSpec (IntN 4)) "rem" remBoundedIntegralSpec-        ],-      testGroup-        "divisions on unsigned bv"-        [ divisionTest @(GeneralSpec (WordN 4)) "div" divIntegralSpec,-          divisionTest @(GeneralSpec (WordN 4)) "mod" modIntegralSpec,-          divisionTest @(GeneralSpec (WordN 4)) "quot" quotIntegralSpec,-          divisionTest @(GeneralSpec (WordN 4)) "rem" remIntegralSpec-        ]-    ]
+ test/Grisette/Backend/TermRewritingGen.hs view
@@ -0,0 +1,1293 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BinaryLiterals #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Grisette.Backend.TermRewritingGen+  ( TermRewritingSpec (..),+    GeneralSpec (..),+    DifferentSizeBVSpec (..),+    FixedSizedBVWithBoolSpec (..),+    BoolWithFixedSizedBVSpec (..),+    BoolWithLIASpec (..),+    LIAWithBoolSpec (..),+    BoolWithNRASpec (..),+    NRAWithBoolSpec (..),+    BoolOnlySpec (..),+    constructUnarySpec,+    constructBinarySpec,+    constructTernarySpec,+    divIntegralSpec,+    modIntegralSpec,+    quotIntegralSpec,+    remIntegralSpec,+    negNumSpec,+    mulNumSpec,+    addNumSpec,+    absNumSpec,+    signumNumSpec,+    ltOrdSpec,+    leOrdSpec,+    iteSpec,+    eqvSpec,+    distinctSpec,+    notSpec,+    andSpec,+    orSpec,+    shiftLeftSpec,+    shiftRightSpec,+    rotateLeftSpec,+    rotateRightSpec,+    fpTraitSpec,+    fdivSpec,+    recipSpec,+    floatingUnarySpec,+    powerSpec,+    fpUnaryOpSpec,+    fpBinaryOpSpec,+    fpRoundingUnaryOpSpec,+    fpRoundingBinarySpec,+    fpFMASpec,+    bitCastSpec,+    bitCastOrSpec,+    fromFPOrSpec,+    toFPSpec,+    bvconcatSpec,+    bvselectSpec,+    bvextendSpec,+    andBitsSpec,+    orBitsSpec,+    xorBitsSpec,+    complementBitsSpec,+    IEEEFPSpec (..),+    IEEEFPBoolOpSpec (..),+    FPRoundingModeSpec (..),+    FPRoundingModeBoolOpSpec (..),+  )+where++import Data.Bits (FiniteBits)+import Data.Data (Proxy (Proxy), Typeable)+import Data.Functor ((<&>))+import Data.Kind (Type)+import Data.List.NonEmpty (NonEmpty ((:|)))+import qualified Data.Text as T+import GHC.TypeLits (KnownNat, Nat, type (+), type (<=))+import Grisette+  ( Identifier,+    SExpr (Atom),+    SizedBV,+    SymRotate,+    SymShift,+    withMetadata,+  )+import Grisette.Internal.SymPrim.AlgReal (AlgReal)+import Grisette.Internal.SymPrim.FP+  ( FP,+    FPRoundingMode (RNA, RNE, RTN, RTP, RTZ),+    ValidFP,+  )+import Grisette.Internal.SymPrim.Prim.Internal.Term+  ( FPBinaryOp (FPMaximum, FPMaximumNumber, FPMinimum, FPMinimumNumber, FPRem),+    FPRoundingBinaryOp (FPAdd, FPDiv, FPMul, FPSub),+    FPRoundingUnaryOp (FPRoundToIntegral, FPSqrt),+    FPUnaryOp (FPAbs, FPNeg),+    FloatingUnaryOp (FloatingSqrt),+    PEvalBitCastOrTerm (pevalBitCastOrTerm),+    PEvalBitCastTerm (pevalBitCastTerm),+    PEvalFloatingTerm (pevalFloatingUnaryTerm, pevalPowerTerm),+    PEvalFractionalTerm (pevalRecipTerm),+    PEvalIEEEFPConvertibleTerm (pevalFromFPOrTerm, pevalToFPTerm),+    SupportedPrim (pevalDistinctTerm),+    bitCastOrTerm,+    bitCastTerm,+    fdivTerm,+    floatingUnaryTerm,+    fpBinaryTerm,+    fpFMATerm,+    fpRoundingBinaryTerm,+    fpRoundingUnaryTerm,+    fpUnaryTerm,+    fromFPOrTerm,+    powerTerm,+    toFPTerm,+  )+import Grisette.Internal.SymPrim.Prim.Term+  ( FPTrait+      ( FPIsInfinite,+        FPIsNaN,+        FPIsNegative,+        FPIsNegativeInfinite,+        FPIsNegativeZero,+        FPIsNormal,+        FPIsPoint,+        FPIsPositive,+        FPIsPositiveInfinite,+        FPIsPositiveZero,+        FPIsSubnormal,+        FPIsZero+      ),+    PEvalBVTerm+      ( pevalBVConcatTerm,+        pevalBVExtendTerm,+        pevalBVSelectTerm+      ),+    PEvalBitwiseTerm+      ( pevalAndBitsTerm,+        pevalComplementBitsTerm,+        pevalOrBitsTerm,+        pevalXorBitsTerm+      ),+    PEvalDivModIntegralTerm+      ( pevalDivIntegralTerm,+        pevalModIntegralTerm,+        pevalQuotIntegralTerm,+        pevalRemIntegralTerm+      ),+    PEvalFractionalTerm (pevalFdivTerm),+    PEvalNumTerm+      ( pevalAbsNumTerm,+        pevalAddNumTerm,+        pevalMulNumTerm,+        pevalNegNumTerm,+        pevalSignumNumTerm+      ),+    PEvalOrdTerm (pevalLeOrdTerm, pevalLtOrdTerm),+    PEvalRotateTerm+      ( pevalRotateLeftTerm,+        pevalRotateRightTerm+      ),+    PEvalShiftTerm+      ( pevalShiftLeftTerm,+        pevalShiftRightTerm+      ),+    SupportedNonFuncPrim,+    SupportedPrim (pevalITETerm),+    Term,+    absNumTerm,+    addNumTerm,+    andBitsTerm,+    andTerm,+    bvConcatTerm,+    bvExtendTerm,+    bvSelectTerm,+    complementBitsTerm,+    conTerm,+    distinctTerm,+    divIntegralTerm,+    eqTerm,+    fpTraitTerm,+    iteTerm,+    leOrdTerm,+    ltOrdTerm,+    modIntegralTerm,+    mulNumTerm,+    negNumTerm,+    notTerm,+    orBitsTerm,+    orTerm,+    pevalAndTerm,+    pevalEqTerm,+    pevalFPBinaryTerm,+    pevalFPFMATerm,+    pevalFPRoundingBinaryTerm,+    pevalFPRoundingUnaryTerm,+    pevalFPTraitTerm,+    pevalFPUnaryTerm,+    pevalNotTerm,+    pevalOrTerm,+    pformatTerm,+    quotIntegralTerm,+    recipTerm,+    remIntegralTerm,+    rotateLeftTerm,+    rotateRightTerm,+    shiftLeftTerm,+    shiftRightTerm,+    signumNumTerm,+    ssymTerm,+    xorBitsTerm,+  )+import Test.QuickCheck (Arbitrary (arbitrary), Gen, elements, frequency, oneof, sized)++-- import Grisette.Internal.SymPrim.FP (FPRoundingMode(RNE))++class (SupportedNonFuncPrim b) => TermRewritingSpec a b | a -> b where+  norewriteVer :: a -> Term b+  rewriteVer :: a -> Term b+  wrap :: Term b -> Term b -> a+  same :: a -> Term Bool+  counterExample :: a -> Term Bool+  counterExample = notTerm . same+  symSpec :: Identifier -> a+  symSpec s = wrap (ssymTerm s) (ssymTerm s)+  conSpec :: b -> a+  conSpec v = wrap (conTerm v) (conTerm v)++constructUnarySpec ::+  forall a av b bv.+  ( TermRewritingSpec a av,+    TermRewritingSpec b bv+  ) =>+  (Term av -> Term bv) ->+  (Term av -> Term bv) ->+  a ->+  b+constructUnarySpec construct partial a =+  wrap (construct $ norewriteVer a) (partial $ rewriteVer a)++constructBinarySpec ::+  forall a av b bv c cv.+  ( TermRewritingSpec a av,+    TermRewritingSpec b bv,+    TermRewritingSpec c cv+  ) =>+  (Term av -> Term bv -> Term cv) ->+  (Term av -> Term bv -> Term cv) ->+  a ->+  b ->+  c+constructBinarySpec construct partial a b =+  wrap+    (construct (norewriteVer a) (norewriteVer b))+    (partial (rewriteVer a) (rewriteVer b))++constructTernarySpec ::+  forall a av b bv c cv d dv.+  ( TermRewritingSpec a av,+    TermRewritingSpec b bv,+    TermRewritingSpec c cv,+    TermRewritingSpec d dv+  ) =>+  (Term av -> Term bv -> Term cv -> Term dv) ->+  (Term av -> Term bv -> Term cv -> Term dv) ->+  a ->+  b ->+  c ->+  d+constructTernarySpec construct partial a b c =+  wrap+    (construct (norewriteVer a) (norewriteVer b) (norewriteVer c))+    (partial (rewriteVer a) (rewriteVer b) (rewriteVer c))++notSpec :: (TermRewritingSpec a Bool) => a -> a+notSpec = constructUnarySpec notTerm pevalNotTerm++andSpec :: (TermRewritingSpec a Bool) => a -> a -> a+andSpec = constructBinarySpec andTerm pevalAndTerm++orSpec :: (TermRewritingSpec a Bool) => a -> a -> a+orSpec = constructBinarySpec orTerm pevalOrTerm++eqvSpec :: (TermRewritingSpec a av, TermRewritingSpec b Bool) => a -> a -> b+eqvSpec = constructBinarySpec eqTerm pevalEqTerm++distinctSpec ::+  (TermRewritingSpec a av, TermRewritingSpec b Bool) => NonEmpty a -> b+distinctSpec l =+  wrap+    (distinctTerm (norewriteVer <$> l))+    (pevalDistinctTerm (rewriteVer <$> l))++iteSpec :: (TermRewritingSpec a Bool, TermRewritingSpec b bv) => a -> b -> b -> b+iteSpec = constructTernarySpec iteTerm pevalITETerm++addNumSpec :: (TermRewritingSpec a av, PEvalNumTerm av) => a -> a -> a+addNumSpec = constructBinarySpec addNumTerm pevalAddNumTerm++negNumSpec :: (TermRewritingSpec a av, PEvalNumTerm av) => a -> a+negNumSpec = constructUnarySpec negNumTerm pevalNegNumTerm++mulNumSpec :: (TermRewritingSpec a av, PEvalNumTerm av) => a -> a -> a+mulNumSpec = constructBinarySpec mulNumTerm pevalMulNumTerm++absNumSpec :: (TermRewritingSpec a av, PEvalNumTerm av) => a -> a+absNumSpec = constructUnarySpec absNumTerm pevalAbsNumTerm++signumNumSpec :: (TermRewritingSpec a av, PEvalNumTerm av) => a -> a+signumNumSpec = constructUnarySpec signumNumTerm pevalSignumNumTerm++bitCastSpec ::+  ( TermRewritingSpec a av,+    TermRewritingSpec b bv,+    PEvalBitCastTerm av bv+  ) =>+  a ->+  b+bitCastSpec = constructUnarySpec bitCastTerm pevalBitCastTerm++bitCastOrSpec ::+  ( TermRewritingSpec a av,+    TermRewritingSpec b bv,+    PEvalBitCastOrTerm av bv+  ) =>+  b ->+  a ->+  b+bitCastOrSpec = constructBinarySpec bitCastOrTerm pevalBitCastOrTerm++ltOrdSpec ::+  (TermRewritingSpec a av, PEvalOrdTerm av, TermRewritingSpec b Bool) =>+  a ->+  a ->+  b+ltOrdSpec = constructBinarySpec ltOrdTerm pevalLtOrdTerm++leOrdSpec ::+  (TermRewritingSpec a av, PEvalOrdTerm av, TermRewritingSpec b Bool) =>+  a ->+  a ->+  b+leOrdSpec = constructBinarySpec leOrdTerm pevalLeOrdTerm++andBitsSpec :: (TermRewritingSpec a av, PEvalBitwiseTerm av) => a -> a -> a+andBitsSpec = constructBinarySpec andBitsTerm pevalAndBitsTerm++orBitsSpec :: (TermRewritingSpec a av, PEvalBitwiseTerm av) => a -> a -> a+orBitsSpec = constructBinarySpec orBitsTerm pevalOrBitsTerm++xorBitsSpec :: (TermRewritingSpec a av, PEvalBitwiseTerm av) => a -> a -> a+xorBitsSpec = constructBinarySpec xorBitsTerm pevalXorBitsTerm++complementBitsSpec :: (TermRewritingSpec a av, PEvalBitwiseTerm av) => a -> a+complementBitsSpec = constructUnarySpec complementBitsTerm pevalComplementBitsTerm++shiftLeftSpec :: (TermRewritingSpec a av, PEvalShiftTerm av) => a -> a -> a+shiftLeftSpec = constructBinarySpec shiftLeftTerm pevalShiftLeftTerm++shiftRightSpec :: (TermRewritingSpec a av, PEvalShiftTerm av) => a -> a -> a+shiftRightSpec = constructBinarySpec shiftRightTerm pevalShiftRightTerm++rotateLeftSpec :: (TermRewritingSpec a av, PEvalRotateTerm av) => a -> a -> a+rotateLeftSpec = constructBinarySpec rotateLeftTerm pevalRotateLeftTerm++rotateRightSpec :: (TermRewritingSpec a av, PEvalRotateTerm av) => a -> a -> a+rotateRightSpec = constructBinarySpec rotateRightTerm pevalRotateRightTerm++bvconcatSpec ::+  ( TermRewritingSpec a (bv an),+    TermRewritingSpec b (bv bn),+    TermRewritingSpec c (bv (an + bn)),+    PEvalBVTerm bv,+    KnownNat an,+    KnownNat bn,+    KnownNat (an + bn),+    1 <= an,+    1 <= bn,+    1 <= an + bn+  ) =>+  a ->+  b ->+  c+bvconcatSpec = constructBinarySpec bvConcatTerm pevalBVConcatTerm++bvselectSpec ::+  ( TermRewritingSpec a (bv an),+    TermRewritingSpec b (bv bn),+    PEvalBVTerm bv,+    KnownNat an,+    KnownNat ix,+    KnownNat bn,+    1 <= an,+    1 <= bn,+    ix + bn <= an+  ) =>+  proxy ix ->+  proxy bn ->+  a ->+  b+bvselectSpec p1 p2 = constructUnarySpec (bvSelectTerm p1 p2) (pevalBVSelectTerm p1 p2)++bvextendSpec ::+  ( TermRewritingSpec a (bv an),+    TermRewritingSpec b (bv bn),+    PEvalBVTerm bv,+    KnownNat an,+    KnownNat bn,+    1 <= an,+    1 <= bn,+    an <= bn+  ) =>+  Bool ->+  proxy bn ->+  a ->+  b+bvextendSpec signed p = constructUnarySpec (bvExtendTerm signed p) (pevalBVExtendTerm signed p)++divIntegralSpec :: (TermRewritingSpec a b, PEvalDivModIntegralTerm b) => a -> a -> a+divIntegralSpec = constructBinarySpec divIntegralTerm pevalDivIntegralTerm++modIntegralSpec :: (TermRewritingSpec a b, PEvalDivModIntegralTerm b) => a -> a -> a+modIntegralSpec = constructBinarySpec modIntegralTerm pevalModIntegralTerm++quotIntegralSpec :: (TermRewritingSpec a b, PEvalDivModIntegralTerm b) => a -> a -> a+quotIntegralSpec = constructBinarySpec quotIntegralTerm pevalQuotIntegralTerm++remIntegralSpec :: (TermRewritingSpec a b, PEvalDivModIntegralTerm b) => a -> a -> a+remIntegralSpec = constructBinarySpec remIntegralTerm pevalRemIntegralTerm++fpTraitSpec ::+  ( ValidFP eb fb,+    TermRewritingSpec a (FP eb fb),+    TermRewritingSpec b Bool+  ) =>+  FPTrait ->+  a ->+  b+fpTraitSpec trait = constructUnarySpec (fpTraitTerm trait) (pevalFPTraitTerm trait)++fdivSpec :: (TermRewritingSpec a av, PEvalFractionalTerm av) => a -> a -> a+fdivSpec = constructBinarySpec fdivTerm pevalFdivTerm++recipSpec :: (TermRewritingSpec a av, PEvalFractionalTerm av) => a -> a+recipSpec = constructUnarySpec recipTerm pevalRecipTerm++floatingUnarySpec ::+  (TermRewritingSpec a av, PEvalFloatingTerm av) => FloatingUnaryOp -> a -> a+floatingUnarySpec op =+  constructUnarySpec+    (floatingUnaryTerm op)+    (pevalFloatingUnaryTerm op)++powerSpec ::+  (TermRewritingSpec a av, PEvalFloatingTerm av) => a -> a -> a+powerSpec = constructBinarySpec powerTerm pevalPowerTerm++fpUnaryOpSpec ::+  ( ValidFP eb fb,+    TermRewritingSpec a (FP eb fb)+  ) =>+  FPUnaryOp ->+  a ->+  a+fpUnaryOpSpec op = constructUnarySpec (fpUnaryTerm op) (pevalFPUnaryTerm op)++fpBinaryOpSpec ::+  ( ValidFP eb fb,+    TermRewritingSpec a (FP eb fb)+  ) =>+  FPBinaryOp ->+  a ->+  a ->+  a+fpBinaryOpSpec op = constructBinarySpec (fpBinaryTerm op) (pevalFPBinaryTerm op)++fpRoundingUnaryOpSpec ::+  ( ValidFP eb fb,+    TermRewritingSpec a (FP eb fb),+    TermRewritingSpec r FPRoundingMode+  ) =>+  FPRoundingUnaryOp ->+  r ->+  a ->+  a+fpRoundingUnaryOpSpec op =+  constructBinarySpec (fpRoundingUnaryTerm op) (pevalFPRoundingUnaryTerm op)++fpRoundingBinarySpec ::+  ( ValidFP eb fb,+    TermRewritingSpec a (FP eb fb),+    TermRewritingSpec r FPRoundingMode+  ) =>+  FPRoundingBinaryOp ->+  r ->+  a ->+  a ->+  a+fpRoundingBinarySpec op =+  constructTernarySpec (fpRoundingBinaryTerm op) (pevalFPRoundingBinaryTerm op)++fpFMASpec ::+  ( ValidFP eb fb,+    TermRewritingSpec a (FP eb fb),+    TermRewritingSpec r FPRoundingMode+  ) =>+  r ->+  a ->+  a ->+  a ->+  a+fpFMASpec a b c d =+  wrap+    (fpFMATerm (norewriteVer a) (norewriteVer b) (norewriteVer c) (norewriteVer d))+    (pevalFPFMATerm (rewriteVer a) (rewriteVer b) (rewriteVer c) (norewriteVer d))++fromFPOrSpec ::+  ( ValidFP eb fb,+    TermRewritingSpec a (FP eb fb),+    TermRewritingSpec rd FPRoundingMode,+    TermRewritingSpec b i,+    PEvalIEEEFPConvertibleTerm i+  ) =>+  b ->+  rd ->+  a ->+  b+fromFPOrSpec = constructTernarySpec fromFPOrTerm pevalFromFPOrTerm++toFPSpec ::+  ( ValidFP eb fb,+    TermRewritingSpec a (FP eb fb),+    TermRewritingSpec rd FPRoundingMode,+    TermRewritingSpec b i,+    PEvalIEEEFPConvertibleTerm i+  ) =>+  rd ->+  b ->+  a+toFPSpec = constructBinarySpec toFPTerm pevalToFPTerm++data BoolOnlySpec = BoolOnlySpec (Term Bool) (Term Bool)++instance Show BoolOnlySpec where+  show (BoolOnlySpec n r) = "BoolOnlySpec { no: " ++ pformatTerm n ++ ", re: " ++ pformatTerm r ++ " }"++instance TermRewritingSpec BoolOnlySpec Bool where+  norewriteVer (BoolOnlySpec n _) = n+  rewriteVer (BoolOnlySpec _ r) = r+  wrap = BoolOnlySpec+  same s = eqTerm (norewriteVer s) (rewriteVer s)++boolonly :: Int -> Gen BoolOnlySpec+boolonly 0 =+  let s =+        oneof $+          return . symSpec . (`withMetadata` (Atom ("bool" :: T.Text)))+            <$> ["a", "b", "c", "d", "e", "f", "g"]+      r = oneof $ return . conSpec <$> [True, False]+   in oneof [r, s]+boolonly n | n > 0 = do+  v1 <- boolonly (n - 1)+  v2 <- boolonly (n - 1)+  v3 <- boolonly (n - 1)+  oneof+    [ return $ notSpec v1,+      return $ andSpec v1 v2,+      return $ orSpec v1 v2,+      return $ eqvSpec v1 v2,+      return $ distinctSpec $ v1 :| [],+      return $ distinctSpec $ v1 :| [v2],+      return $ distinctSpec $ v1 :| [v2, v3],+      return $ iteSpec v1 v2 v3+    ]+boolonly _ = error "Should never be called"++instance Arbitrary BoolOnlySpec where+  arbitrary = sized boolonly++data BoolWithLIASpec = BoolWithLIASpec (Term Bool) (Term Bool)++instance Show BoolWithLIASpec where+  show (BoolWithLIASpec n r) = "BoolWithLIASpec { no: " ++ pformatTerm n ++ ", re: " ++ pformatTerm r ++ " }"++instance TermRewritingSpec BoolWithLIASpec Bool where+  norewriteVer (BoolWithLIASpec n _) = n+  rewriteVer (BoolWithLIASpec _ r) = r+  wrap = BoolWithLIASpec+  same s = eqTerm (norewriteVer s) (rewriteVer s)++data LIAWithBoolSpec = LIAWithBoolSpec (Term Integer) (Term Integer)++instance Show LIAWithBoolSpec where+  show (LIAWithBoolSpec n r) =+    "LIAWithBoolSpec { no: " ++ pformatTerm n ++ ", re: " ++ pformatTerm r ++ " }"++instance TermRewritingSpec LIAWithBoolSpec Integer where+  norewriteVer (LIAWithBoolSpec n _) = n+  rewriteVer (LIAWithBoolSpec _ r) = r+  wrap = LIAWithBoolSpec+  same s = eqTerm (norewriteVer s) (rewriteVer s)++boolWithLIA :: Int -> Gen BoolWithLIASpec+boolWithLIA 0 =+  let s =+        oneof $+          return . symSpec . (`withMetadata` (Atom ("bool" :: T.Text)))+            <$> ["a", "b", "c", "d", "e", "f", "g"]+      r = oneof $ return . conSpec <$> [True, False]+   in oneof [r, s]+boolWithLIA n | n > 0 = do+  v1 <- boolWithLIA (n - 1)+  v2 <- boolWithLIA (n - 1)+  v3 <- boolWithLIA (n - 1)+  v1i <- liaWithBool (n - 1)+  v2i <- liaWithBool (n - 1)+  v3i <- liaWithBool (n - 1)+  frequency+    [ (1, return $ notSpec v1),+      (1, return $ andSpec v1 v2),+      (1, return $ orSpec v1 v2),+      (1, return $ eqvSpec v1 v2),+      (4, return $ eqvSpec v1i v2i),+      (1, return $ distinctSpec $ v1 :| []),+      (1, return $ distinctSpec $ v1 :| [v2]),+      (1, return $ distinctSpec $ v1 :| [v2, v3]),+      (2, return $ distinctSpec $ v1i :| []),+      (2, return $ distinctSpec $ v1i :| [v2i]),+      (2, return $ distinctSpec $ v1i :| [v2i, v3i]),+      (5, return $ ltOrdSpec v1i v2i),+      (5, return $ leOrdSpec v1i v2i),+      (1, return $ iteSpec v1 v2 v3)+    ]+boolWithLIA _ = error "Should never be called"++liaWithBool :: Int -> Gen LIAWithBoolSpec+liaWithBool 0 =+  let s =+        oneof $+          return . symSpec . (`withMetadata` (Atom ("int" :: T.Text)))+            <$> ["a", "b", "c", "d", "e", "f", "g"]+      r = conSpec <$> arbitrary+   in oneof [r, s]+liaWithBool n | n > 0 = do+  v1b <- boolWithLIA (n - 1)+  v1i <- liaWithBool (n - 1)+  v2i <- liaWithBool (n - 1)+  oneof+    [ return $ negNumSpec v1i,+      return $ absNumSpec v1i,+      return $ signumNumSpec v1i,+      return $ addNumSpec v1i v2i,+      return $ iteSpec v1b v1i v2i+    ]+liaWithBool _ = error "Should never be called"++instance Arbitrary BoolWithLIASpec where+  arbitrary = sized boolWithLIA++instance Arbitrary LIAWithBoolSpec where+  arbitrary = sized liaWithBool++data FixedSizedBVWithBoolSpec (bv :: Nat -> Type) (n :: Nat) = FixedSizedBVWithBoolSpec (Term (bv n)) (Term (bv n))++instance (SupportedNonFuncPrim (bv n)) => Show (FixedSizedBVWithBoolSpec bv n) where+  show (FixedSizedBVWithBoolSpec n r) = "FixedSizedBVWithBoolSpec { no: " ++ pformatTerm n ++ ", re: " ++ pformatTerm r ++ " }"++instance (SupportedNonFuncPrim (bv n)) => TermRewritingSpec (FixedSizedBVWithBoolSpec bv n) (bv n) where+  norewriteVer (FixedSizedBVWithBoolSpec n _) = n+  rewriteVer (FixedSizedBVWithBoolSpec _ r) = r+  wrap = FixedSizedBVWithBoolSpec+  same s = eqTerm (norewriteVer s) (rewriteVer s)++data BoolWithFixedSizedBVSpec (bv :: Nat -> Type) (n :: Nat) = BoolWithFixedSizedBVSpec (Term Bool) (Term Bool)++instance Show (BoolWithFixedSizedBVSpec bv n) where+  show (BoolWithFixedSizedBVSpec n r) =+    "BoolWithFixedSizedBVSpec { no: " ++ pformatTerm n ++ ", re: " ++ pformatTerm r ++ " }"++instance TermRewritingSpec (BoolWithFixedSizedBVSpec bv n) Bool where+  norewriteVer (BoolWithFixedSizedBVSpec n _) = n+  rewriteVer (BoolWithFixedSizedBVSpec _ r) = r+  wrap = BoolWithFixedSizedBVSpec+  same s = eqTerm (norewriteVer s) (rewriteVer s)++boolWithFSBV ::+  forall p1 p2 bv n.+  (SupportedBV bv n) =>+  p1 bv ->+  p2 n ->+  Int ->+  Gen (BoolWithFixedSizedBVSpec bv n)+boolWithFSBV _ _ 0 =+  let s =+        oneof $+          return . symSpec . (`withMetadata` (Atom ("bool" :: T.Text)))+            <$> ["a", "b", "c", "d", "e", "f", "g"]+      r = oneof $ return . conSpec <$> [True, False]+   in oneof [r, s]+boolWithFSBV pbv pn n | n > 0 = do+  v1 <- boolWithFSBV pbv pn (n - 1)+  v2 <- boolWithFSBV pbv pn (n - 1)+  v3 <- boolWithFSBV pbv pn (n - 1)+  v1i <- fsbvWithBool pbv pn (n - 1)+  v2i <- fsbvWithBool pbv pn (n - 1)+  v3i <- fsbvWithBool pbv pn (n - 1)+  frequency+    [ (1, return $ notSpec v1),+      (1, return $ andSpec v1 v2),+      (1, return $ orSpec v1 v2),+      (1, return $ eqvSpec v1 v2),+      (5, return $ eqvSpec v1i v2i),+      (1, return $ distinctSpec $ v1 :| []),+      (1, return $ distinctSpec $ v1 :| [v2]),+      (1, return $ distinctSpec $ v1 :| [v2, v3]),+      (2, return $ distinctSpec $ v1i :| []),+      (2, return $ distinctSpec $ v1i :| [v2i]),+      (2, return $ distinctSpec $ v1i :| [v2i, v3i]),+      (5, return $ ltOrdSpec v1i v2i),+      (5, return $ leOrdSpec v1i v2i),+      (1, return $ iteSpec v1 v2 v3)+    ]+boolWithFSBV _ _ _ = error "Should never be called"++fsbvWithBool ::+  forall p1 p2 bv n.+  (SupportedBV bv n) =>+  p1 bv ->+  p2 n ->+  Int ->+  Gen (FixedSizedBVWithBoolSpec bv n)+fsbvWithBool _ _ 0 =+  let s =+        oneof $+          return . symSpec . (`withMetadata` (Atom ("int" :: T.Text)))+            <$> ["a", "b", "c", "d", "e", "f", "g"]+      r =+        conSpec+          <$> oneof+            [ return minBound,+              return maxBound,+              fromInteger <$> arbitrary+            ]+   in oneof [r, s]+fsbvWithBool pbv pn n | n > 0 = do+  v1b <- boolWithFSBV pbv pn (n - 1)+  v1i <- fsbvWithBool pbv pn (n - 1)+  v2i <- fsbvWithBool pbv pn (n - 1)+  oneof+    [ return $ negNumSpec v1i,+      return $ absNumSpec v1i,+      return $ signumNumSpec v1i,+      return $ addNumSpec v1i v2i,+      return $ mulNumSpec v1i v2i,+      return $ andBitsSpec v1i v2i,+      return $ orBitsSpec v1i v2i,+      return $ xorBitsSpec v1i v2i,+      return $ complementBitsSpec v1i,+      return $ shiftLeftSpec v1i v2i,+      return $ rotateLeftSpec v1i v2i,+      return $ shiftRightSpec v1i v2i,+      return $ rotateRightSpec v1i v2i,+      return $ iteSpec v1b v1i v2i+    ]+fsbvWithBool _ _ _ = error "Should never be called"++instance (SupportedBV bv n) => Arbitrary (BoolWithFixedSizedBVSpec bv n) where+  arbitrary = sized (boolWithFSBV (Proxy @bv) (Proxy @n))++instance (SupportedBV bv n) => Arbitrary (FixedSizedBVWithBoolSpec bv n) where+  arbitrary = sized (fsbvWithBool Proxy Proxy)++data DifferentSizeBVSpec bv (n :: Nat) = DifferentSizeBVSpec (Term (bv n)) (Term (bv n))++instance (SupportedNonFuncPrim (bv n)) => Show (DifferentSizeBVSpec bv n) where+  show (DifferentSizeBVSpec n r) = "DSizeBVSpec { no: " ++ pformatTerm n ++ ", re: " ++ pformatTerm r ++ " }"++instance (SupportedNonFuncPrim (bv n)) => TermRewritingSpec (DifferentSizeBVSpec bv n) (bv n) where+  norewriteVer (DifferentSizeBVSpec n _) = n+  rewriteVer (DifferentSizeBVSpec _ r) = r+  wrap = DifferentSizeBVSpec+  same s = eqTerm (norewriteVer s) (rewriteVer s)++type SupportedBV bv (n :: Nat) =+  ( SupportedPrim (bv n),+    SupportedNonFuncPrim (bv n),+    Ord (bv n),+    Num (bv n),+    FiniteBits (bv n),+    Integral (bv n),+    Bounded (bv n),+    SymShift (bv n),+    SymRotate (bv n),+    PEvalShiftTerm (bv n),+    PEvalRotateTerm (bv n),+    PEvalNumTerm (bv n),+    PEvalOrdTerm (bv n),+    PEvalBitwiseTerm (bv n),+    KnownNat n,+    PEvalBVTerm bv,+    1 <= n+  )++dsbv1 ::+  forall proxy bv.+  ( SupportedBV bv 1,+    SupportedBV bv 2,+    SupportedBV bv 3,+    SupportedBV bv 4+  ) =>+  proxy bv ->+  Int ->+  Gen (DifferentSizeBVSpec bv 1)+dsbv1 _ 0 =+  let s =+        oneof $+          return . symSpec . (`withMetadata` (Atom ("bv1" :: T.Text)))+            <$> ["a", "b", "c", "d", "e", "f", "g"]+      r = conSpec . fromInteger <$> arbitrary+   in oneof [r, s]+dsbv1 p depth | depth > 0 = do+  v1 <- dsbv1 p (depth - 1)+  v1' <- dsbv1 p (depth - 1)+  v2 <- dsbv2 p (depth - 1)+  v3 <- dsbv3 p (depth - 1)+  v4 <- dsbv4 p (depth - 1)+  oneof+    [ return $ negNumSpec v1,+      return $ absNumSpec v1,+      return $ signumNumSpec v1,+      return $ addNumSpec v1 v1',+      return $ mulNumSpec v1 v1',+      return $ andBitsSpec v1 v1',+      return $ orBitsSpec v1 v1',+      return $ xorBitsSpec v1 v1',+      return $ complementBitsSpec v1,+      return $ shiftLeftSpec v1 v1',+      return $ rotateLeftSpec v1 v1',+      return $ shiftRightSpec v1 v1',+      return $ rotateRightSpec v1 v1',+      return $ bvselectSpec (Proxy @0) (Proxy @1) v4,+      return $ bvselectSpec (Proxy @1) (Proxy @1) v4,+      return $ bvselectSpec (Proxy @2) (Proxy @1) v4,+      return $ bvselectSpec (Proxy @3) (Proxy @1) v4,+      return $ bvselectSpec (Proxy @0) (Proxy @1) v3,+      return $ bvselectSpec (Proxy @1) (Proxy @1) v3,+      return $ bvselectSpec (Proxy @2) (Proxy @1) v3,+      return $ bvselectSpec (Proxy @0) (Proxy @1) v2,+      return $ bvselectSpec (Proxy @1) (Proxy @1) v2,+      return $ bvselectSpec (Proxy @0) (Proxy @1) v1+    ]+dsbv1 _ _ = error "Should never be called"++dsbv2 ::+  forall proxy bv.+  ( SupportedBV bv 1,+    SupportedBV bv 2,+    SupportedBV bv 3,+    SupportedBV bv 4+  ) =>+  proxy bv ->+  Int ->+  Gen (DifferentSizeBVSpec bv 2)+dsbv2 _ 0 =+  let s =+        oneof $+          return . symSpec . (`withMetadata` (Atom ("bv2" :: T.Text)))+            <$> ["a", "b", "c", "d", "e", "f", "g"]+      r = conSpec . fromInteger <$> arbitrary+   in oneof [r, s]+dsbv2 p depth | depth > 0 = do+  v1 <- dsbv1 p (depth - 1)+  v1' <- dsbv1 p (depth - 1)+  v2 <- dsbv2 p (depth - 1)+  v2' <- dsbv2 p (depth - 1)+  v3 <- dsbv3 p (depth - 1)+  v4 <- dsbv4 p (depth - 1)+  oneof+    [ return $ negNumSpec v2,+      return $ absNumSpec v2,+      return $ signumNumSpec v2,+      return $ addNumSpec v2 v2',+      return $ mulNumSpec v2 v2',+      return $ andBitsSpec v2 v2',+      return $ orBitsSpec v2 v2',+      return $ xorBitsSpec v2 v2',+      return $ complementBitsSpec v2,+      return $ shiftLeftSpec v2 v2',+      return $ rotateLeftSpec v2 v2',+      return $ shiftRightSpec v2 v2',+      return $ rotateRightSpec v2 v2',+      return $ bvselectSpec (Proxy @0) (Proxy @2) v4,+      return $ bvselectSpec (Proxy @1) (Proxy @2) v4,+      return $ bvselectSpec (Proxy @2) (Proxy @2) v4,+      return $ bvselectSpec (Proxy @0) (Proxy @2) v3,+      return $ bvselectSpec (Proxy @1) (Proxy @2) v3,+      return $ bvselectSpec (Proxy @0) (Proxy @2) v2,+      return $ bvconcatSpec v1 v1',+      return $ bvextendSpec False (Proxy @2) v1,+      return $ bvextendSpec True (Proxy @2) v1+    ]+dsbv2 _ _ = error "Should never be called"++dsbv3 ::+  forall proxy bv.+  ( SupportedBV bv 1,+    SupportedBV bv 2,+    SupportedBV bv 3,+    SupportedBV bv 4+  ) =>+  proxy bv ->+  Int ->+  Gen (DifferentSizeBVSpec bv 3)+dsbv3 _ 0 =+  let s =+        oneof $+          return . symSpec . (`withMetadata` (Atom ("bv3" :: T.Text)))+            <$> ["a", "b", "c", "d", "e", "f", "g"]+      r = conSpec . fromInteger <$> arbitrary+   in oneof [r, s]+dsbv3 p depth | depth > 0 = do+  v1 <- dsbv1 p (depth - 1)+  v2 <- dsbv2 p (depth - 1)+  v3 <- dsbv3 p (depth - 1)+  v3' <- dsbv3 p (depth - 1)+  v4 <- dsbv4 p (depth - 1)+  oneof+    [ return $ negNumSpec v3,+      return $ absNumSpec v3,+      return $ signumNumSpec v3,+      return $ addNumSpec v3 v3',+      return $ mulNumSpec v3 v3',+      return $ andBitsSpec v3 v3',+      return $ orBitsSpec v3 v3',+      return $ xorBitsSpec v3 v3',+      return $ complementBitsSpec v3,+      return $ shiftLeftSpec v3 v3',+      return $ rotateLeftSpec v3 v3',+      return $ shiftRightSpec v3 v3',+      return $ rotateRightSpec v3 v3',+      return $ bvselectSpec (Proxy @0) (Proxy @3) v4,+      return $ bvselectSpec (Proxy @1) (Proxy @3) v4,+      return $ bvselectSpec (Proxy @0) (Proxy @3) v3,+      return $ bvconcatSpec v1 v2,+      return $ bvconcatSpec v2 v1,+      return $ bvextendSpec False (Proxy @3) v1,+      return $ bvextendSpec True (Proxy @3) v1,+      return $ bvextendSpec False (Proxy @3) v2,+      return $ bvextendSpec True (Proxy @3) v2+    ]+dsbv3 _ _ = error "Should never be called"++dsbv4 ::+  forall proxy bv.+  ( SupportedBV bv 1,+    SupportedBV bv 2,+    SupportedBV bv 3,+    SupportedBV bv 4+  ) =>+  proxy bv ->+  Int ->+  Gen (DifferentSizeBVSpec bv 4)+dsbv4 _ 0 =+  let s =+        oneof $+          return . symSpec . (`withMetadata` (Atom ("bv4" :: T.Text)))+            <$> ["a", "b", "c", "d", "e", "f", "g"]+      r = conSpec . fromInteger <$> arbitrary+   in oneof [r, s]+dsbv4 p depth | depth > 0 = do+  v1 <- dsbv1 p (depth - 1)+  v2 <- dsbv2 p (depth - 1)+  v2' <- dsbv2 p (depth - 1)+  v3 <- dsbv3 p (depth - 1)+  v4 <- dsbv4 p (depth - 1)+  v4' <- dsbv4 p (depth - 1)+  oneof+    [ return $ negNumSpec v4,+      return $ absNumSpec v4,+      return $ signumNumSpec v4,+      return $ addNumSpec v4 v4',+      return $ mulNumSpec v4 v4',+      return $ andBitsSpec v4 v4',+      return $ orBitsSpec v4 v4',+      return $ xorBitsSpec v4 v4',+      return $ complementBitsSpec v4,+      return $ shiftLeftSpec v4 v4',+      return $ rotateLeftSpec v4 v4',+      return $ shiftRightSpec v4 v4',+      return $ rotateRightSpec v4 v4',+      return $ bvselectSpec (Proxy @0) (Proxy @4) v4,+      return $ bvconcatSpec v1 v3,+      return $ bvconcatSpec v2 v2',+      return $ bvconcatSpec v3 v1,+      return $ bvextendSpec False (Proxy @4) v1,+      return $ bvextendSpec True (Proxy @4) v1,+      return $ bvextendSpec False (Proxy @4) v2,+      return $ bvextendSpec True (Proxy @4) v2,+      return $ bvextendSpec False (Proxy @4) v3,+      return $ bvextendSpec True (Proxy @4) v3+    ]+dsbv4 _ _ = error "Should never be called"++instance+  ( SupportedBV bv 1,+    SupportedBV bv 2,+    SupportedBV bv 3,+    SupportedBV bv 4,+    Typeable bv,+    SizedBV bv+  ) =>+  Arbitrary (DifferentSizeBVSpec bv 4)+  where+  arbitrary = sized (dsbv4 Proxy)++data GeneralSpec s = GeneralSpec (Term s) (Term s)++instance (SupportedPrim s) => Show (GeneralSpec s) where+  show (GeneralSpec n r) = "GeneralSpec { no: " ++ pformatTerm n ++ ", re: " ++ pformatTerm r ++ " }"++instance (SupportedNonFuncPrim s) => TermRewritingSpec (GeneralSpec s) s where+  norewriteVer (GeneralSpec n _) = n+  rewriteVer (GeneralSpec _ r) = r+  wrap = GeneralSpec+  same s = eqTerm (norewriteVer s) (rewriteVer s)++data IEEEFPSpec eb sb = IEEEFPSpec (Term (FP eb sb)) (Term (FP eb sb))++instance (ValidFP eb sb) => Show (IEEEFPSpec eb sb) where+  show (IEEEFPSpec n r) =+    "IEEEFPSpec { no: " ++ pformatTerm n ++ ", re: " ++ pformatTerm r ++ " }"++instance (ValidFP eb sb) => TermRewritingSpec (IEEEFPSpec eb sb) (FP eb sb) where+  norewriteVer (IEEEFPSpec n _) = n+  rewriteVer (IEEEFPSpec _ r) = r+  wrap = IEEEFPSpec+  same s =+    orTerm+      ( andTerm+          (fpTraitTerm FPIsNaN (norewriteVer s))+          (fpTraitTerm FPIsNaN (rewriteVer s))+      )+      (eqTerm (norewriteVer s) (rewriteVer s))++instance (ValidFP eb sb) => Arbitrary (IEEEFPSpec eb sb) where+  arbitrary = do+    bool :: BoolOnlySpec <-+      oneof [conSpec <$> arbitrary, return $ symSpec "bool"]+    rounding :: FPRoundingModeSpec <- arbitrary+    let gen =+          oneof+            [conSpec <$> arbitrary, return $ symSpec "a", return $ symSpec "b"]+    a <- gen+    b <- gen+    c <- gen+    let regular =+          [ a,+            iteSpec bool a b,+            addNumSpec a a,+            negNumSpec a,+            mulNumSpec a b,+            absNumSpec a,+            signumNumSpec a,+            fdivSpec a b,+            recipSpec a,+            floatingUnarySpec FloatingSqrt a+          ]+    let uop = fpUnaryOpSpec <$> [FPAbs, FPNeg] <*> return a+    let bop =+          fpBinaryOpSpec+            <$> [ FPRem,+                  FPMinimum,+                  FPMaximum,+                  FPMaximumNumber,+                  FPMinimumNumber+                ]+            <*> [a]+            <*> [b]+    let ruop =+          fpRoundingUnaryOpSpec+            <$> [FPSqrt, FPRoundToIntegral]+            <*> [rounding]+            <*> [a]+    let rbop =+          fpRoundingBinarySpec+            <$> [FPAdd, FPSub, FPMul, FPDiv]+            <*> [rounding]+            <*> [a]+            <*> [b]+    oneof $+      return+        <$> regular+          ++ uop+          ++ bop+          ++ ruop+          ++ rbop+          ++ [fpFMASpec rounding a b c]++data IEEEFPBoolOpSpec (eb :: Nat) (sb :: Nat)+  = IEEEFPBoolOpSpec (Term Bool) (Term Bool)++instance Show (IEEEFPBoolOpSpec eb sb) where+  show (IEEEFPBoolOpSpec n r) =+    "IEEEFPBoolOpSpec { no: " ++ pformatTerm n ++ ", re: " ++ pformatTerm r ++ " }"++instance TermRewritingSpec (IEEEFPBoolOpSpec eb sb) Bool where+  norewriteVer (IEEEFPBoolOpSpec n _) = n+  rewriteVer (IEEEFPBoolOpSpec _ r) = r+  wrap = IEEEFPBoolOpSpec+  same s = eqTerm (norewriteVer s) (rewriteVer s)++singleFPBoolOpSpecGen ::+  forall eb sb. (ValidFP eb sb) => Gen (IEEEFPBoolOpSpec eb sb)+singleFPBoolOpSpecGen = do+  s0 :: IEEEFPSpec eb sb <- arbitrary+  s1 :: IEEEFPSpec eb sb <- arbitrary+  s2 :: IEEEFPSpec eb sb <- arbitrary+  let traitGens =+        [ FPIsNaN,+          FPIsPositive,+          FPIsNegative,+          FPIsPositiveInfinite,+          FPIsNegativeInfinite,+          FPIsInfinite,+          FPIsPositiveZero,+          FPIsNegativeZero,+          FPIsZero,+          FPIsNormal,+          FPIsSubnormal,+          FPIsPoint+        ]+          <&> (\trait -> return $ fpTraitSpec trait s0)+  let cmpGens =+        return+          <$> [ eqvSpec s0 s1,+                distinctSpec $ s0 :| [],+                distinctSpec $ s0 :| [s1],+                distinctSpec $ s0 :| [s1, s2],+                ltOrdSpec s0 s1,+                leOrdSpec s0 s1+              ]+  oneof $ traitGens ++ cmpGens++instance (ValidFP eb sb) => Arbitrary (IEEEFPBoolOpSpec eb sb) where+  arbitrary = singleFPBoolOpSpecGen++data FPRoundingModeSpec+  = FPRoundingModeSpec (Term FPRoundingMode) (Term FPRoundingMode)++instance Show FPRoundingModeSpec where+  show (FPRoundingModeSpec n r) =+    "FPRoundingModeSpec { no: " ++ pformatTerm n ++ ", re: " ++ pformatTerm r ++ " }"++instance TermRewritingSpec FPRoundingModeSpec FPRoundingMode where+  norewriteVer (FPRoundingModeSpec n _) = n+  rewriteVer (FPRoundingModeSpec _ r) = r+  wrap = FPRoundingModeSpec+  same s = eqTerm (norewriteVer s) (rewriteVer s)++instance Arbitrary FPRoundingModeSpec where+  arbitrary =+    elements+      [ conSpec RNE,+        conSpec RNA,+        conSpec RTP,+        conSpec RTN,+        conSpec RTZ,+        symSpec "a",+        symSpec "b"+      ]++data FPRoundingModeBoolOpSpec = FPRoundingModeBoolOpSpec (Term Bool) (Term Bool)++instance Show FPRoundingModeBoolOpSpec where+  show (FPRoundingModeBoolOpSpec n r) =+    "FPRoundingModeBoolOpSpec { no: " ++ pformatTerm n ++ ", re: " ++ pformatTerm r ++ " }"++instance TermRewritingSpec FPRoundingModeBoolOpSpec Bool where+  norewriteVer (FPRoundingModeBoolOpSpec n _) = n+  rewriteVer (FPRoundingModeBoolOpSpec _ r) = r+  wrap = FPRoundingModeBoolOpSpec+  same s = eqTerm (norewriteVer s) (rewriteVer s)++instance Arbitrary FPRoundingModeBoolOpSpec where+  arbitrary = do+    l :: FPRoundingModeSpec <- arbitrary+    r <- arbitrary+    x <- arbitrary+    elements+      [ eqvSpec l r,+        distinctSpec $ l :| [],+        distinctSpec $ l :| [r],+        distinctSpec $ l :| [r, x],+        ltOrdSpec l r,+        leOrdSpec l r+      ]++data BoolWithNRASpec = BoolWithNRASpec (Term Bool) (Term Bool)++instance Show BoolWithNRASpec where+  show (BoolWithNRASpec n r) =+    "BoolWithNRASpec { no: " ++ pformatTerm n ++ ", re: " ++ pformatTerm r ++ " }"++instance TermRewritingSpec BoolWithNRASpec Bool where+  norewriteVer (BoolWithNRASpec n _) = n+  rewriteVer (BoolWithNRASpec _ r) = r+  wrap = BoolWithNRASpec+  same s = eqTerm (norewriteVer s) (rewriteVer s)++data NRAWithBoolSpec = NRAWithBoolSpec (Term AlgReal) (Term AlgReal)++instance Show NRAWithBoolSpec where+  show (NRAWithBoolSpec n r) =+    "NRAWithBoolSpec { no: " ++ pformatTerm n ++ ", re: " ++ pformatTerm r ++ " }"++instance TermRewritingSpec NRAWithBoolSpec AlgReal where+  norewriteVer (NRAWithBoolSpec n _) = n+  rewriteVer (NRAWithBoolSpec _ r) = r+  wrap = NRAWithBoolSpec+  same s = eqTerm (norewriteVer s) (rewriteVer s)++boolWithNRA :: Int -> Gen BoolWithNRASpec+boolWithNRA 0 =+  let s =+        oneof $+          return . symSpec . (`withMetadata` (Atom ("bool" :: T.Text)))+            <$> ["a", "b", "c", "d", "e", "f", "g"]+      r = oneof $ return . conSpec <$> [True, False]+   in oneof [r, s]+boolWithNRA n | n > 0 = do+  v1 <- boolWithNRA (n - 1)+  v2 <- boolWithNRA (n - 1)+  v3 <- boolWithNRA (n - 1)+  v1i <- nraWithBool (n - 1)+  v2i <- nraWithBool (n - 1)+  v3i <- nraWithBool (n - 1)+  frequency+    [ (1, return $ notSpec v1),+      (1, return $ andSpec v1 v2),+      (1, return $ orSpec v1 v2),+      (1, return $ eqvSpec v1 v2),+      (5, return $ eqvSpec v1i v2i),+      (1, return $ distinctSpec $ v1 :| []),+      (1, return $ distinctSpec $ v1 :| [v2]),+      (1, return $ distinctSpec $ v1 :| [v2, v3]),+      (2, return $ distinctSpec $ v1i :| []),+      (2, return $ distinctSpec $ v1i :| [v2i]),+      (2, return $ distinctSpec $ v1i :| [v2i, v3i]),+      (5, return $ ltOrdSpec v1i v2i),+      (5, return $ leOrdSpec v1i v2i),+      (1, return $ iteSpec v1 v2 v3)+    ]+boolWithNRA _ = error "Should never be called"++nraWithBool :: Int -> Gen NRAWithBoolSpec+nraWithBool 0 =+  let s =+        oneof $+          return . symSpec . (`withMetadata` (Atom ("real" :: T.Text)))+            <$> ["a", "b", "c", "d", "e", "f", "g"]+      r = conSpec <$> arbitrary+   in oneof [r, s]+nraWithBool n | n > 0 = do+  v1b <- boolWithNRA (n - 1)+  v1i <- nraWithBool (n - 1)+  v2i <- nraWithBool (n - 1)+  oneof+    [ return $ negNumSpec v1i,+      return $ absNumSpec v1i,+      return $ signumNumSpec v1i,+      return $ addNumSpec v1i v2i,+      return $ mulNumSpec v1i v2i,+      return $ fdivSpec v1i v2i,+      return $ recipSpec v1i,+      return $ iteSpec v1b v1i v2i+    ]+nraWithBool _ = error "Should never be called"++instance Arbitrary BoolWithNRASpec where+  arbitrary = sized boolWithNRA++instance Arbitrary NRAWithBoolSpec where+  arbitrary = sized nraWithBool
+ test/Grisette/Backend/TermRewritingTests.hs view
@@ -0,0 +1,1442 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Grisette.Backend.TermRewritingTests+  ( termRewritingTests,+    validateSpec,+    bitwuzlaConfig,+  )+where++import Data.Foldable (traverse_)+import Data.Proxy (Proxy (Proxy))+import GHC.TypeLits (KnownNat, type (<=))+import Grisette+  ( AlgReal,+    BitCast (bitCast),+    GrisetteSMTConfig,+    IEEEFPConstants+      ( fpMaxNormalized,+        fpMaxSubnormal,+        fpMinNormalized,+        fpMinSubnormal,+        fpNaN,+        fpNegativeInfinite,+        fpNegativeZero,+        fpPositiveInfinite,+        fpPositiveZero+      ),+    IEEEFPRoundingMode (rna, rne, rtn, rtp, rtz),+    ITEOp (symIte),+    IntN,+    LinkedRep,+    LogicalOp (symNot, true),+    Solvable (con),+    SymBool (SymBool),+    SymFP,+    SymIEEEFPTraits (symFpIsNaN),+    SymRep (SymType),+    WordN,+    bitwuzla,+    fpIsNaN,+    solve,+    z3,+  )+import Grisette.Backend.TermRewritingGen+  ( BoolOnlySpec (BoolOnlySpec),+    BoolWithFixedSizedBVSpec (BoolWithFixedSizedBVSpec),+    BoolWithLIASpec,+    DifferentSizeBVSpec,+    FPRoundingModeBoolOpSpec,+    FPRoundingModeSpec,+    FixedSizedBVWithBoolSpec (FixedSizedBVWithBoolSpec),+    GeneralSpec,+    IEEEFPBoolOpSpec (IEEEFPBoolOpSpec),+    IEEEFPSpec,+    LIAWithBoolSpec,+    NRAWithBoolSpec,+    TermRewritingSpec+      ( conSpec,+        counterExample,+        norewriteVer,+        rewriteVer,+        same,+        symSpec,+        wrap+      ),+    absNumSpec,+    addNumSpec,+    andBitsSpec,+    andSpec,+    bitCastOrSpec,+    bitCastSpec,+    bvconcatSpec,+    bvextendSpec,+    bvselectSpec,+    complementBitsSpec,+    divIntegralSpec,+    eqvSpec,+    fpBinaryOpSpec,+    fpFMASpec,+    fpRoundingBinarySpec,+    fpRoundingUnaryOpSpec,+    fpTraitSpec,+    fromFPOrSpec,+    iteSpec,+    leOrdSpec,+    modIntegralSpec,+    mulNumSpec,+    negNumSpec,+    notSpec,+    orBitsSpec,+    orSpec,+    quotIntegralSpec,+    remIntegralSpec,+    shiftLeftSpec,+    shiftRightSpec,+    signumNumSpec,+    toFPSpec,+    xorBitsSpec,+  )+import Grisette.Internal.Core.Data.Class.LogicalOp (LogicalOp ((.&&)))+import Grisette.Internal.Core.Data.Class.SymEq (SymEq ((./=), (.==)))+import Grisette.Internal.Core.Data.Class.SymIEEEFP+  ( SymIEEEFPTraits (symFpIsPositiveInfinite),+  )+import Grisette.Internal.SymPrim.FP+  ( ConvertibleBound (convertibleLowerBound, convertibleUpperBound),+    FP,+    FP32,+    FPRoundingMode,+    ValidFP,+    nextFP,+    prevFP,+  )+import Grisette.Internal.SymPrim.Prim.Term+  ( FPBinaryOp (FPMaximum, FPMaximumNumber, FPMinimum, FPMinimumNumber, FPRem),+    FPRoundingBinaryOp (FPAdd, FPDiv, FPMul, FPSub),+    FPRoundingUnaryOp (FPRoundToIntegral, FPSqrt),+    FPTrait (FPIsPositive),+    PEvalBVTerm,+    PEvalBitCastOrTerm,+    PEvalBitCastTerm,+    PEvalBitwiseTerm (pevalAndBitsTerm, pevalOrBitsTerm),+    PEvalIEEEFPConvertibleTerm,+    PEvalShiftTerm,+    SupportedNonFuncPrim,+    Term,+    andBitsTerm,+    andTerm,+    bvConcatTerm,+    bvExtendTerm,+    complementBitsTerm,+    conTerm,+    eqTerm,+    fpTraitTerm,+    iteTerm,+    notTerm,+    orBitsTerm,+    orTerm,+    pformatTerm,+    ssymTerm,+    xorBitsTerm,+  )+import Grisette.Internal.SymPrim.SymFP (SymFP32)+import Test.Framework (Test, TestName, testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.HUnit (Assertion, assertFailure, (@?=))+import Test.QuickCheck+  ( Arbitrary,+    elements,+    forAll,+    ioProperty,+    mapSize,+    vectorOf,+    withMaxSuccess,+    (==>),+  )+import Type.Reflection (Typeable, typeRep)++validateSpec' ::+  (TermRewritingSpec a av) =>+  GrisetteSMTConfig ->+  SymBool ->+  a ->+  Assertion+validateSpec' config precond a = do+  r <- solve config (precond .&& SymBool (counterExample a))+  rs <- solve config (precond .&& SymBool (same a))+  case (r, rs) of+    (Left _, Right _) -> do+      return ()+    (Left _, Left err) -> do+      print err+      assertFailure $+        "Bad rewriting with unsolvable formula: "+          ++ pformatTerm (norewriteVer a)+          ++ " was rewritten to "+          ++ pformatTerm (rewriteVer a)+          ++ " under precondition"+          ++ show precond+          ++ " corresponding same formula:"+          ++ pformatTerm (same a)+    (Right m, _) -> do+      assertFailure $+        "With model"+          ++ show m+          ++ "Bad rewriting: "+          ++ pformatTerm (norewriteVer a)+          ++ " was rewritten to "+          ++ pformatTerm (rewriteVer a)+          ++ " under precondition"+          ++ show precond+          ++ " corresponding cex formula:"+          ++ pformatTerm (counterExample a)+          ++ "\n"+          ++ show (norewriteVer a)+          ++ "\n"+          ++ show (rewriteVer a)+          ++ "\n"+          ++ show (counterExample a)++validateSpec ::+  (TermRewritingSpec a av) =>+  GrisetteSMTConfig ->+  a ->+  Assertion+validateSpec config = validateSpec' config true++bitwuzlaConfig :: IO (Maybe GrisetteSMTConfig)+bitwuzlaConfig = do+  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 bitwuzla++onlyWhenBitwuzlaIsAvailable :: (GrisetteSMTConfig -> IO ()) -> IO ()+onlyWhenBitwuzlaIsAvailable action = do+  config <- bitwuzlaConfig+  case config of+    Just config -> action config+    Nothing ->+      putStrLn $+        "bitwuzla isn't available in the system, or the dependent sbv"+          <> " library does not work well with it. This test is marked as "+          <> " success."++unboundedConfig = z3++divisionTest ::+  forall a b.+  (TermRewritingSpec a b, Enum b, Num b) =>+  TestName ->+  (a -> a -> a) ->+  Test+divisionTest name f =+  testGroup+    name+    [ testCase "on concrete" $ do+        traverse_+          ( \(x :: b, y :: b) -> do+              validateSpec @a unboundedConfig $ f (conSpec x) (conSpec y)+          )+          [(i, j) | i <- [-3 .. 3], j <- [-3 .. 3]],+      testCase "on single concrete" $ do+        traverse_+          ( \x -> do+              validateSpec @a unboundedConfig $ f (conSpec x) (symSpec "a")+              validateSpec @a unboundedConfig $ f (symSpec "a") (conSpec x)+          )+          [-3 .. 3]+    ]++bvConcatTest ::+  forall bv.+  ( forall n. (KnownNat n, 1 <= n) => SupportedNonFuncPrim (bv n),+    forall n. (KnownNat n, 1 <= n) => PEvalShiftTerm (bv n),+    forall n. (KnownNat n, 1 <= n) => Arbitrary (bv n),+    Typeable bv,+    PEvalBVTerm bv+  ) =>+  Test+bvConcatTest =+  testGroup (show (typeRep @bv) <> "_concat") $+    ( do+        (opName, opSpec, termOp) <-+          [ ("and", andBitsSpec, andBitsTerm),+            ("or", orBitsSpec, orBitsTerm),+            ("xor", xorBitsSpec, xorBitsTerm)+          ]+        [ testCase (opName <> "(const,concat)") $ do+            let lhs = conSpec 0x39 :: FixedSizedBVWithBoolSpec bv 8+            let rhs =+                  bvconcatSpec+                    (symSpec "a" :: FixedSizedBVWithBoolSpec bv 4)+                    (symSpec "b" :: FixedSizedBVWithBoolSpec bv 4)+            let spec = opSpec lhs rhs+            validateSpec @(FixedSizedBVWithBoolSpec bv 8) unboundedConfig spec,+          testCase (opName <> "(concat,concat)") $ do+            let lhs =+                  bvconcatSpec+                    (symSpec "a" :: FixedSizedBVWithBoolSpec bv 4)+                    (symSpec "b" :: FixedSizedBVWithBoolSpec bv 4)+            let rhs =+                  bvconcatSpec+                    (symSpec "c" :: FixedSizedBVWithBoolSpec bv 4)+                    (symSpec "d" :: FixedSizedBVWithBoolSpec bv 4)+            let spec@(FixedSizedBVWithBoolSpec _ r) = opSpec lhs rhs+            let expected =+                  ( bvConcatTerm+                      (termOp (ssymTerm "a" :: Term (bv 4)) (ssymTerm "c"))+                      (termOp (ssymTerm "b" :: Term (bv 4)) (ssymTerm "d"))+                  )+            r @?= expected+            validateSpec @(FixedSizedBVWithBoolSpec bv 8) unboundedConfig spec+          ]+    )+      ++ [ testCase "complement(concat)" $ do+             let lhs =+                   bvconcatSpec+                     (symSpec "a" :: FixedSizedBVWithBoolSpec bv 4)+                     (symSpec "b" :: FixedSizedBVWithBoolSpec bv 4)+             let spec@(FixedSizedBVWithBoolSpec _ r) = complementBitsSpec lhs+             let expected =+                   bvConcatTerm+                     (complementBitsTerm (ssymTerm "a" :: Term (bv 4)))+                     (complementBitsTerm (ssymTerm "b" :: Term (bv 4)))+             r @?= expected+             validateSpec @(FixedSizedBVWithBoolSpec bv 8) unboundedConfig spec,+           testCase "complement(sext)" $ do+             let spec@(FixedSizedBVWithBoolSpec _ r) =+                   complementBitsSpec+                     ( bvextendSpec+                         True+                         (Proxy :: Proxy 8)+                         (symSpec "a" :: FixedSizedBVWithBoolSpec bv 4)+                     ) ::+                     FixedSizedBVWithBoolSpec bv 8+             let expected =+                   bvExtendTerm+                     True+                     (Proxy :: Proxy 8)+                     (complementBitsTerm (ssymTerm "a" :: Term (bv 4)))+             r @?= expected+             validateSpec @(FixedSizedBVWithBoolSpec bv 8) unboundedConfig spec,+           testCase "and(leading_zero_then_all_one, b)" $ do+             let spec =+                   andBitsSpec+                     (conSpec 0x1f)+                     (symSpec "b" :: FixedSizedBVWithBoolSpec bv 4)+             validateSpec @(FixedSizedBVWithBoolSpec bv 4) unboundedConfig spec,+           testCase "and(leading_one_then_all_zero, b)" $ do+             let spec =+                   andBitsSpec+                     (conSpec 0xf8)+                     (symSpec "b" :: FixedSizedBVWithBoolSpec bv 4)+             validateSpec @(FixedSizedBVWithBoolSpec bv 4) unboundedConfig spec,+           testCase "or(leading_zero_then_all_one, b)" $ do+             let spec =+                   orBitsSpec+                     (conSpec 0x1f)+                     (symSpec "b" :: FixedSizedBVWithBoolSpec bv 4)+             validateSpec @(FixedSizedBVWithBoolSpec bv 4) unboundedConfig spec,+           testCase "or(leading_one_then_all_zero, b)" $ do+             let spec =+                   orBitsSpec+                     (conSpec 0xf8)+                     (symSpec "b" :: FixedSizedBVWithBoolSpec bv 4)+             validateSpec @(FixedSizedBVWithBoolSpec bv 4) unboundedConfig spec,+           testCase "select(sext)with_part_base" $ do+             let spec =+                   bvselectSpec+                     (Proxy @2)+                     (Proxy @4)+                     ( bvextendSpec+                         True+                         (Proxy @8)+                         (symSpec "b" :: FixedSizedBVWithBoolSpec bv 4) ::+                         FixedSizedBVWithBoolSpec bv 8+                     ) ::+                     FixedSizedBVWithBoolSpec bv 4+             validateSpec @(FixedSizedBVWithBoolSpec bv 4) unboundedConfig spec,+           testCase "ite(cond,concat(a,b),concat(c,d))" $ do+             let spec@(FixedSizedBVWithBoolSpec _ r) =+                   iteSpec+                     (symSpec "cond" :: BoolWithFixedSizedBVSpec bv 4)+                     ( bvconcatSpec+                         (symSpec "a" :: FixedSizedBVWithBoolSpec bv 4)+                         (symSpec "b" :: FixedSizedBVWithBoolSpec bv 4)+                     )+                     ( bvconcatSpec+                         (symSpec "c" :: FixedSizedBVWithBoolSpec bv 4)+                         (symSpec "d" :: FixedSizedBVWithBoolSpec bv 4)+                     )+             let expected =+                   bvConcatTerm+                     ( iteTerm+                         (ssymTerm "cond" :: Term Bool)+                         (ssymTerm "a" :: Term (bv 4))+                         (ssymTerm "c" :: Term (bv 4))+                     )+                     ( iteTerm+                         (ssymTerm "cond" :: Term Bool)+                         (ssymTerm "b" :: Term (bv 4))+                         (ssymTerm "d" :: Term (bv 4))+                     )+             r @?= expected+             validateSpec @(FixedSizedBVWithBoolSpec bv 8) unboundedConfig spec+         ]+      ++ ( do+             pos <- [True, False]+             cvalue <- [0 :: Int, -1]+             value <- [0 :: Int, -1]+             let con = conSpec (fromIntegral value) :: FixedSizedBVWithBoolSpec bv 4+             let sym = symSpec "b"+             let t = if pos then con else sym+             let f = if pos then sym else con+             let spec =+                   iteSpec+                     ( eqvSpec+                         (symSpec "c" :: FixedSizedBVWithBoolSpec bv 1)+                         (conSpec $ fromIntegral cvalue) ::+                         BoolWithFixedSizedBVSpec bv 1+                     )+                     t+                     f+             let ts = if pos then show value else "sym"+             let fs = if pos then "sym" else show value+             return+               $ testCase+                 ( "ite(bv1="+                     <> show cvalue+                     <> ","+                     <> ts+                     <> ","+                     <> fs+                     <> ")"+                 )+               $ validateSpec unboundedConfig spec+         )+      ++ ( do+             let cond = symSpec "cond" :: BoolWithFixedSizedBVSpec bv 1+             let condTerm = ssymTerm "cond" :: Term Bool+             (opName, op, opSpec) <-+               [ ("and", andBitsTerm, andBitsSpec),+                 ("or", orBitsTerm, orBitsSpec),+                 ("xor", xorBitsTerm, xorBitsSpec),+                 ("ite", iteTerm condTerm, iteSpec cond)+               ]+             let name = opName <> "(sext,sext)"+             let spec@(FixedSizedBVWithBoolSpec _ r) =+                   opSpec+                     ( bvextendSpec+                         True+                         (Proxy :: Proxy 8)+                         (symSpec "a" :: FixedSizedBVWithBoolSpec bv 4)+                     )+                     ( bvextendSpec+                         True+                         (Proxy :: Proxy 8)+                         (symSpec "b" :: FixedSizedBVWithBoolSpec bv 4)+                     )+             let expected =+                   bvExtendTerm+                     True+                     (Proxy :: Proxy 8)+                     ( op+                         (ssymTerm "a" :: Term (bv 4))+                         (ssymTerm "b" :: Term (bv 4))+                     )+             return $ testCase name $ do+               r @?= expected+               validateSpec @(FixedSizedBVWithBoolSpec bv 8) unboundedConfig spec+         )+      ++ ( do+             let a = symSpec "a" :: FixedSizedBVWithBoolSpec bv 4+             let b = symSpec "b" :: FixedSizedBVWithBoolSpec bv 4+             let c = symSpec "c" :: FixedSizedBVWithBoolSpec bv 4+             let cond = symSpec "cond" :: BoolWithFixedSizedBVSpec bv 1+             (lhs, rhs, lhsName, rhsName) <-+               [ (andBitsSpec a b, a, "(& a b)", "a"),+                 (andBitsSpec a b, b, "(& a b)", "b"),+                 (a, andBitsSpec a b, "a", "(& a b)"),+                 (b, andBitsSpec a b, "b", "(& a b)"),+                 (orBitsSpec a b, a, "(| a b)", "a"),+                 (orBitsSpec a b, b, "(| a b)", "b"),+                 (a, orBitsSpec a b, "a", "(| a b)"),+                 (b, orBitsSpec a b, "b", "(| a b)"),+                 (andBitsSpec a b, andBitsSpec a c, "(& a b)", "(& a c)"),+                 (andBitsSpec a b, andBitsSpec c a, "(& a b)", "(& c a)"),+                 (andBitsSpec a b, andBitsSpec b c, "(& a b)", "(& b c)"),+                 (andBitsSpec a b, andBitsSpec c b, "(& a b)", "(& c b)"),+                 (orBitsSpec a b, orBitsSpec a c, "(| a b)", "(| a c)"),+                 (orBitsSpec a b, orBitsSpec c a, "(| a b)", "(| c a)"),+                 (orBitsSpec a b, orBitsSpec b c, "(| a b)", "(| b c)"),+                 (orBitsSpec a b, orBitsSpec c b, "(| a b)", "(| c b)")+               ]+             let spec = iteSpec cond lhs rhs+             return $+               testCase ("ite(cond," <> lhsName <> "," <> rhsName <> ")") $+                 validateSpec @(FixedSizedBVWithBoolSpec bv 4) unboundedConfig spec+         )+      ++ ( do+             trueBranch <- [True, False]+             (opName, spec) <-+               [("and", andBitsSpec), ("or", orBitsSpec)]+             let iteName = "ite(cond,const,const)"+             let name =+                   opName+                     <> "("+                     <> (if trueBranch then iteName else "a")+                     <> ","+                     <> (if trueBranch then "b" else iteName)+                     <> ")"+             return $ testProperty name $ \a b -> ioProperty $ do+               let ite =+                     iteSpec+                       (symSpec "cond" :: BoolWithFixedSizedBVSpec bv 4)+                       (conSpec a :: FixedSizedBVWithBoolSpec bv 4)+                       (conSpec b :: FixedSizedBVWithBoolSpec bv 4)+               let s = symSpec "a" :: FixedSizedBVWithBoolSpec bv 4+               let lhs = if trueBranch then ite else s+               let rhs = if trueBranch then s else ite+               let resSpec = spec lhs rhs+               validateSpec unboundedConfig resSpec+         )+      ++ ( do+             a <- [0, 1, 4, 7, 8, 9, 16]+             (opName, opSpec) <-+               [ ("shr", shiftRightSpec),+                 ("shl", shiftLeftSpec)+               ]+             return $ testCase (opName <> "(bv8," <> show a <> ")") $ do+               let spec =+                     opSpec+                       (symSpec "a" :: FixedSizedBVWithBoolSpec bv 8)+                       (conSpec a)+               validateSpec @(FixedSizedBVWithBoolSpec bv 8) unboundedConfig spec+         )+      ++ ( do+             trueBranch <- [True, False]+             innerTrueBranch <- [True, False]+             let l = symSpec "l" :: FixedSizedBVWithBoolSpec bv 8+             let r = symSpec "r" :: FixedSizedBVWithBoolSpec bv 8+             let cond = symSpec "cond" :: BoolWithFixedSizedBVSpec bv 8+             (absorbing, absorbingTerm, absorbingValueName, opName, opSpec, opTerm) <-+               [ ( conSpec 0 :: FixedSizedBVWithBoolSpec bv 8,+                   conTerm 0 :: Term (bv 8),+                   "0",+                   "and",+                   andBitsSpec,+                   andBitsTerm+                 ),+                 ( conSpec $ -1 :: FixedSizedBVWithBoolSpec bv 8,+                   conTerm $ -1 :: Term (bv 8),+                   "-1",+                   "or",+                   orBitsSpec,+                   orBitsTerm+                 )+               ]+             let condTerm = ssymTerm "cond" :: Term Bool+             let lTerm = ssymTerm "l" :: Term (bv 8)+             let rTerm = ssymTerm "r" :: Term (bv 8)++             let (lhsName, lhs, lhsResultTerm)+                   | trueBranch && innerTrueBranch = ("ite(cond," <> absorbingValueName <> ",l)", iteSpec cond absorbing l, absorbingTerm)+                   | trueBranch && not innerTrueBranch = ("ite(cond,l," <> absorbingValueName <> ")", iteSpec cond l absorbing, opTerm lTerm rTerm)+                   | otherwise = ("l", l, if innerTrueBranch then absorbingTerm else opTerm lTerm rTerm)+             let (rhsName, rhs, rhsResultTerm)+                   | trueBranch = ("r", r, if innerTrueBranch then opTerm lTerm rTerm else absorbingTerm)+                   | innerTrueBranch = ("ite(cond," <> absorbingValueName <> ",r)", iteSpec cond absorbing r, opTerm lTerm rTerm)+                   | otherwise = ("ite(cond,r," <> absorbingValueName <> ")", iteSpec cond r absorbing, absorbingTerm)+             let spec@(FixedSizedBVWithBoolSpec _ rspec) = opSpec lhs rhs+             return $ testCase (opName <> "(" <> lhsName <> "," <> rhsName <> ")") $ do+               rspec @?= iteTerm condTerm lhsResultTerm rhsResultTerm+               validateSpec @(FixedSizedBVWithBoolSpec bv 8) unboundedConfig spec+         )+      ++ ( do+             innerTrueBranch <- [0 :: Int, -1]+             let innerFalseBranch = -1 - innerTrueBranch+             lhsIsExtend <- [True, False]+             let extendName =+                   "sext(ite(cond,"+                     <> show innerTrueBranch+                     <> ","+                     <> show innerFalseBranch+                     <> "))"+             (opName, opSpec, opTerm) <-+               [ ("and", andBitsSpec, pevalAndBitsTerm),+                 ("or", orBitsSpec, pevalOrBitsTerm)+               ]+             let name =+                   opName+                     <> if lhsIsExtend then "(" <> extendName <> ",c)" else "(c," <> extendName <> ")"+             return $+               testCase name $+                 do+                   let extend =+                         bvextendSpec+                           True+                           (Proxy :: Proxy 8)+                           ( iteSpec+                               (symSpec "cond" :: BoolWithFixedSizedBVSpec bv 1)+                               (conSpec $ fromIntegral innerTrueBranch :: FixedSizedBVWithBoolSpec bv 4)+                               (conSpec $ fromIntegral innerFalseBranch :: FixedSizedBVWithBoolSpec bv 4)+                           ) ::+                           FixedSizedBVWithBoolSpec bv 8+                   let single = symSpec "c" :: FixedSizedBVWithBoolSpec bv 8+                   let spec@(FixedSizedBVWithBoolSpec _ r) =+                         if lhsIsExtend+                           then opSpec extend single+                           else opSpec single extend+                   let expected =+                         iteTerm+                           (ssymTerm "cond" :: Term Bool)+                           (opTerm (conTerm $ fromIntegral innerTrueBranch) (ssymTerm "c"))+                           (opTerm (conTerm $ fromIntegral innerFalseBranch) (ssymTerm "c"))+                   r @?= expected+                   validateSpec @(FixedSizedBVWithBoolSpec bv 8) unboundedConfig spec+         )++bv1Test ::+  forall bv.+  ( SupportedNonFuncPrim (bv 1),+    Num (bv 1),+    Typeable bv,+    PEvalBitwiseTerm (bv 1)+  ) =>+  Test+bv1Test =+  testGroup (show (typeRep @bv) <> " 1") $+    ( do+        (opName, op, v, bvop) <-+          [ ("||", orSpec, 0, andBitsTerm),+            ("||", orSpec, 1, orBitsTerm),+            ("&&", andSpec, 0, orBitsTerm),+            ("&&", andSpec, 1, andBitsTerm)+          ]+        let isV = "==" <> show v+        let name = "(a" <> isV <> ")" <> opName <> "(b" <> isV <> ")"+        let spec@(BoolWithFixedSizedBVSpec _ r) =+              op+                (eqvSpec (symSpec "a" :: FixedSizedBVWithBoolSpec bv 1) (conSpec v))+                (eqvSpec (symSpec "b" :: FixedSizedBVWithBoolSpec bv 1) (conSpec v))+        let expected =+              eqTerm+                ( bvop+                    (ssymTerm "a" :: Term (bv 1))+                    (ssymTerm "b")+                )+                (conTerm v)+        return $ testCase name $ do+          r @?= expected+          validateSpec @(BoolWithFixedSizedBVSpec bv 1) unboundedConfig spec+    )+      ++ ( do+             cond <- [0 :: bv 1, 1]+             t <- [0 :: bv 1, 1]+             let f = 1 - t+             let name = "ite(a==" <> show cond <> "," <> show t <> "," <> show f <> ")"+             let spec@(FixedSizedBVWithBoolSpec _ r) =+                   iteSpec+                     ( eqvSpec+                         (symSpec "a" :: FixedSizedBVWithBoolSpec bv 1)+                         (conSpec cond) ::+                         BoolWithFixedSizedBVSpec bv 1+                     )+                     (conSpec t)+                     (conSpec f)+             let aTerm = ssymTerm "a" :: Term (bv 1)+             let expected =+                   if t == cond+                     then aTerm+                     else complementBitsTerm aTerm+             return $ testCase name $ do+               r @?= expected+               validateSpec @(FixedSizedBVWithBoolSpec bv 1) unboundedConfig spec+         )+      ++ [ testCase "(a==b)==(a==c)" $ do+             let spec@(BoolWithFixedSizedBVSpec _ r) =+                   eqvSpec+                     (eqvSpec (symSpec "a" :: FixedSizedBVWithBoolSpec bv 1) (symSpec "b") :: BoolWithFixedSizedBVSpec bv 1)+                     (eqvSpec (symSpec "a" :: FixedSizedBVWithBoolSpec bv 1) (symSpec "c"))+             validateSpec @(BoolWithFixedSizedBVSpec bv 1)+               unboundedConfig+               spec+             r @?= eqTerm (ssymTerm "b" :: Term (bv 1)) (ssymTerm "c")+         ]++termRewritingTests :: Test+termRewritingTests =+  testGroup+    "TermRewriting"+    [ bv1Test @WordN,+      bv1Test @IntN,+      bvConcatTest @WordN,+      bvConcatTest @IntN,+      testGroup+        "Bool only"+        [ testProperty "Bool only random test" $+            mapSize (`min` 10) $+              ioProperty . \(x :: BoolOnlySpec) -> do+                validateSpec unboundedConfig x,+          testCase "Regression nested ite with (ite a (ite b c d) e) with b is true" $ do+            validateSpec @BoolOnlySpec+              unboundedConfig+              ( iteSpec+                  (symSpec "a" :: BoolOnlySpec)+                  ( iteSpec+                      (orSpec (notSpec (andSpec (symSpec "b1") (symSpec "b2"))) (symSpec "b2") :: BoolOnlySpec)+                      (symSpec "c")+                      (symSpec "d")+                  )+                  (symSpec "e")+              ),+          testCase "Regression for pevalImpliesTerm _ false should be false" $ do+            validateSpec @BoolOnlySpec+              unboundedConfig+              ( iteSpec+                  (symSpec "fbool" :: BoolOnlySpec)+                  ( notSpec+                      ( orSpec+                          (orSpec (notSpec (andSpec (symSpec "gbool" :: BoolOnlySpec) (symSpec "fbool" :: BoolOnlySpec))) (symSpec "gbool" :: BoolOnlySpec))+                          (orSpec (symSpec "abool" :: BoolOnlySpec) (notSpec (andSpec (symSpec "gbool" :: BoolOnlySpec) (symSpec "bbool" :: BoolOnlySpec))))+                      )+                  )+                  (symSpec "xxx" :: BoolOnlySpec)+              ),+          testCase "And absortion" $ do+            let spec@(BoolOnlySpec _ r) =+                  andSpec+                    (orSpec (symSpec "c") (orSpec (symSpec "b") (symSpec "a")))+                    (andSpec (symSpec "a") (andSpec (symSpec "d") (symSpec "e")))+            validateSpec @BoolOnlySpec+              unboundedConfig+              spec+            r @?= andTerm (ssymTerm "a") (andTerm (ssymTerm "d") (ssymTerm "e")),+          testCase "Or absorption" $ do+            let spec@(BoolOnlySpec _ r) =+                  orSpec+                    (andSpec (symSpec "c") (andSpec (symSpec "b") (symSpec "a")))+                    (orSpec (symSpec "a") (orSpec (symSpec "d") (symSpec "e")))+            validateSpec @BoolOnlySpec+              unboundedConfig+              spec+            r @?= orTerm (ssymTerm "a") (orTerm (ssymTerm "d") (ssymTerm "e")),+          testCase "(a==b)==(a==c)" $ do+            let spec@(BoolOnlySpec _ r) =+                  eqvSpec+                    (eqvSpec (symSpec "a" :: BoolOnlySpec) (symSpec "b") :: BoolOnlySpec)+                    (eqvSpec (symSpec "a" :: BoolOnlySpec) (symSpec "c"))+            validateSpec @BoolOnlySpec+              unboundedConfig+              spec+            r @?= eqTerm (ssymTerm "b" :: Term Bool) (ssymTerm "c")+        ],+      testGroup+        "LIA"+        [ testProperty "LIA random test" $+            mapSize (`min` 10) $+              ioProperty . \(x :: LIAWithBoolSpec) -> do+                validateSpec unboundedConfig x,+          testCase "Regression nested ite with (ite a b (ite c d e)) with c implies a" $ do+            validateSpec @LIAWithBoolSpec+              unboundedConfig+              ( iteSpec+                  (notSpec (eqvSpec (symSpec "v" :: LIAWithBoolSpec) (conSpec 1 :: LIAWithBoolSpec) :: BoolWithLIASpec))+                  (symSpec "b")+                  ( iteSpec+                      (eqvSpec (symSpec "v" :: LIAWithBoolSpec) (conSpec 2 :: LIAWithBoolSpec) :: BoolWithLIASpec)+                      (symSpec "d")+                      (symSpec "d")+                  )+              )+        ],+      testGroup+        "NRA"+        [ testProperty "NRA random test" $+            mapSize (`min` 5) $+              ioProperty . \(x :: NRAWithBoolSpec) ->+                validateSpec unboundedConfig x+        ],+      testGroup+        "Different sized signed BV"+        [ testProperty "Random test" $+            withMaxSuccess 1000 . mapSize (`min` 5) $+              ioProperty . \(x :: (DifferentSizeBVSpec IntN 4)) -> do+                validateSpec unboundedConfig x+        ],+      testGroup+        "Fixed sized signed BV"+        [ testProperty "Random test on IntN 1" $+            withMaxSuccess 200 . mapSize (`min` 5) $+              ioProperty . \(x :: (FixedSizedBVWithBoolSpec IntN 1)) -> do+                validateSpec unboundedConfig x,+          testProperty "Random test on IntN 2" $+            withMaxSuccess 200 . mapSize (`min` 5) $+              ioProperty . \(x :: (FixedSizedBVWithBoolSpec IntN 2)) -> do+                validateSpec unboundedConfig x,+          testProperty "Random test on IntN 4" $+            withMaxSuccess 200 . mapSize (`min` 5) $+              ioProperty . \(x :: (FixedSizedBVWithBoolSpec IntN 4)) -> do+                validateSpec unboundedConfig x,+          testProperty "Random test on IntN 63" $+            withMaxSuccess 200 . mapSize (`min` 1) $+              ioProperty . \(x :: (FixedSizedBVWithBoolSpec IntN 63)) -> do+                validateSpec unboundedConfig x,+          testProperty "Random test on IntN 64" $+            withMaxSuccess 200 . mapSize (`min` 1) $+              ioProperty . \(x :: (FixedSizedBVWithBoolSpec IntN 64)) -> do+                validateSpec unboundedConfig x,+          testProperty "Random test on IntN 65" $+            withMaxSuccess 200 . mapSize (`min` 1) $+              ioProperty . \(x :: (FixedSizedBVWithBoolSpec IntN 65)) -> do+                validateSpec unboundedConfig x,+          testProperty "Random test on IntN 128" $+            withMaxSuccess 200 . mapSize (`min` 1) $+              ioProperty . \(x :: (FixedSizedBVWithBoolSpec IntN 128)) -> do+                validateSpec unboundedConfig x+        ],+      testGroup+        "Different sized unsigned BV"+        [ testProperty "random test" $+            withMaxSuccess 1000 . mapSize (`min` 5) $+              ioProperty . \(x :: (DifferentSizeBVSpec WordN 4)) -> do+                validateSpec unboundedConfig x+        ],+      testGroup+        "Fixed sized unsigned BV"+        [ testProperty "Random test on WordN 1" $+            withMaxSuccess 200 . mapSize (`min` 5) $+              ioProperty . \(x :: (FixedSizedBVWithBoolSpec WordN 1)) -> do+                validateSpec unboundedConfig x,+          testProperty "Random test on WordN 2" $+            withMaxSuccess 200 . mapSize (`min` 5) $+              ioProperty . \(x :: (FixedSizedBVWithBoolSpec WordN 2)) -> do+                validateSpec unboundedConfig x,+          testProperty "Random test on WordN 4" $+            withMaxSuccess 200 . mapSize (`min` 5) $+              ioProperty . \(x :: (FixedSizedBVWithBoolSpec WordN 4)) -> do+                validateSpec unboundedConfig x,+          testProperty "Random test on WordN 63" $+            withMaxSuccess 200 . mapSize (`min` 1) $+              ioProperty . \(x :: (FixedSizedBVWithBoolSpec WordN 63)) -> do+                validateSpec unboundedConfig x,+          testProperty "Random test on WordN 64" $+            withMaxSuccess 200 . mapSize (`min` 1) $+              ioProperty . \(x :: (FixedSizedBVWithBoolSpec WordN 64)) -> do+                validateSpec unboundedConfig x,+          testProperty "Random test on WordN 65" $+            withMaxSuccess 200 . mapSize (`min` 1) $+              ioProperty . \(x :: (FixedSizedBVWithBoolSpec WordN 65)) -> do+                validateSpec unboundedConfig x,+          testProperty "Random test on WordN 128" $+            withMaxSuccess 200 . mapSize (`min` 1) $+              ioProperty . \(x :: (FixedSizedBVWithBoolSpec WordN 128)) -> do+                validateSpec unboundedConfig x+        ],+      testCase "Regression: shift twice and the sum of shift amount overflows" $ do+        validateSpec @(FixedSizedBVWithBoolSpec IntN 4)+          unboundedConfig+          ( shiftRightSpec+              (shiftRightSpec (symSpec "fint") (conSpec 0x5))+              (conSpec 0x5)+          ),+      testGroup+        "Regression for abs on unsigned BV"+        [ testCase "abs on negate" $+            validateSpec @(FixedSizedBVWithBoolSpec WordN 4)+              unboundedConfig+              (absNumSpec (negNumSpec (symSpec "a"))),+          testCase "abs on times negate" $+            validateSpec @(FixedSizedBVWithBoolSpec WordN 4)+              unboundedConfig+              (absNumSpec (mulNumSpec (symSpec "a") (negNumSpec (symSpec "b"))))+        ],+      testGroup+        "mulNumSpec on integer"+        [ testCase "times on both concrete" $ do+            traverse_+              (\(x, y) -> validateSpec @(GeneralSpec Integer) unboundedConfig $ mulNumSpec (conSpec x) (conSpec y))+              [(i, j) | i <- [-3 .. 3], j <- [-3 .. 3]],+          testCase "times on single concrete" $ do+            traverse_+              ( \x -> do+                  validateSpec @(GeneralSpec Integer) unboundedConfig $ mulNumSpec (conSpec x) (symSpec "a")+                  validateSpec @(GeneralSpec Integer) unboundedConfig $ mulNumSpec (symSpec "a") (conSpec x)+              )+              [-3 .. 3],+          testCase "Two times with two concrete combined" $ do+            traverse_+              ( \(x, y) -> do+                  validateSpec @(GeneralSpec Integer) unboundedConfig $ mulNumSpec (conSpec x) $ mulNumSpec (conSpec y) (symSpec "a")+                  validateSpec @(GeneralSpec Integer) unboundedConfig $ mulNumSpec (conSpec x) $ mulNumSpec (symSpec "a") (conSpec y)+                  validateSpec @(GeneralSpec Integer) unboundedConfig $ mulNumSpec (mulNumSpec (conSpec x) (symSpec "a")) (conSpec y)+                  validateSpec @(GeneralSpec Integer) unboundedConfig $ mulNumSpec (mulNumSpec (symSpec "a") (conSpec x)) (conSpec y)+              )+              [(i, j) | i <- [-3 .. 3], j <- [-3 .. 3]],+          testCase "Two times with one concrete" $ do+            traverse_+              ( \x -> do+                  validateSpec @(GeneralSpec Integer) unboundedConfig $ mulNumSpec (conSpec x) $ mulNumSpec (symSpec "b") (symSpec "a")+                  validateSpec @(GeneralSpec Integer) unboundedConfig $ mulNumSpec (symSpec "b") $ mulNumSpec (symSpec "a") (conSpec x)+                  validateSpec @(GeneralSpec Integer) unboundedConfig $ mulNumSpec (symSpec "b") $ mulNumSpec (conSpec x) (symSpec "a")+                  validateSpec @(GeneralSpec Integer) unboundedConfig $ mulNumSpec (mulNumSpec (conSpec x) (symSpec "a")) (symSpec "b")+                  validateSpec @(GeneralSpec Integer) unboundedConfig $ mulNumSpec (mulNumSpec (symSpec "a") (conSpec x)) (symSpec "b")+                  validateSpec @(GeneralSpec Integer) unboundedConfig $ mulNumSpec (mulNumSpec (symSpec "a") (symSpec "b")) (conSpec x)+              )+              [-3 .. 3],+          testCase "times and add with two concretes combined" $ do+            traverse_+              ( \(x, y) -> do+                  validateSpec @(GeneralSpec Integer) unboundedConfig $ mulNumSpec (conSpec x) $ addNumSpec (conSpec y) (symSpec "a")+                  validateSpec @(GeneralSpec Integer) unboundedConfig $ mulNumSpec (conSpec x) $ addNumSpec (symSpec "a") (conSpec y)+                  validateSpec @(GeneralSpec Integer) unboundedConfig $ mulNumSpec (addNumSpec (conSpec x) (symSpec "a")) (conSpec y)+                  validateSpec @(GeneralSpec Integer) unboundedConfig $ mulNumSpec (addNumSpec (symSpec "a") (conSpec x)) (conSpec y)+                  validateSpec @(GeneralSpec Integer) unboundedConfig $ addNumSpec (conSpec x) $ mulNumSpec (conSpec y) (symSpec "a")+                  validateSpec @(GeneralSpec Integer) unboundedConfig $ addNumSpec (conSpec x) $ mulNumSpec (symSpec "a") (conSpec y)+                  validateSpec @(GeneralSpec Integer) unboundedConfig $ addNumSpec (mulNumSpec (conSpec x) (symSpec "a")) (conSpec y)+                  validateSpec @(GeneralSpec Integer) unboundedConfig $ addNumSpec (mulNumSpec (symSpec "a") (conSpec x)) (conSpec y)+              )+              [(i, j) | i <- [-3 .. 3], j <- [-3 .. 3]],+          testCase "times concrete with negNumSpec symbolic" $ do+            traverse_+              ( \x -> do+                  validateSpec @(GeneralSpec Integer) unboundedConfig $ mulNumSpec (conSpec x) (negNumSpec $ symSpec "a")+                  validateSpec @(GeneralSpec Integer) unboundedConfig $ mulNumSpec (negNumSpec $ symSpec "a") (conSpec x)+              )+              [-3 .. 3]+        ],+      testGroup+        "divisions on integer"+        [ divisionTest @(GeneralSpec Integer) "div" divIntegralSpec,+          divisionTest @(GeneralSpec Integer) "mod" modIntegralSpec,+          divisionTest @(GeneralSpec Integer) "quot" quotIntegralSpec,+          divisionTest @(GeneralSpec Integer) "rem" remIntegralSpec+        ],+      testGroup+        "divisions on signed bv"+        [ divisionTest @(GeneralSpec (IntN 4)) "div" divIntegralSpec,+          divisionTest @(GeneralSpec (IntN 4)) "mod" modIntegralSpec,+          divisionTest @(GeneralSpec (IntN 4)) "quot" quotIntegralSpec,+          divisionTest @(GeneralSpec (IntN 4)) "rem" remIntegralSpec+        ],+      testGroup+        "divisions on unsigned bv"+        [ divisionTest @(GeneralSpec (WordN 4)) "div" divIntegralSpec,+          divisionTest @(GeneralSpec (WordN 4)) "mod" modIntegralSpec,+          divisionTest @(GeneralSpec (WordN 4)) "quot" quotIntegralSpec,+          divisionTest @(GeneralSpec (WordN 4)) "rem" remIntegralSpec+        ],+      testGroup+        "FP"+        [ testCase "0.0 == -0.0" $+            onlyWhenBitwuzlaIsAvailable+              ( `validateSpec`+                  ( eqvSpec+                      (conSpec 0.0 :: IEEEFPSpec 5 11)+                      (conSpec $ -0.0) ::+                      IEEEFPBoolOpSpec 5 11+                  )+              ),+          testCase "-0.0 <= -0.0" $+            onlyWhenBitwuzlaIsAvailable+              ( `validateSpec`+                  ( leOrdSpec+                      (conSpec 0.0 :: IEEEFPSpec 5 11)+                      (conSpec $ -0.0) ::+                      IEEEFPBoolOpSpec 5 11+                  )+              ),+          testCase "is_pos(nan)" $+            onlyWhenBitwuzlaIsAvailable+              ( `validateSpec`+                  ( fpTraitSpec+                      FPIsPositive+                      (conSpec fpNaN :: IEEEFPSpec 5 11) ::+                      IEEEFPBoolOpSpec 5 11+                  )+              ),+          testCase "is_pos(+inf)" $+            onlyWhenBitwuzlaIsAvailable+              ( `validateSpec`+                  ( fpTraitSpec+                      FPIsPositive+                      ( iteSpec+                          (symSpec "bool" :: BoolOnlySpec)+                          (conSpec fpNegativeInfinite)+                          (conSpec fpPositiveInfinite) ::+                          IEEEFPSpec 5 11+                      ) ::+                      IEEEFPBoolOpSpec 5 11+                  )+              ),+          testCase "regression 2" $+            onlyWhenBitwuzlaIsAvailable+              ( `validateSpec`+                  ( eqvSpec+                      (signumNumSpec (conSpec (1.175e-38) :: IEEEFPSpec 5 11))+                      (symSpec "b") ::+                      IEEEFPBoolOpSpec 5 11+                  )+              ),+          testCase "test sbv bug mitigation sbv#702" $+            onlyWhenBitwuzlaIsAvailable+              ( flip validateSpec $+                  IEEEFPBoolOpSpec+                    ( fpTraitTerm+                        FPIsPositive+                        ( iteTerm+                            (ssymTerm "bool")+                            (conTerm fpNegativeInfinite :: Term FP32)+                            (conTerm fpPositiveInfinite :: Term FP32)+                        )+                    )+                    (notTerm $ ssymTerm "bool")+              ),+          testProperty "FP32BoolOp" $+            withMaxSuccess 1000 . mapSize (`min` 10) $+              ioProperty . \(x :: IEEEFPBoolOpSpec 5 11) ->+                onlyWhenBitwuzlaIsAvailable (`validateSpec` x),+          testProperty "FPRoundingModeBoolOpSpec" $+            mapSize (`min` 10) $+              ioProperty . \(x :: FPRoundingModeBoolOpSpec) ->+                onlyWhenBitwuzlaIsAvailable (`validateSpec` x),+          testGroup "fpBinaryOp" $ do+            op <-+              [FPMaximum, FPMinimum, FPMaximumNumber, FPMinimumNumber, FPRem]+            return $ testCase (show op) $ do+              let lst =+                    [ conSpec fpNegativeInfinite,+                      conSpec fpPositiveInfinite,+                      conSpec fpNaN,+                      conSpec fpPositiveZero,+                      conSpec fpNegativeZero,+                      conSpec 1,+                      conSpec (-1),+                      symSpec "a",+                      symSpec "b"+                    ]+              let ps =+                    [ fpBinaryOpSpec op l r :: IEEEFPSpec 4 4+                    | l <- lst,+                      r <- lst+                    ]+              traverse_ (validateSpec z3) ps,+          testGroup "RoundingOp" $ do+            let rdgen =+                  elements+                    [ conSpec rna :: FPRoundingModeSpec,+                      conSpec rne,+                      conSpec rtz,+                      conSpec rtp,+                      conSpec rtn+                    ]+            let vgen =+                  elements+                    [ conSpec fpNegativeInfinite :: IEEEFPSpec 4 4,+                      conSpec fpPositiveInfinite,+                      conSpec fpNaN,+                      conSpec fpPositiveZero,+                      conSpec fpNegativeZero,+                      conSpec 120,+                      conSpec 60,+                      conSpec 1,+                      conSpec 2,+                      conSpec 3,+                      conSpec 4,+                      conSpec (-1),+                      conSpec (-2),+                      conSpec (-3),+                      conSpec (-4),+                      conSpec 1.5625e-2,+                      conSpec 2.4e2,+                      conSpec 1.953125e-3,+                      conSpec 1.3671875e-2,+                      symSpec "a",+                      symSpec "b"+                    ]+            [ testGroup "fpRoundingUnaryOp" $ do+                op <- [FPSqrt, FPRoundToIntegral]+                return $+                  testProperty (show op) $+                    forAll rdgen $ \rd ->+                      forAll vgen $ \v ->+                        ioProperty $+                          validateSpec z3 $+                            fpRoundingUnaryOpSpec op rd v,+              testGroup "fpRoundingBinaryOp" $ do+                op <- [FPAdd, FPSub, FPMul, FPDiv]+                return $+                  testProperty (show op) $+                    forAll rdgen $ \rd ->+                      forAll (vectorOf 2 vgen) $ \[l, r] ->+                        ioProperty $+                          validateSpec z3 $+                            fpRoundingBinarySpec op rd l r,+              testProperty "fma" $+                forAll rdgen $ \rd ->+                  forAll (vectorOf 3 vgen) $ \[x, y, z] ->+                    ioProperty $+                      validateSpec z3 $+                        fpFMASpec rd x y z+              ]+        ],+      testGroup "bitCast" $ do+        let bitCastCase ::+              forall a b.+              ( Arbitrary a,+                PEvalBitCastTerm a b,+                SupportedNonFuncPrim a,+                SupportedNonFuncPrim b+              ) =>+              Test+            bitCastCase = testProperty+              (show (typeRep @a) <> " -> " <> show (typeRep @b))+              $ \x ->+                withMaxSuccess 10 . ioProperty $+                  validateSpec+                    z3+                    ( bitCastSpec (conSpec x :: GeneralSpec a) ::+                        GeneralSpec b+                    )+        let fromFPCase ::+              forall a b.+              ( Arbitrary a,+                Arbitrary b,+                PEvalBitCastOrTerm a b,+                RealFloat a,+                SupportedNonFuncPrim a,+                SupportedNonFuncPrim b+              ) =>+              Test+            fromFPCase = testProperty+              (show (typeRep @a) <> " -> " <> show (typeRep @b))+              $ \d x ->+                withMaxSuccess 10 . (not (isNaN x) ==>) . ioProperty $+                  validateSpec+                    z3+                    ( bitCastOrSpec+                        (conSpec d :: GeneralSpec b)+                        (conSpec x :: GeneralSpec a)+                    )+        let toFPCase ::+              forall a b.+              ( Arbitrary a,+                PEvalBitCastTerm a b,+                RealFloat b,+                SupportedNonFuncPrim a,+                SupportedNonFuncPrim b+              ) =>+              Test+            toFPCase = testProperty+              (show (typeRep @a) <> " -> " <> show (typeRep @b))+              $ \x ->+                withMaxSuccess 10+                  . (not (isNaN (bitCast x :: b)) ==>)+                  . ioProperty+                  $ validateSpec+                    z3+                    ( bitCastSpec (conSpec x :: GeneralSpec a) ::+                        GeneralSpec b+                    )+        [ bitCastCase @(IntN 4) @(WordN 4),+          bitCastCase @(WordN 4) @(IntN 4),+          bitCastCase @(IntN 1) @Bool,+          bitCastCase @(WordN 1) @Bool,+          bitCastCase @Bool @(IntN 1),+          bitCastCase @Bool @(WordN 1),+          fromFPCase @(FP 3 5) @(IntN 8),+          fromFPCase @(FP 3 5) @(WordN 8),+          toFPCase @(IntN 8) @(FP 3 5),+          toFPCase @(WordN 8) @(FP 3 5)+          ],+      testGroup "FPConvertible" $ do+        let fromFPAssertion ::+              forall eb sb spec b.+              ( ValidFP eb sb,+                PEvalIEEEFPConvertibleTerm b,+                TermRewritingSpec spec b+              ) =>+              b ->+              FPRoundingMode ->+              FP eb sb ->+              IO ()+            fromFPAssertion d rd x+              | fpIsNaN x = return ()+              | otherwise =+                  validateSpec'+                    z3+                    ( con x+                        .== p+                        .&& symNot (symFpIsNaN p)+                    )+                    ( fromFPOrSpec+                        (conSpec d :: spec)+                        (conSpec rd :: GeneralSpec FPRoundingMode)+                        ( wrap (ssymTerm "p") (conTerm x) ::+                            GeneralSpec (FP eb sb)+                        ) ::+                        spec+                    )+              where+                p = "p" :: SymFP eb sb+            fromFPAssertionDirect ::+              forall eb sb spec b.+              ( ValidFP eb sb,+                PEvalIEEEFPConvertibleTerm b,+                TermRewritingSpec spec b+              ) =>+              b ->+              FPRoundingMode ->+              FP eb sb ->+              IO ()+            fromFPAssertionDirect d rd x =+              validateSpec+                z3+                ( fromFPOrSpec+                    (conSpec d :: spec)+                    (conSpec rd :: GeneralSpec FPRoundingMode)+                    (conSpec x :: GeneralSpec (FP eb sb))+                )+            fromFPCase ::+              forall eb sb spec b.+              ( ValidFP eb sb,+                Arbitrary b,+                PEvalIEEEFPConvertibleTerm b,+                TermRewritingSpec spec b+              ) =>+              Bool ->+              Test+            fromFPCase direct = testProperty+              (show (typeRep @(FP eb sb)) <> " -> " <> show (typeRep @b))+              $ \(d :: b) rd (x :: FP eb sb) ->+                withMaxSuccess 10 . ioProperty $+                  ( if direct+                      then fromFPAssertionDirect @eb @sb @spec+                      else fromFPAssertion @eb @sb @spec+                  )+                    d+                    rd+                    x+            toFPAssertion ::+              forall eb sb b bs.+              ( ValidFP eb sb,+                PEvalIEEEFPConvertibleTerm b,+                LinkedRep b bs,+                Solvable b bs,+                SupportedNonFuncPrim b,+                SymEq bs+              ) =>+              FPRoundingMode ->+              b ->+              IO ()+            toFPAssertion rd x =+              validateSpec'+                z3+                ((con x :: SymType b) .== "p")+                ( toFPSpec+                    (conSpec rd :: GeneralSpec FPRoundingMode)+                    (wrap (ssymTerm "p") (conTerm x) :: GeneralSpec b) ::+                    IEEEFPSpec eb sb+                )+            toFPAssertionFP ::+              forall eb sb eb0 sb0.+              ( ValidFP eb sb,+                ValidFP eb0 sb0+              ) =>+              FPRoundingMode ->+              FP eb0 sb0 ->+              IO ()+            toFPAssertionFP _ x | fpIsNaN x = return ()+            toFPAssertionFP rd x =+              validateSpec'+                z3+                ( con x+                    .== p+                    .&& symNot (symFpIsNaN p)+                )+                ( toFPSpec+                    (conSpec rd :: GeneralSpec FPRoundingMode)+                    ( wrap (ssymTerm "p") (conTerm x) ::+                        GeneralSpec (FP eb0 sb0)+                    ) ::+                    IEEEFPSpec eb sb+                )+              where+                p = "p" :: SymFP eb0 sb0+            toFPCase ::+              forall eb sb b bs.+              ( ValidFP eb sb,+                Arbitrary b,+                PEvalIEEEFPConvertibleTerm b,+                SupportedNonFuncPrim b,+                LinkedRep b bs,+                Solvable b bs,+                SymEq bs+              ) =>+              Test+            toFPCase = testProperty+              (show (typeRep @b) <> " -> " <> show (typeRep @(FP eb sb)))+              $ \rd (x :: b) ->+                withMaxSuccess 10 . ioProperty $+                  toFPAssertion @eb @sb rd x+            toFPCaseFP ::+              forall eb sb eb0 sb0.+              ( ValidFP eb sb,+                ValidFP eb0 sb0+              ) =>+              Test+            toFPCaseFP = testProperty+              ( show (typeRep @(FP eb0 sb0))+                  <> " -> "+                  <> show (typeRep @(FP eb sb))+              )+              $ \rd (x :: b) ->+                withMaxSuccess 10 . ioProperty $+                  toFPAssertionFP @eb @sb @eb0 @sb0 rd x+            specialFps :: (ValidFP eb sb) => [FP eb sb]+            specialFps =+              [ fpPositiveZero,+                fpNegativeZero,+                fpPositiveInfinite,+                fpNegativeInfinite,+                fpNaN,+                fpMaxNormalized,+                fpMinNormalized,+                fpMaxSubnormal,+                fpMinSubnormal+              ]+            boundFps ::+              (ConvertibleBound bv, KnownNat n, 1 <= n, ValidFP eb sb) =>+              bv n ->+              FPRoundingMode ->+              [FP eb sb]+            boundFps n mode =+              [ convertibleLowerBound n mode,+                convertibleUpperBound n mode+              ]+            fps ::+              (ConvertibleBound bv, KnownNat n, 1 <= n, ValidFP eb sb) =>+              bv n ->+              FPRoundingMode ->+              [FP eb sb]+            fps n mode =+              specialFps+                ++ boundFps n mode+                ++ (nextFP <$> boundFps n mode)+                ++ (prevFP <$> boundFps n mode)+            boundedFromFPCase ::+              forall bv n eb sb.+              ( ConvertibleBound bv,+                KnownNat n,+                1 <= n,+                ValidFP eb sb,+                PEvalIEEEFPConvertibleTerm (bv n),+                SupportedNonFuncPrim (bv n),+                Num (bv n),+                Typeable bv+              ) =>+              FPRoundingMode ->+              Test+            boundedFromFPCase mode =+              testCase (show (typeRep @bv) ++ "/" ++ show mode) $+                mapM_+                  ( fromFPAssertion @eb @sb @(GeneralSpec (bv n))+                      123+                      mode+                  )+                  (fps (undefined :: (bv n)) mode)+            boundedFromFPTestGroup ::+              forall n eb sb.+              ( KnownNat n,+                1 <= n,+                ValidFP eb sb+              ) =>+              Test+            boundedFromFPTestGroup =+              testGroup+                ( show (typeRep @(FP eb sb))+                    ++ " -> "+                    ++ show (typeRep @(IntN n))+                    ++ "/"+                    ++ show (typeRep @(WordN n))+                )+                $ do+                  mode <- [rna, rne, rtz, rtp, rtn]+                  [ boundedFromFPCase @IntN @n @eb @sb mode,+                    boundedFromFPCase @WordN @n @eb @sb mode+                    ]+        [ -- z3 is buggy with the indirect encoding+          -- https://github.com/Z3Prover/z3/issues/7321+          fromFPCase @4 @4 @(GeneralSpec AlgReal) True,+          toFPCase @4 @4 @AlgReal,+          testCase "FP 4 4 -> Integer" $ do+            sequence_ $+              (fromFPAssertionDirect @4 @4 @(GeneralSpec Integer) 0)+                <$> [rna, rne, rtz, rtp, rtn]+                <*> (specialFps ++ ((/ 4) . fromIntegral <$> [-7 .. 7])),+          toFPCase @4 @4 @Integer,+          fromFPCase @4 @4 @(IEEEFPSpec 3 3) False,+          toFPCaseFP @4 @4 @3 @3,+          fromFPCase @4 @4 @(IEEEFPSpec 5 5) False,+          toFPCaseFP @4 @4 @5 @5,+          toFPCase @4 @4 @(WordN 8),+          toFPCase @4 @4 @(IntN 8),+          boundedFromFPTestGroup @32 @4 @4,+          boundedFromFPTestGroup @12 @4 @16,+          boundedFromFPTestGroup @12 @4 @12,+          boundedFromFPTestGroup @12 @4 @11,+          boundedFromFPTestGroup @12 @4 @10,+          boundedFromFPTestGroup @12 @4 @9,+          boundedFromFPTestGroup @12 @4 @2,+          boundedFromFPTestGroup @10 @4 @16,+          boundedFromFPTestGroup @10 @4 @10,+          boundedFromFPTestGroup @10 @4 @9,+          boundedFromFPTestGroup @10 @4 @8,+          boundedFromFPTestGroup @10 @4 @7,+          boundedFromFPTestGroup @10 @4 @2,+          boundedFromFPTestGroup @9 @4 @16,+          boundedFromFPTestGroup @9 @4 @9,+          boundedFromFPTestGroup @9 @4 @8,+          boundedFromFPTestGroup @9 @4 @7,+          boundedFromFPTestGroup @9 @4 @6,+          boundedFromFPTestGroup @9 @4 @2,+          boundedFromFPTestGroup @8 @4 @16,+          boundedFromFPTestGroup @8 @4 @8,+          boundedFromFPTestGroup @8 @4 @7,+          boundedFromFPTestGroup @8 @4 @6,+          boundedFromFPTestGroup @8 @4 @5,+          boundedFromFPTestGroup @8 @4 @2,+          boundedFromFPTestGroup @7 @4 @16,+          boundedFromFPTestGroup @7 @4 @7,+          boundedFromFPTestGroup @7 @4 @6,+          boundedFromFPTestGroup @7 @4 @5,+          boundedFromFPTestGroup @7 @4 @4,+          boundedFromFPTestGroup @7 @4 @2,+          boundedFromFPTestGroup @5 @4 @16,+          boundedFromFPTestGroup @5 @4 @5,+          boundedFromFPTestGroup @5 @4 @4,+          boundedFromFPTestGroup @5 @4 @3,+          boundedFromFPTestGroup @5 @4 @2+          ]+    ]
test/Grisette/Core/Control/ExceptionTests.hs view
@@ -7,42 +7,30 @@   ( ArrayException (IndexOutOfBounds, UndefinedElement),   ) import Control.Monad.Except (ExceptT (ExceptT))-import Grisette.Core.Control.Exception-  ( AssertionError (AssertionError),-    VerificationConditions (AssertionViolation, AssumptionViolation),-  )-import Grisette.Core.Control.Monad.UnionM (UnionM)-import Grisette.Core.Data.Class.Error-  ( TransformError (transformError),-    symAssert,-  )-import Grisette.Core.Data.Class.EvaluateSym-  ( EvaluateSym (evaluateSym),-  )-import Grisette.Core.Data.Class.ExtractSymbolics-  ( ExtractSymbolics (extractSymbolics),-  )-import Grisette.Core.Data.Class.LogicalOp (LogicalOp (symNot))-import Grisette.Core.Data.Class.Mergeable-  ( Mergeable (rootStrategy),+import Grisette+  ( AsKey (AsKey),+    AssertionError (AssertionError),+    EvalSym (evalSym),+    ExtractSym (extractSym),+    LogicalOp (symNot),+    Mergeable (rootStrategy),     MergingStrategy (SimpleStrategy),-  )-import Grisette.Core.Data.Class.ModelOps-  ( ModelOps (emptyModel),+    ModelOps (emptyModel),+    SimpleMergeable (mrgIte),+    Solvable (con),+    SymEq ((.==)),+    SymOrd (symCompare, (.<), (.<=), (.>), (.>=)),     SymbolSetOps (emptySet),-  )-import Grisette.Core.Data.Class.SEq (SEq ((.==)))-import Grisette.Core.Data.Class.SOrd-  ( SOrd (symCompare, (.<), (.<=), (.>), (.>=)),-  )-import Grisette.Core.Data.Class.SimpleMergeable-  ( SimpleMergeable (mrgIte),+    ToCon (toCon),+    ToSym (toSym),+    TransformError (transformError),+    Union,+    VerificationConditions (AssertionViolation, AssumptionViolation),     mrgIf,     mrgSingle,+    symAssert,   )-import Grisette.Core.Data.Class.Solvable (Solvable (con))-import Grisette.Core.Data.Class.ToCon (ToCon (toCon))-import Grisette.Core.Data.Class.ToSym (ToSym (toSym))+import Grisette.Internal.Core.Data.Class.AsKey (AsKey1 (AsKey1)) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit ((@?=))@@ -57,20 +45,19 @@             toCon AssertionError @?= Just AssertionError,           testCase "ToSym" $ do             toSym AssertionError @?= AssertionError,-          testCase "SEq" $ do-            AssertionError .== AssertionError @?= con True,-          testCase "SOrd" $ 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,+          testCase "SymEq" $ do+            AsKey (AssertionError .== AssertionError) @?= con True,+          testCase "SymOrd" $ do+            AsKey (AssertionError .<= AssertionError) @?= con True+            AsKey (AssertionError .< AssertionError) @?= con False+            AsKey (AssertionError .>= AssertionError) @?= con True+            AsKey (AssertionError .> AssertionError) @?= con False+            AsKey1 (AssertionError `symCompare` AssertionError)+              @?= (mrgSingle EQ :: AsKey1 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@@ -95,51 +82,47 @@           testCase "ToSym" $ do             toSym AssertionViolation @?= AssertionViolation             toSym AssumptionViolation @?= AssumptionViolation,-          testCase "SEq" $ do-            AssertionViolation .== AssertionViolation @?= con True-            AssertionViolation .== AssumptionViolation @?= con False-            AssumptionViolation .== AssertionViolation @?= con False-            AssumptionViolation .== AssumptionViolation @?= con True,-          testCase "SOrd" $ do-            AssertionViolation .<= AssertionViolation @?= con True-            AssertionViolation .< AssertionViolation @?= con False-            AssertionViolation .>= AssertionViolation @?= con True-            AssertionViolation .> AssertionViolation @?= con False-            AssertionViolation-              `symCompare` AssertionViolation-              @?= (mrgSingle EQ :: UnionM Ordering)+          testCase "SymEq" $ do+            AsKey (AssertionViolation .== AssertionViolation) @?= con True+            AsKey (AssertionViolation .== AssumptionViolation) @?= con False+            AsKey (AssumptionViolation .== AssertionViolation) @?= con False+            AsKey (AssumptionViolation .== AssumptionViolation) @?= con True,+          testCase "SymOrd" $ do+            AsKey (AssertionViolation .<= AssertionViolation) @?= con True+            AsKey (AssertionViolation .< AssertionViolation) @?= con False+            AsKey (AssertionViolation .>= AssertionViolation) @?= con True+            AsKey (AssertionViolation .> AssertionViolation) @?= con False+            AsKey1 (AssertionViolation `symCompare` AssertionViolation)+              @?= (mrgSingle EQ :: AsKey1 Union Ordering) -            AssertionViolation .<= AssumptionViolation @?= con True-            AssertionViolation .< AssumptionViolation @?= con True-            AssertionViolation .>= AssumptionViolation @?= con False-            AssertionViolation .> AssumptionViolation @?= con False-            AssertionViolation-              `symCompare` AssumptionViolation-              @?= (mrgSingle LT :: UnionM Ordering)+            AsKey (AssertionViolation .<= AssumptionViolation) @?= con True+            AsKey (AssertionViolation .< AssumptionViolation) @?= con True+            AsKey (AssertionViolation .>= AssumptionViolation) @?= con False+            AsKey (AssertionViolation .> AssumptionViolation) @?= con False+            AsKey1 (AssertionViolation `symCompare` AssumptionViolation)+              @?= (mrgSingle LT :: AsKey1 Union Ordering) -            AssumptionViolation .<= AssertionViolation @?= con False-            AssumptionViolation .< AssertionViolation @?= con False-            AssumptionViolation .>= AssertionViolation @?= con True-            AssumptionViolation .> AssertionViolation @?= con True-            AssumptionViolation-              `symCompare` AssertionViolation-              @?= (mrgSingle GT :: UnionM Ordering)+            AsKey (AssumptionViolation .<= AssertionViolation) @?= con False+            AsKey (AssumptionViolation .< AssertionViolation) @?= con False+            AsKey (AssumptionViolation .>= AssertionViolation) @?= con True+            AsKey (AssumptionViolation .> AssertionViolation) @?= con True+            AsKey1 (AssumptionViolation `symCompare` AssertionViolation)+              @?= (mrgSingle GT :: AsKey1 Union Ordering) -            AssumptionViolation .<= AssumptionViolation @?= con True-            AssumptionViolation .< AssumptionViolation @?= con False-            AssumptionViolation .>= AssumptionViolation @?= con True-            AssumptionViolation .> AssumptionViolation @?= con False-            AssumptionViolation-              `symCompare` AssumptionViolation-              @?= (mrgSingle EQ :: UnionM Ordering),-          testCase "GEvaluateSym" $ do-            evaluateSym False emptyModel AssertionViolation+            AsKey (AssumptionViolation .<= AssumptionViolation) @?= con True+            AsKey (AssumptionViolation .< AssumptionViolation) @?= con False+            AsKey (AssumptionViolation .>= AssumptionViolation) @?= con True+            AsKey (AssumptionViolation .> AssumptionViolation) @?= con False+            AsKey1 (AssumptionViolation `symCompare` AssumptionViolation)+              @?= (mrgSingle EQ :: AsKey1 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"@@ -149,7 +132,7 @@                       (symNot "a")                       (mrgSingle AssertionViolation)                       (mrgSingle AssumptionViolation) ::-                      UnionM VerificationConditions+                      AsKey1 Union VerificationConditions                   ),           testCase             "Transform VerificationConditions to VerificationConditions"@@ -158,7 +141,7 @@               transformError AssumptionViolation @?= AssumptionViolation         ],       testCase "symAssert" $ do-        (symAssert "a" :: ExceptT VerificationConditions UnionM ())+        (symAssert "a" :: ExceptT VerificationConditions (AsKey1 Union) ())           @?= ExceptT             ( mrgIf                 (symNot "a")
− test/Grisette/Core/Control/Monad/UnionMTests.hs 
@@ -1,832 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Grisette.Core.Control.Monad.UnionMTests (unionMTests) where--import qualified Data.ByteString as B-import qualified Data.HashMap.Lazy as ML-import Grisette.Core.BuiltinUnionWrappers (mrgLeft, mrgRight)-import Grisette.Core.Control.Monad.UnionM-  ( UnionM,-    isMerged,-    underlyingUnion,-    unionSize,-  )-import Grisette.Core.Data.Class.EvaluateSym-  ( EvaluateSym (evaluateSym),-  )-import Grisette.Core.Data.Class.ExtractSymbolics-  ( ExtractSymbolics (extractSymbolics),-  )-import Grisette.Core.Data.Class.Function (Function ((#)))-import Grisette.Core.Data.Class.GenSym-  ( ListSpec (ListSpec),-    choose,-    genSym,-    genSymSimple,-  )-import Grisette.Core.Data.Class.ITEOp (ITEOp (symIte))-import Grisette.Core.Data.Class.LogicalOp-  ( LogicalOp (symImplies, symNot, symXor, (.&&), (.||)),-  )-import Grisette.Core.Data.Class.ModelOps-  ( ModelOps (emptyModel),-    ModelRep (buildModel),-    SymbolSetRep (buildSymbolSet),-  )-import Grisette.Core.Data.Class.SEq (SEq ((.==)))-import Grisette.Core.Data.Class.SOrd-  ( SOrd (symCompare, (.<), (.<=), (.>), (.>=)),-  )-import Grisette.Core.Data.Class.SimpleMergeable-  ( SimpleMergeable (mrgIte),-    UnionLike (single, unionIf),-    UnionPrjOp (ifView, leftMost, singleView, toGuardedList),-    merge,-    mrgIf,-    mrgIte1,-    mrgSingle,-    (.#),-    pattern If,-    pattern Single,-  )-import Grisette.Core.Data.Class.Solvable (Solvable (con, conView, isym, ssym))-import Grisette.Core.Data.Class.SubstituteSym (SubstituteSym (substituteSym))-import Grisette.Core.Data.Class.ToCon (ToCon (toCon))-import Grisette.Core.Data.Class.ToSym (ToSym (toSym))-import Grisette.Core.Data.Union (Union (UnionIf, UnionSingle))-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term (TypedSymbol)-import Grisette.IR.SymPrim.Data.Prim.Model-  ( ModelValuePair ((::=)),-  )-import Grisette.IR.SymPrim.Data.SymPrim (SymBool)-import Grisette.TestUtil.SymbolicAssertion ((@?=~))-import Test.Framework (Test, testGroup)-import Test.Framework.Providers.HUnit (testCase)-import Test.HUnit (assertFailure, (@?=))--unionMTests :: Test-unionMTests =-  testGroup-    "UnionM"-    [ testCase "Mergeable" $-        do-          let r =-                ( mrgIf-                    "a"-                    ( mrgSingle-                        ( mrgIf-                            "b"-                            (mrgSingle $ Left "c")-                            (mrgSingle $ Right "d")-                        )-                    )-                    ( mrgSingle-                        ( mrgIf-                            "e"-                            (mrgSingle $ Left "f")-                            (mrgSingle $ Right "g")-                        )-                    ) ::-                    UnionM (UnionM (Either SymBool SymBool))-                )-          isMerged r @?= True-          underlyingUnion (underlyingUnion <$> r)-            @?= UnionSingle-              ( UnionIf-                  (Left $ symIte "a" "c" "f")-                  True-                  (symIte "a" "b" "e")-                  (UnionSingle $ Left $ symIte "a" "c" "f")-                  (UnionSingle $ Right $ symIte "a" "d" "g")-              ),-      testCase "SimpleMergeable" $ do-        let l :: UnionM (Either SymBool SymBool) =-              mrgIf "b" (mrgSingle $ Left "c") (mrgSingle $ Right "d")-        let r = mrgIf "e" (mrgSingle $ Left "f") (mrgSingle $ Right "g")-        let res = mrgIte "a" l r-        let ref =-              UnionIf-                (Left $ symIte "a" "c" "f")-                True-                (symIte "a" "b" "e")-                (UnionSingle $ Left $ symIte "a" "c" "f")-                (UnionSingle $ Right $ symIte "a" "d" "g")-        isMerged res @?= True-        underlyingUnion res @?= ref,-      testCase "SimpleMergeable1" $ do-        let l :: UnionM SymBool = mrgIf "b" (mrgSingle "c") (mrgSingle "d")-        let r :: UnionM SymBool = mrgIf "e" (mrgSingle "f") (mrgSingle "g")-        let res = mrgIte1 "a" l r-        isMerged res @?= True-        underlyingUnion res-          @?= UnionSingle-            ( symIte-                "a"-                (symIte "b" "c" "d")-                (symIte "e" "f" "g")-            ),-      testGroup-        "Functor"-        [ testCase "fmap should work but would strip mergeable knowledge" $ do-            let x :: UnionM Integer =-                  (+ 1) <$> mrgIf "a" (mrgSingle 1) (mrgSingle 2)-            x @?= unionIf "a" (return 2) (return 3)-        ],-      testGroup-        "Applicative"-        [ testCase "pure should work but won't give us mergeable knowledge" $-            (pure 1 :: UnionM Integer) @?= single 1,-          testCase "<*> should work but won't give us mergeable knowledge" $ do-            let f :: UnionM (Integer -> Integer) =-                  mrgIf "a" (mrgSingle id) (mrgSingle (+ 1))-            let v :: UnionM Integer = mrgIf "b" (mrgSingle 1) (mrgSingle 3)-            f-              <*> v-              @?= unionIf-                "a"-                (unionIf "b" (single 1) (single 3))-                (unionIf "b" (single 2) (single 4))-        ],-      testGroup-        "Monad"-        [ testCase "return should work but won't give us mergeable knowledge" $-            (pure 1 :: UnionM Integer) @?= single 1,-          testCase ">>= should work and keeps mergeable knowledge" $ do-            let v :: UnionM Integer = mrgIf "a" (mrgSingle 0) (mrgSingle 1)-            let f :: Integer -> UnionM Integer = \i ->-                  mrgIf "b" (mrgSingle $ i + 1) (mrgSingle $ i + 3)-            (v >>= f)-              @?= mrgIf-                "a"-                (mrgIf "b" (mrgSingle 1) (mrgSingle 3))-                (mrgIf "b" (mrgSingle 2) (mrgSingle 4))-        ],-      testGroup-        "UnionOp"-        [ testCase "single" $ do-            let r1 :: UnionM SymBool = single "a"-            isMerged r1 @?= False-            underlyingUnion r1 @?= UnionSingle "a",-          testGroup-            "unionIf"-            [ testCase "unionIf should work when no merged" $ do-                let r1 :: UnionM SymBool = unionIf "a" (single "b") (single "c")-                isMerged r1 @?= False-                underlyingUnion r1-                  @?= UnionIf "b" False "a" (UnionSingle "b") (UnionSingle "c"),-              testCase-                "unionIf should propagate and merge the results when some branch merged"-                $ do-                  let r1 :: UnionM SymBool =-                        unionIf "a" (mrgSingle "b") (single "c")-                  isMerged r1 @?= True-                  underlyingUnion r1 @?= UnionSingle (symIte "a" "b" "c")-                  let r2 :: UnionM SymBool =-                        unionIf "a" (single "b") (mrgSingle "c")-                  isMerged r2 @?= True-                  underlyingUnion r2 @?= UnionSingle (symIte "a" "b" "c")-                  let r3 :: UnionM SymBool =-                        unionIf "a" (mrgSingle "b") (mrgSingle "c")-                  isMerged r3 @?= True-                  underlyingUnion r3 @?= UnionSingle (symIte "a" "b" "c")-            ],-          testCase "singleView should work" $ do-            singleView (single "a" :: UnionM SymBool) @?= Just "a"-            singleView (mrgSingle "a" :: UnionM SymBool) @?= Just "a"-            singleView-              ( unionIf "a" (single $ Left "b") (single $ Right "c") ::-                  UnionM (Either SymBool SymBool)-              )-              @?= Nothing-            case (single "a" :: UnionM SymBool) of-              Single r -> r @?= "a"-              _ -> assertFailure "Single match failed"-            case (mrgSingle "a" :: UnionM SymBool) of-              Single r -> r @?= "a"-              _ -> assertFailure "Single match failed"-            case ( unionIf "a" (single $ Left "b") (single $ Right "c") ::-                     UnionM (Either SymBool SymBool)-                 ) of-              Single _ -> assertFailure "Single match failed"-              _ -> return (),-          testCase "ifView should work" $ do-            let r1 :: UnionM (Either SymBool SymBool) =-                  unionIf "a" (single $ Left "b") (single $ Right "c")-            let r2 :: UnionM (Either SymBool SymBool) =-                  mrgIf "a" (mrgSingle $ Left "b") (mrgSingle $ Right "c")-            ifView r1 @?= Just ("a", single $ Left "b", single $ Right "c")-            ifView r2-              @?= Just ("a", mrgSingle $ Left "b", mrgSingle $ Right "c")-            ifView (single "a" :: UnionM SymBool) @?= Nothing-            case r1 of-              If c l r -> do-                c @?= "a"-                l @?= single (Left "b")-                r @?= single (Right "c")-              _ -> assertFailure "Single match failed"-            case r2 of-              If c l r -> do-                c @?= "a"-                l @?= mrgSingle (Left "b")-                r @?= mrgSingle (Right "c")-              _ -> assertFailure "Single match failed"-            case single "a" :: UnionM SymBool of-              If {} -> assertFailure "Single match failed"-              _ -> return (),-          testCase "leftMost should work" $ do-            leftMost (single "a" :: UnionM SymBool) @?= "a"-            leftMost (mrgSingle "a" :: UnionM SymBool) @?= "a"-            let r1 :: UnionM (Either SymBool SymBool) =-                  unionIf "a" (single $ Left "b") (single $ Right "c")-            let r2 :: UnionM (Either SymBool SymBool) =-                  mrgIf "a" (mrgSingle $ Left "b") (mrgSingle $ Right "c")-            leftMost r1 @?= Left "b"-            leftMost r2 @?= Left "b",-          testCase "toGuardedList should work" $ do-            let actual =-                  toGuardedList-                    ( mrgIf "a" (single 1) (mrgIf "b" (single 2) (single 3)) ::-                        UnionM Integer-                    )-            let expected =-                  [ ("a", 1),-                    (symNot "a" .&& "b", 2),-                    (symNot "a" .&& symNot "b", 3)-                  ]-            actual @?=~ expected-        ],-      testGroup-        "MonadUnion"-        [ testCase "merge should work" $ do-            let r1 :: UnionM SymBool =-                  merge (unionIf "a" (single "b") (single "c"))-            isMerged r1 @?= True-            underlyingUnion r1 @?= UnionSingle (symIte "a" "b" "c"),-          testCase "mrgSingle should work" $ do-            let r1 :: UnionM SymBool = mrgSingle "a"-            isMerged r1 @?= True-            underlyingUnion r1 @?= UnionSingle "a",-          testGroup-            "mrgIf should work"-            [ testCase "mrgIf should perform lazy evaluation" $ do-                (mrgIf (con True) (mrgSingle "a") undefined :: UnionM SymBool)-                  @?= mrgSingle "a"-                (mrgIf (con False) undefined (mrgSingle "a") :: UnionM SymBool)-                  @?= mrgSingle "a",-              testCase "mrgIf should work" $-                (mrgIf "a" (single "b") (single "c") :: UnionM SymBool)-                  @?= merge (unionIf "a" (single "b") (single "c"))-            ]-        ],-      let a :: SymBool = "a"-          b :: SymBool = "b"-          c :: SymBool = "c"-          d :: SymBool = "d"-          e :: SymBool = "e"-          f :: SymBool = "f"-          g1 :: UnionM (Either SymBool SymBool) =-            mrgIf a (mrgSingle $ Left b) (mrgSingle $ Right c)-          g2 :: UnionM (Either SymBool SymBool) =-            mrgIf d (mrgSingle $ Left e) (mrgSingle $ Right f)-       in testGroup-            "SEq"-            [ testCase "Single/Single" $-                (mrgSingle a :: UnionM SymBool)-                  .== mrgSingle b-                  @?= (a .== b),-              testCase "If/Single" $ do-                g1-                  .== mrgSingle (Left d)-                  @?= symIte a (b .== d) (con False)-                g1-                  .== mrgSingle (Right d)-                  @?= symIte a (con False) (c .== d),-              testCase "Single/If" $ do-                mrgSingle (Left d)-                  .== g1-                  @?= symIte a (d .== b) (con False)-                mrgSingle (Right d)-                  .== g1-                  @?= symIte a (con False) (d .== c),-              testCase "If/If" $-                g1-                  .== g2-                  @?= symIte-                    a-                    (symIte d (b .== e) (con False))-                    (symIte d (con False) (c .== f))-            ],-      let a :: SymBool = "a"-          b :: SymBool = "b"-          c :: SymBool = "c"-          d :: SymBool = "d"-          e :: SymBool = "e"-          f :: SymBool = "f"--          g1 :: UnionM (Either SymBool SymBool) =-            mrgIf a (mrgSingle $ Left b) (mrgSingle $ Right c)-          g2 :: UnionM (Either SymBool SymBool) =-            mrgIf d (mrgSingle $ Left e) (mrgSingle $ Right f)-       in testGroup-            "SOrd"-            [ testCase "Single/Single" $ do-                (mrgSingle a :: UnionM SymBool)-                  .<= mrgSingle b-                  @?= (a .<= b :: SymBool)-                (mrgSingle a :: UnionM SymBool)-                  .< mrgSingle b-                  @?= (a .< b :: SymBool)-                (mrgSingle a :: UnionM SymBool)-                  .>= mrgSingle b-                  @?= (a .>= b :: SymBool)-                (mrgSingle a :: UnionM SymBool)-                  .> mrgSingle b-                  @?= (a .> b :: SymBool)-                (mrgSingle a :: UnionM SymBool)-                  `symCompare` mrgSingle b-                  @?= (a `symCompare` b :: UnionM Ordering),-              testCase "If/Single" $ do-                g1-                  .<= mrgSingle (Left d)-                  @?= symIte a (b .<= d) (con False)-                g1-                  .< mrgSingle (Left d)-                  @?= symIte a (b .< d) (con False)-                g1-                  .>= mrgSingle (Left d)-                  @?= symIte a (b .>= d) (con True)-                g1-                  .> mrgSingle (Left d)-                  @?= symIte a (b .> d) (con True)--                g1-                  `symCompare` mrgSingle (Left d)-                  @?= ( mrgIf a (b `symCompare` d) (mrgSingle GT) ::-                          UnionM Ordering-                      )--                g1-                  .<= mrgSingle (Right d)-                  @?= symIte a (con True) (c .<= d)-                g1-                  .< mrgSingle (Right d)-                  @?= symIte a (con True) (c .< d)-                g1-                  .>= mrgSingle (Right d)-                  @?= symIte a (con False) (c .>= d)-                g1-                  .> mrgSingle (Right d)-                  @?= symIte a (con False) (c .> d)--                g1-                  `symCompare` mrgSingle (Right d)-                  @?= ( mrgIf a (mrgSingle LT) (c `symCompare` d) ::-                          UnionM Ordering-                      ),-              testCase "Single/If" $ do-                mrgSingle (Left d)-                  .<= g1-                  @?= symIte a (d .<= b) (con True)-                mrgSingle (Left d)-                  .< g1-                  @?= symIte a (d .< b) (con True)-                mrgSingle (Left d)-                  .>= g1-                  @?= symIte a (d .>= b) (con False)-                mrgSingle (Left d)-                  .> g1-                  @?= symIte a (d .> b) (con False)--                mrgSingle (Left d)-                  `symCompare` g1-                  @?= ( mrgIf a (d `symCompare` b) (mrgSingle LT) ::-                          UnionM Ordering-                      )--                mrgSingle (Right d)-                  .<= g1-                  @?= symIte a (con False) (d .<= c)-                mrgSingle (Right d)-                  .< g1-                  @?= symIte a (con False) (d .< c)-                mrgSingle (Right d)-                  .>= g1-                  @?= symIte a (con True) (d .>= c)-                mrgSingle (Right d)-                  .> g1-                  @?= symIte a (con True) (d .> c)--                mrgSingle (Right d)-                  `symCompare` g1-                  @?= ( mrgIf a (mrgSingle GT) (d `symCompare` c) ::-                          UnionM Ordering-                      ),-              testCase "If/If" $ do-                g1-                  .<= g2-                  @?= symIte-                    a-                    (symIte d (b .<= e) (con True))-                    (symIte d (con False) (c .<= f))-                g1-                  .< g2-                  @?= symIte-                    a-                    (symIte d (b .< e) (con True))-                    (symIte d (con False) (c .< f))-                g1-                  .>= g2-                  @?= symIte-                    a-                    (symIte d (b .>= e) (con False))-                    (symIte d (con True) (c .>= f))-                g1-                  .> g2-                  @?= symIte-                    a-                    (symIte d (b .> e) (con False))-                    (symIte d (con True) (c .> f))-                g1-                  `symCompare` g2-                  @?= ( mrgIf-                          a-                          (mrgIf d (b `symCompare` e) (mrgSingle LT))-                          (mrgIf d (mrgSingle GT) (c `symCompare` f)) ::-                          UnionM Ordering-                      )-            ],-      testGroup-        "ToSym"-        [ testCase "From single" $-            (toSym True :: UnionM SymBool) @?= mrgSingle (con True),-          testCase "From UnionMBase" $-            (toSym (mrgSingle True :: UnionM Bool) :: UnionM SymBool)-              @?= mrgSingle (con True)-        ],-      testGroup-        "ToCon"-        [ testCase "To single" $ do-            (toCon (mrgSingle (con True) :: UnionM SymBool) :: Maybe Bool)-              @?= Just True-            (toCon (mrgSingle "a" :: UnionM SymBool) :: Maybe Bool) @?= Nothing-            ( toCon-                ( mrgIf "a" (mrgLeft $ con False) (mrgRight $ con True) ::-                    UnionM (Either SymBool SymBool)-                ) ::-                Maybe (Either Bool Bool)-              )-              @?= Nothing,-          testCase "To UnionMBase" $ do-            ( toCon (mrgSingle (con True) :: UnionM SymBool) ::-                Maybe (UnionM Bool)-              )-              @?= Just (mrgSingle True)-            (toCon (mrgSingle "a" :: UnionM SymBool) :: Maybe (UnionM Bool))-              @?= Nothing-            ( toCon-                ( mrgIf "a" (mrgLeft $ con False) (mrgRight $ con True) ::-                    UnionM (Either SymBool SymBool)-                ) ::-                Maybe (UnionM (Either Bool Bool))-              )-              @?= Just (mrgIf "a" (mrgLeft False) (mrgRight True))-            ( toCon-                ( mrgIf "a" (mrgLeft "b") (mrgRight $ con True) ::-                    UnionM (Either SymBool SymBool)-                ) ::-                Maybe (UnionM (Either Bool Bool))-              )-              @?= Nothing-        ],-      testCase "Evaluate" $ do-        let model = emptyModel-        let model1 = buildModel ("a" ::= True, "b" ::= False, "c" ::= True)-        evaluateSym False model (mrgSingle "a")-          @?= (mrgSingle "a" :: UnionM SymBool)-        evaluateSym True model (mrgSingle "a")-          @?= (mrgSingle $ con False :: UnionM SymBool)-        evaluateSym False model1 (mrgSingle "a")-          @?= (mrgSingle $ con True :: UnionM SymBool)-        evaluateSym True model1 (mrgSingle "a")-          @?= (mrgSingle $ con True :: UnionM SymBool)-        evaluateSym-          False-          model1-          ( mrgIf-              "a"-              (mrgSingle $ Left "d")-              (mrgSingle $ Right "e")-          )-          @?= (mrgSingle $ Left "d" :: UnionM (Either SymBool SymBool))-        evaluateSym-          True-          model1-          ( mrgIf-              "a"-              (mrgSingle $ Left "d")-              (mrgSingle $ Right "e")-          )-          @?= (mrgSingle $ Left $ con False :: UnionM (Either SymBool SymBool))-        evaluateSym-          False-          model1-          ( mrgIf-              "d"-              (mrgSingle $ Left "a")-              (mrgSingle $ Right "b")-          )-          @?= ( mrgIf-                  "d"-                  (mrgSingle $ Left $ con True)-                  (mrgSingle $ Right $ con False) ::-                  UnionM (Either SymBool SymBool)-              )-        evaluateSym-          True-          model1-          ( mrgIf-              "d"-              (mrgSingle $ Left "a")-              (mrgSingle $ Right "b")-          )-          @?= (mrgSingle $ Right $ con False :: UnionM (Either SymBool SymBool))-        evaluateSym-          False-          model1-          ( mrgIf-              "a"-              (mrgSingle $ Left "b")-              (mrgSingle $ Right "c")-          )-          @?= ( mrgSingle $ Left $ con False ::-                  UnionM-                    (Either SymBool SymBool)-              ),-      testCase "SubstituteSym" $ do-        let asym = "a" :: TypedSymbol Bool-        let a = "a"-        let b = "b"-        let c = "c"-        substituteSym-          asym-          b-          (mrgSingle $ Left a :: UnionM (Either SymBool SymBool))-          @?= mrgSingle (Left b)-        substituteSym-          asym-          b-          (mrgSingle $ Left c :: UnionM (Either SymBool SymBool))-          @?= mrgSingle (Left c)-        substituteSym-          asym-          b-          (mrgSingle $ Right a :: UnionM (Either SymBool SymBool))-          @?= mrgSingle (Right b)-        substituteSym-          asym-          b-          (mrgSingle $ Right c :: UnionM (Either SymBool SymBool))-          @?= mrgSingle (Right c)-        substituteSym-          asym-          b-          ( mrgIf a (mrgSingle $ Left a) (mrgSingle $ Right c) ::-              UnionM (Either SymBool SymBool)-          )-          @?= mrgIf b (mrgSingle $ Left b) (mrgSingle $ Right c)-        substituteSym-          asym-          b-          ( mrgIf c (mrgSingle $ Left c) (mrgSingle $ Right a) ::-              UnionM (Either SymBool SymBool)-          )-          @?= mrgIf c (mrgSingle $ Left c) (mrgSingle $ Right b),-      testCase "ExtractSymbolic" $ do-        extractSymbolics (mrgSingle "a" :: UnionM SymBool)-          @?= buildSymbolSet ("a" :: TypedSymbol Bool)-        extractSymbolics-          ( mrgIf "a" (mrgSingle $ Left "b") (mrgSingle $ Right "c") ::-              UnionM (Either SymBool SymBool)-          )-          @?= buildSymbolSet-            ( "a" :: TypedSymbol Bool,-              "b" :: TypedSymbol Bool,-              "c" :: TypedSymbol Bool-            ),-      testGroup-        "Num"-        [ testCase "fromInteger" $ (1 :: UnionM Integer) @?= mrgSingle 1,-          testCase "negate" $-            negate (mrgIf "a" (mrgSingle 1) (mrgSingle 2) :: UnionM Integer)-              @?= mrgIf "a" (mrgSingle $ -1) (mrgSingle $ -2),-          testCase "plus" $-            (mrgIf "a" (mrgSingle 0) (mrgSingle 1) :: UnionM Integer)-              + mrgIf "b" (mrgSingle 1) (mrgSingle 3)-              @?= mrgIf-                "a"-                (mrgIf "b" (mrgSingle 1) (mrgSingle 3))-                (mrgIf "b" (mrgSingle 2) (mrgSingle 4)),-          testCase "minus" $-            (mrgIf "a" (mrgSingle 0) (mrgSingle 1) :: UnionM Integer)-              - mrgIf "b" (mrgSingle $ -3) (mrgSingle $ -1)-              @?= mrgIf-                "a"-                (mrgIf (symNot "b") (mrgSingle 1) (mrgSingle 3))-                (mrgIf (symNot "b") (mrgSingle 2) (mrgSingle 4)),-          testCase "times" $-            (mrgIf "a" (mrgSingle 1) (mrgSingle 2) :: UnionM Integer)-              * mrgIf "b" (mrgSingle 3) (mrgSingle 4)-              @?= mrgIf-                "a"-                (mrgIf "b" (mrgSingle 3) (mrgSingle 4))-                (mrgIf "b" (mrgSingle 6) (mrgSingle 8)),-          testCase "abs" $-            abs (mrgIf "a" (mrgSingle $ -1) (mrgSingle 2) :: UnionM Integer)-              @?= mrgIf "a" (mrgSingle 1) (mrgSingle 2),-          testCase "signum" $-            signum (mrgIf "a" (mrgSingle $ -1) (mrgSingle 2) :: UnionM Integer)-              @?= mrgIf "a" (mrgSingle $ -1) (mrgSingle 1)-        ],-      testGroup-        "symIteOp"-        [ testCase "symIte" $-            symIte "a" (mrgSingle "b") (mrgSingle "c")-              @?= (mrgSingle (symIte "a" "b" "c") :: UnionM SymBool)-        ],-      let l = mrgIf "a" (mrgSingle False) (mrgSingle True)-          r = mrgIf "b" (mrgSingle False) (mrgSingle True)-       in testGroup-            "LogicalOp"-            [ testCase ".||" $-                l-                  .|| r-                  @?= ( mrgIf-                          ("a" .&& "b")-                          (mrgSingle False)-                          (mrgSingle True) ::-                          UnionM Bool-                      ),-              testCase ".&&" $-                l-                  .&& r-                  @?= ( mrgIf-                          ("a" .|| "b")-                          (mrgSingle False)-                          (mrgSingle True) ::-                          UnionM Bool-                      ),-              testCase "symNot" $-                symNot l-                  @?= mrgIf (symNot "a") (mrgSingle False) (mrgSingle True),-              testCase "symXor" $-                l-                  `symXor` r-                  @?= ( mrgIf-                          (symIte "a" "b" (symNot "b"))-                          (mrgSingle False)-                          (mrgSingle True) ::-                          UnionM Bool-                      ),-              testCase "symImplies" $-                l-                  `symImplies` r-                  @?= ( mrgIf-                          (symNot "a" .&& "b")-                          (mrgSingle False)-                          (mrgSingle True) ::-                          UnionM Bool-                      )-            ],-      testCase "PrimWrapper" $ do-        con True @?= (mrgSingle $ con True :: UnionM SymBool)-        ssym "a" @?= (mrgSingle "a" :: UnionM SymBool)-        isym "a" 0 @?= (mrgSingle $ isym "a" 0 :: UnionM SymBool)-        conView (mrgSingle $ con True :: UnionM SymBool) @?= Just True-        conView (mrgSingle "a" :: UnionM SymBool) @?= Nothing-        conView-          ( mrgIf-              "a"-              (mrgSingle $ con False)-              (mrgSingle $ con True) ::-              UnionM SymBool-          )-          @?= Nothing,-      testGroup-        "Function class"-        [ testCase "Applying function in UnionMBase" $ do-            let func =-                  mrgIf "a" (mrgSingle (+ 1)) (mrgSingle (+ 2)) ::-                    UnionM (Integer -> Integer)-            func # (1 :: Integer) @?= mrgIf "a" (mrgSingle 2) (mrgSingle 3),-          testCase "Helper for applying on UnionMBase" $ do-            let func (x :: Integer) =-                  mrgIf "a" (mrgSingle $ x + 1) (mrgSingle $ x + 3)-            (func .# (mrgIf "b" (mrgSingle 0) (mrgSingle 1) :: UnionM Integer))-              @?= ( mrgIf-                      "b"-                      (mrgIf "a" (mrgSingle 1) (mrgSingle 3))-                      (mrgIf "a" (mrgSingle 2) (mrgSingle 4)) ::-                      UnionM Integer-                  )-        ],-      testCase "IsString" $ ("x" :: UnionM B.ByteString) @?= mrgSingle "x",-      testGroup-        "GenSym"-        [ testCase "GenSym with spec" $ do-            (genSym (ListSpec 1 3 ()) "a" :: UnionM (UnionM [SymBool]))-              @?= mrgSingle-                ( mrgIf-                    (isym "a" 3)-                    (mrgSingle [isym "a" 2])-                    ( mrgIf-                        (isym "a" 4)-                        (mrgSingle [isym "a" 1, isym "a" 2])-                        (mrgSingle [isym "a" 0, isym "a" 1, isym "a" 2])-                    )-                )-            (genSymSimple (ListSpec 1 3 ()) "a" :: UnionM [SymBool])-              @?= mrgIf-                (isym "a" 3)-                (mrgSingle [isym "a" 2])-                ( mrgIf-                    (isym "a" 4)-                    (mrgSingle [isym "a" 1, isym "a" 2])-                    (mrgSingle [isym "a" 0, isym "a" 1, isym "a" 2])-                ),-          testCase "GenSym with same shape" $-            ( genSym-                ( mrgIf-                    "a"-                    (mrgSingle ["x"])-                    (mrgSingle ["y", "z"]) ::-                    UnionM [SymBool]-                )-                "a" ::-                UnionM [SymBool]-            )-              @?= mrgIf-                (isym "a" 0)-                (mrgSingle [isym "a" 1])-                (mrgSingle [isym "a" 2, isym "a" 3])-        ],-      testGroup-        "Concrete Key HashMaps"-        [ testCase "Concrete Key HashMap should work" $ do-            mrgIte-              "a"-              ( ML.fromList-                  [ (1, mrgSingle $ Just 1),-                    (2, mrgSingle $ Just 2)-                  ] ::-                  ML.HashMap Integer (UnionM (Maybe Integer))-              )-              (ML.fromList [(1, mrgSingle $ Just 2), (3, mrgSingle $ Just 3)])-              @?= ML.fromList-                [ (1, mrgIf "a" (mrgSingle $ Just 1) (mrgSingle $ Just 2)),-                  ( 2,-                    mrgIf-                      (symNot "a")-                      (mrgSingle Nothing)-                      (mrgSingle $ Just 2)-                  ),-                  (3, mrgIf "a" (mrgSingle Nothing) (mrgSingle $ Just 3))-                ]-            mrgIf-              "a"-              ( mrgSingle $-                  ML.fromList-                    [ (1, mrgSingle $ Just 1),-                      (2, mrgSingle $ Just 2)-                    ] ::-                  UnionM (ML.HashMap Integer (UnionM (Maybe Integer)))-              )-              ( mrgSingle-                  ( ML.fromList-                      [ (1, mrgSingle $ Just 2),-                        (3, mrgSingle $ Just 3)-                      ]-                  )-              )-              @?= mrgSingle-                ( ML.fromList-                    [ (1, mrgIf "a" (mrgSingle $ Just 1) (mrgSingle $ Just 2)),-                      ( 2,-                        mrgIf-                          (symNot "a")-                          (mrgSingle Nothing)-                          (mrgSingle $ Just 2)-                      ),-                      (3, mrgIf "a" (mrgSingle Nothing) (mrgSingle $ Just 3))-                    ]-                )-        ],-      testCase-        "unionSize"-        $ do-          unionSize (single 1 :: UnionM Integer) @?= 1-          unionSize (mrgIf (ssym "a") (single 1) (single 2) :: UnionM Integer)-            @?= 2-          unionSize (choose [1, 2, 3, 4, 5, 6, 7] "a" :: UnionM Integer) @?= 7-    ]
test/Grisette/Core/Control/Monad/UnionTests.hs view
@@ -1,839 +1,384 @@-{-# 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.Core.Data.Class.ITEOp (ITEOp (symIte))-import Grisette.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.&&), (.||)))-import Grisette.Core.Data.Class.Mergeable-  ( Mergeable (rootStrategy),-    MergingStrategy (SortedStrategy),-    wrapStrategy,-  )-import Grisette.Core.Data.Class.Solvable (Solvable (con))-import Grisette.Core.Data.Union-  ( Union (UnionIf, UnionSingle),-    fullReconstruct,-    ifWithLeftMost,-    ifWithStrategy,-  )-import Grisette.IR.SymPrim.Data.SymPrim (SymInteger)-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 DataKinds #-}+{-# 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 Data.Maybe (isNothing)+import qualified Data.Text as T+import Grisette+  ( AsKey (AsKey),+    EvalSym (evalSym),+    ExtractSym (extractSym),+    Function ((#)),+    ITEOp (symIte),+    IfViewResult (IfViewResult),+    LogicalOp ((.&&)),+    Mergeable (rootStrategy),+    ModelOps (emptyModel),+    ModelRep (buildModel),+    ModelValuePair ((::=)),+    PPrint (pformat),+    SimpleMergeable (mrgIte),+    Solvable (con, conView, isym, ssym),+    SubstSym (substSym),+    SymBool,+    SymBranching (mrgIfPropagatedStrategy, mrgIfWithStrategy),+    SymEq ((.==)),+    SymInteger,+    SymOrd ((.<=)),+    SymbolSetRep (buildSymbolSet),+    ToCon (toCon),+    ToSym (toSym),+    TryMerge (tryMergeWithStrategy),+    TypedAnySymbol,+    TypedConstantSymbol,+    UnionView (ifView, singleView),+    mrgIf,+    mrgIte1,+    mrgSingle,+    toUnionSym,+    tryMerge,+    unionToCon,+  )+import Grisette.Internal.Core.Control.Monad.Union+  ( Union (Union),+    isMerged,+    unionBase,+    unionBinOp,+    unionSize,+    unionUnaryOp,+  )+import Grisette.Internal.Core.Data.Class.AsKey (AsKey1 (AsKey1, getAsKey1))+import Grisette.Internal.Core.Data.Class.UnionView (liftToMonadUnion, liftUnion)+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 (assertBool, (@?=))++union1 :: AsKey1 Union (Either (AsKey SymBool) (AsKey SymInteger))+union1 = AsKey1 $ mrgIfPropagatedStrategy "u1c" (return $ Left "u1a") (return $ Right "u1b")++union2 :: AsKey1 Union (Either (AsKey SymBool) (AsKey SymInteger))+union2 = AsKey1 $ mrgIfPropagatedStrategy "u2c" (return $ Left "u2a") (return $ Right "u2b")++union12 :: AsKey1 Union (Either (AsKey SymBool) (AsKey SymInteger))+union12 = mrgIfPropagatedStrategy "u12c" union1 union2++unionBase12Merged :: UnionBase (Either (AsKey SymBool) (AsKey SymInteger))+unionBase12Merged =+  ifWithLeftMost+    True+    (symIte "u12c" "u1c" "u2c")+    (UnionSingle (Left (symIte "u12c" "u1a" "u2a")))+    (UnionSingle (Right (symIte "u12c" "u1b" "u2b")))++union12Merged :: AsKey1 Union (Either (AsKey SymBool) (AsKey SymInteger))+union12Merged = AsKey1 $ Union (Just rootStrategy) unionBase12Merged++unionSimple1 :: AsKey1 Union (AsKey SymInteger)+unionSimple1 = mrgIfPropagatedStrategy "u1c" (return "u1a") (return "u1b")++unionSimple1Plus1 :: AsKey1 Union (AsKey SymInteger)+unionSimple1Plus1 =+  mrgIfPropagatedStrategy+    "u1c"+    (return $ "u1a" + 1)+    (return $ "u1b" + 1)++unionSimple2 :: AsKey1 Union (AsKey SymInteger)+unionSimple2 = AsKey1 $ mrgIfPropagatedStrategy "u2c" (return "u2a") (return "u2b")++unionSimple12Merged :: AsKey1 Union (AsKey SymInteger)+unionSimple12Merged =+  AsKey1 $+    Union+      (Just rootStrategy)+      ( UnionSingle+          (symIte "u12c" (symIte "u1c" "u1a" "u1b") (symIte "u2c" "u2a" "u2b"))+      )++unionTests :: Test+unionTests =+  testGroup+    "Union"+    [ testCase "unionBase" $+        AsKey1 (unionBase (getAsKey1 union12Merged)) @?= AsKey1 unionBase12Merged,+      testCase "isMerged" $ do+        isMerged (getAsKey1 union12) @?= False+        isMerged (getAsKey1 union12Merged) @?= True,+      testCase "liftUnion & liftToMonadUnion" $ do+        let expected =+              mrgSingle (symIte "u1c" "u1a" "u1b") :: ExceptT () (AsKey1 Union) (AsKey SymInteger)+        liftUnion (getAsKey1 unionSimple1) @?= expected+        liftToMonadUnion (getAsKey1 unionSimple1) @?= expected,+      testCase "unionSize" $+        unionSize (getAsKey1 union12Merged) @?= 2,+      testCase "unaryOp" $+        unionUnaryOp (+ 1) (getAsKey1 unionSimple1) .@?= (getAsKey1 unionSimple1Plus1),+      testCase "binOp" $ do+        let actual = unionBinOp (+) (getAsKey1 unionSimple1) (getAsKey1 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+        "UnionView"+        [ 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)+                assertBool "ifView should return Nothing" (isNothing actual),+              testCase "is not single (unmerged)" $ do+                let Just (IfViewResult cond left right) = ifView unionSimple1+                let expected =+                      ( "u1c",+                        return "u1a",+                        return "u1b"+                      )+                (AsKey cond, left, right) @?= expected,+              testCase "is not single (merged)" $ do+                let Just (IfViewResult cond left right) = ifView (tryMerge union1)+                let expected =+                      ( "u1c",+                        mrgSingle $ Left "u1a",+                        mrgSingle $ Right "u1b"+                      )+                (AsKey cond, left, right) @?= 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 = "<If u1c u1a u1b>"+            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` "<If u1c (Left u1a) (Right u1b)>"+        ],+      testGroup+        "Functor"+        [ testCase "fmap should work" $ do+            (+ 1) <$> unionSimple1 @?= unionSimple1Plus1+        ],+      testGroup+        "Applicative"+        [ testCase "pure should work" $+            (pure 1 :: AsKey1 Union Int) @?= AsKey1 (Union Nothing (UnionSingle 1)),+          testCase "<*> should work" $+            pure (+ 1) <*> unionSimple1 @?= unionSimple1Plus1+        ],+      testGroup+        "Monad"+        [ testCase "return should work" $+            (return 1 :: AsKey1 Union Int) @?= AsKey1 (Union Nothing (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) should be done with toUnionSym" $ do+        let actual = toUnionSym True :: Union (AsKey SymBool)+        let expected = mrgSingle (con True)+        AsKey actual @?= AsKey expected,+      testCase "toUnionSym (Identity a) (Union b)" $ do+        let actual = toUnionSym $ Identity True :: Union (AsKey SymBool)+        let expected = mrgSingle (con True)+        AsKey actual @?= AsKey expected,+      testCase "toUnionSym (Union a) (Union b)" $ do+        let actual = toUnionSym (mrgSingle True :: Union Bool) :: Union (AsKey SymBool)+        let expected = mrgSingle (con True)+        AsKey actual @?= AsKey expected,+      testCase "ToSym (Identity a) (Union b)" $ do+        let actual = toSym $ Identity True :: Union (AsKey SymBool)+        let expected = return $ con True+        AsKey actual @?= AsKey expected,+      testCase "ToSym (Union a) (Union b)" $ do+        let actual = toSym (mrgSingle True :: Union Bool) :: Union (AsKey SymBool)+        let expected = return $ con True+        AsKey actual @?= AsKey expected,+      testCase "ToSym (Union Integer) SymInteger" $ do+        let actual = toSym (mrgIf "a" 1 2 :: Union Integer)+        let expected = symIte "a" 1 2 :: SymInteger+        AsKey actual @?= AsKey expected,+      testGroup+        "ToCon (Union a) b should be done with unionToCon"+        [ testCase "Const" $ do+            let actual = mrgSingle (con True) :: Union SymBool+            let expected = Just True :: Maybe Bool+            unionToCon actual @?= expected,+          testCase "Not const" $ do+            let actual = mrgSingle "a" :: Union SymBool+            let expected = Nothing :: Maybe Bool+            unionToCon 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 (AsKey1 Union Bool)+            toCon actual @?= expected,+          testCase "Not const" $ do+            let actual = mrgSingle "a" :: Union SymBool+            let expected = Nothing :: Maybe (Union Bool)+            (AsKey <$> (toCon actual)) @?= (AsKey <$> 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" :: AsKey1 Union (AsKey SymBool)+            actual @?= expected,+          testCase "EmptyModel with filling default" $ do+            let actual = evalSym True emptyModel (mrgSingle "a")+            let expected = mrgSingle $ con False :: AsKey1 Union (AsKey SymBool)+            actual @?= expected,+          testCase "non-empty model, simple test" $ do+            let actual = evalSym False model (mrgSingle "a")+            let expected = mrgSingle $ con True :: AsKey1 Union (AsKey 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")+                    ) ::+                    AsKey1 Union (Either (AsKey SymBool) (AsKey SymBool))+            let expected =+                  mrgIf "d" (mrgSingle $ Left (con False)) (mrgSingle $ Right "f")+            actual .@?= expected+          ],+      testCase "SubstSym" $ do+        let actual =+              substSym+                ("a" :: TypedConstantSymbol Bool)+                "b"+                ( mrgIf "a" (return $ Left "a") (return $ Right "c") ::+                    AsKey1 Union (Either (AsKey SymBool) (AsKey SymBool))+                )+        let expected = mrgIf "b" (return $ Left "b") (return $ Right "c")+        actual @?= expected,+      testCase "ExtractSym" $ do+        let actual = extractSym union1+        let expected =+              buildSymbolSet+                ( "u1c" :: TypedAnySymbol Bool,+                  "u1a" :: TypedAnySymbol Bool,+                  "u1b" :: TypedAnySymbol Integer+                )+        actual @?= expected,+      testGroup+        "Solvable"+        [ testCase "con" $ (con True :: AsKey1 Union (AsKey SymBool)) @?= mrgSingle (con True),+          testCase "sym" $ (ssym "a" :: AsKey1 Union (AsKey SymBool)) @?= mrgSingle (ssym "a"),+          testCase "isym" $+            (isym "a" 1 :: AsKey1 Union (AsKey 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) :: AsKey1 Union (AsKey SymInteger -> AsKey SymInteger)+        f # 1 @?= 2     ]
− test/Grisette/Core/Data/BVTests.hs 
@@ -1,483 +0,0 @@-{-# LANGUAGE BinaryLiterals #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE NegativeLiterals #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}--module Grisette.Core.Data.BVTests (bvTests) where--import Control.DeepSeq (NFData (rnf), deepseq, force)-import Control.Exception-  ( ArithException,-    SomeException,-    catch,-    evaluate,-  )-import Control.Monad (when)-import Data.Bifunctor (Bifunctor (bimap))-import Data.Bits-  ( Bits-      ( bit,-        bitSizeMaybe,-        clearBit,-        complement,-        complementBit,-        isSigned,-        popCount,-        rotate,-        rotateL,-        rotateR,-        setBit,-        shift,-        shiftL,-        shiftR,-        testBit,-        xor,-        zeroBits,-        (.&.),-        (.|.)-      ),-    FiniteBits (countLeadingZeros, countTrailingZeros, finiteBitSize),-  )-import Data.Int (Int8)-import Data.Proxy (Proxy (Proxy))-import Data.Typeable (Typeable, typeRep)-import Data.Word (Word8)-import GHC.Stack (HasCallStack)-import Grisette.Core.Data.BV (IntN (IntN), WordN (unWordN))-import Grisette.Core.Data.Class.BitVector-  ( SizedBV-      ( sizedBVConcat,-        sizedBVExt,-        sizedBVSelect,-        sizedBVSext,-        sizedBVZext-      ),-  )-import Test.Framework (Test, TestName, testGroup)-import Test.Framework.Providers.HUnit (testCase)-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.HUnit (Assertion, assertFailure, (@=?))-import Test.QuickCheck (Arbitrary, Property, ioProperty)--unaryConform :: forall a b c d. (Show c, Eq c, HasCallStack) => (a -> b) -> (d -> c) -> (a -> c) -> (b -> d) -> a -> Property-unaryConform a2b d2c f g x = ioProperty $ f x @=? d2c (g (a2b x))--binaryConform ::-  forall a b c d e f.-  (Show e, Eq e, HasCallStack) =>-  (a -> b) ->-  (c -> d) ->-  (f -> e) ->-  (a -> c -> e) ->-  (b -> d -> f) ->-  a ->-  c ->-  Property-binaryConform a2b c2d f2e f g x y = ioProperty $ f x y @=? f2e (g (a2b x) (c2d y))--wordUnaryConform :: (HasCallStack) => (WordN 8 -> WordN 8) -> (Word8 -> Word8) -> Word8 -> Assertion-wordUnaryConform f g x = unWordN (f (fromIntegral x)) @=? toInteger (g x)--wordUnaryNonNegIntConform :: (HasCallStack) => (Int -> WordN 8) -> (Int -> Word8) -> Int -> Assertion-wordUnaryNonNegIntConform f g y = when (y >= 0) $ unWordN (f y) @=? toInteger (g y)--wordBinIntConform :: (HasCallStack) => (WordN 8 -> Int -> WordN 8) -> (Word8 -> Int -> Word8) -> Word8 -> Int -> Assertion-wordBinIntConform f g x y = unWordN (f (fromIntegral x) y) @=? toInteger (g x y)--wordBinNonNegIntConform :: (HasCallStack) => (WordN 8 -> Int -> WordN 8) -> (Word8 -> Int -> Word8) -> Word8 -> Int -> Assertion-wordBinNonNegIntConform f g x y = when (y >= 0) $ unWordN (f (fromIntegral x) y) @=? toInteger (g x y)--wordBinConform :: (HasCallStack) => (WordN 8 -> WordN 8 -> WordN 8) -> (Word8 -> Word8 -> Word8) -> Word8 -> Word8 -> Assertion-wordBinConform f g x y = unWordN (f (fromIntegral x) (fromIntegral y)) @=? toInteger (g x y)--intN8eqint8 :: IntN 8 -> Int8 -> Assertion-intN8eqint8 (IntN v) i-  | v < 0 = assertFailure "Bad IntN"-  | v <= 127 = v @=? fromIntegral i-  | v == 128 = i @=? -128-  | otherwise = 256 - v @=? fromIntegral (-i)--intUnaryConform :: (IntN 8 -> IntN 8) -> (Int8 -> Int8) -> Int8 -> Assertion-intUnaryConform f g x = intN8eqint8 (f (fromIntegral x)) (g x)--intUnaryNonNegIntConform :: (Int -> IntN 8) -> (Int -> Int8) -> Int -> Assertion-intUnaryNonNegIntConform f g y = when (y >= 0) $ intN8eqint8 (f y) (g y)--intBinIntConform :: (IntN 8 -> Int -> IntN 8) -> (Int8 -> Int -> Int8) -> Int8 -> Int -> Assertion-intBinIntConform f g x y = intN8eqint8 (f (fromIntegral x) y) (g x y)--intBinNonNegIntConform :: (IntN 8 -> Int -> IntN 8) -> (Int8 -> Int -> Int8) -> Int8 -> Int -> Assertion-intBinNonNegIntConform f g x y = when (y >= 0) $ intN8eqint8 (f (fromIntegral x) y) (g x y)--intBinConform :: (IntN 8 -> IntN 8 -> IntN 8) -> (Int8 -> Int8 -> Int8) -> Int8 -> Int8 -> Assertion-intBinConform f g x y = intN8eqint8 (f (fromIntegral x) (fromIntegral y)) (g x y)--finiteBitsConformTest ::-  forall ref typ.-  (Arbitrary ref, Typeable ref, Typeable typ, Show ref, Show typ, Eq ref, Eq typ, FiniteBits ref, FiniteBits typ, Integral ref, Integral typ) =>-  Proxy ref ->-  Proxy typ ->-  Int ->-  Test-finiteBitsConformTest pref ptyp numBits =-  testGroup-    (show (typeRep ptyp) ++ " conform to " ++ show (typeRep pref) ++ " for FiniteBits instances")-    [ testCase "finiteBitSize" $ finiteBitSize (0 :: typ) @=? numBits,-      testProperty "countLeadingZeros" $ unaryConform @ref @typ fromIntegral id countLeadingZeros countLeadingZeros,-      testProperty "countTrailingZeros" $ unaryConform @ref @typ fromIntegral id countTrailingZeros countTrailingZeros-    ]--boundedConformTest ::-  forall ref typ.-  (Typeable ref, Typeable typ, Bounded typ, Bounded ref, Integral ref, Num typ, Eq typ, Show typ) =>-  Proxy ref ->-  Proxy typ ->-  Test-boundedConformTest pref ptyp =-  testGroup-    (show (typeRep ptyp) ++ " conform to " ++ show (typeRep pref) ++ " for Bounded instances")-    [ testCase "minBound" $ (minBound :: typ) @=? fromIntegral (minBound :: ref),-      testCase "maxBound" $ (maxBound :: typ) @=? fromIntegral (maxBound :: ref)-    ]--shouldThrow :: (NFData a) => String -> a -> IO ()-shouldThrow name x = do-  errored <- catch (evaluate $ x `deepseq` True) (\(_ :: SomeException) -> return False)-  when errored $ assertFailure $ name ++ " should throw an exception"--succPredLikeTest ::-  forall a b.-  (Arbitrary a, Eq a, Eq b, Show a, Show b, NFData b) =>-  TestName ->-  String ->-  (a -> b) ->-  (a -> a) ->-  (b -> b) ->-  a ->-  b ->-  Test-succPredLikeTest name boundName a2b fa fb bounda boundb =-  testGroup-    name-    [ testProperty (name ++ " non " ++ boundName) $-        ioProperty . \(x :: a) ->-          if x == bounda then return () else a2b (fa x) @=? fb (a2b x),-      testCase (name ++ " " ++ boundName) $ shouldThrow (name ++ " " ++ boundName) $ fb boundb-    ]--enumConformTest ::-  forall ref typ.-  ( Arbitrary ref,-    Typeable ref,-    Typeable typ,-    Eq ref,-    Eq typ,-    Show ref,-    Show typ,-    NFData typ,-    Integral ref,-    Integral typ,-    Bounded ref,-    Bounded typ-  ) =>-  Proxy ref ->-  Proxy typ ->-  Test-enumConformTest pref ptyp =-  testGroup-    (show (typeRep ptyp) ++ " conform to " ++ show (typeRep pref) ++ " for Enum instances")-    [ succPredLikeTest @ref @typ "succ" "maxBound" fromIntegral succ succ maxBound maxBound,-      succPredLikeTest @ref @typ "pred" "minBound" fromIntegral pred pred minBound minBound,-      testGroup-        "toEnum"-        [ testProperty "toEnum in bounds" $-            ioProperty . \(x :: ref) ->-              toInteger (toEnum (fromIntegral x) :: ref) @=? toInteger (toEnum (fromIntegral x) :: typ),-          testCase "toEnum (fromIntegral minBound - 1)" $-            shouldThrow "toEnum (fromIntegral minBound - 1)" (toEnum (fromIntegral (minBound :: typ) - 1) :: typ),-          testCase "toEnum (fromIntegral maxBound + 1)" $-            shouldThrow "toEnum (fromIntegral maxBound + 1)" (toEnum (fromIntegral (maxBound :: typ) + 1) :: typ)-        ],-      testProperty "fromEnum" $ unaryConform @ref @typ fromIntegral id fromEnum fromEnum,-      testProperty "enumFrom" $ unaryConform @ref @typ fromIntegral (fromIntegral <$>) enumFrom enumFrom,-      testProperty "enumFromThen" $ \(x :: ref) y ->-        ioProperty $ do-          if x == y-            then return ()-            else do-              (fromIntegral <$> enumFromThen x y) @=? enumFromThen (fromIntegral x :: typ) (fromIntegral y),-      testProperty "enumFromTo" $ binaryConform @ref @typ fromIntegral fromIntegral (fromIntegral <$>) enumFromTo enumFromTo,-      testProperty "enumFromThenTo" $ \(x :: ref) y z ->-        ioProperty $-          if x == y-            then return ()-            else (fromIntegral <$> enumFromThenTo x y z) @=? enumFromThenTo (fromIntegral x :: typ) (fromIntegral y) (fromIntegral z)-    ]--newtype AEWrapper = AEWrapper ArithException deriving (Eq)--instance Show AEWrapper where-  show (AEWrapper x) = show x--instance NFData AEWrapper where-  rnf (AEWrapper x) = x `seq` ()--sameDiv :: (NFData a, NFData b, Eq b, Show b) => a -> a -> (a -> b) -> (a -> a -> a) -> (b -> b -> b) -> IO ()-sameDiv x y a2b fa fb = do-  xa <- evaluate (force $ Right $ fa x y) `catch` \(e :: ArithException) -> return $ Left $ AEWrapper e-  xb <- evaluate (force $ Right $ fb (a2b x) (a2b y)) `catch` \(e :: ArithException) -> return $ Left $ AEWrapper e-  xb @=? a2b <$> xa--sameDivMod :: (NFData a, NFData b, Eq b, Show b) => a -> a -> (a -> b) -> (a -> a -> (a, a)) -> (b -> b -> (b, b)) -> IO ()-sameDivMod x y a2b fa fb = do-  xa <- evaluate (force $ Right $ fa x y) `catch` \(e :: ArithException) -> return $ Left $ AEWrapper e-  xb <- evaluate (force $ Right $ fb (a2b x) (a2b y)) `catch` \(e :: ArithException) -> return $ Left $ AEWrapper e-  xb @=? bimap a2b a2b <$> xa--divLikeTest ::-  forall a b.-  (Arbitrary a, Eq a, Eq b, Num a, Show a, Bounded a, Bits a, Eq b, Show b, Num b, NFData b, Bounded b, Bits b, NFData a) =>-  TestName ->-  (a -> b) ->-  (a -> a -> a) ->-  (b -> b -> b) ->-  Test-divLikeTest name a2b fa fb =-  testGroup-    name-    [ testCase "divided by zero" $ do-        sameDiv 1 0 a2b fa fb-        sameDiv 0 0 a2b fa fb-        sameDiv (-1) 0 a2b fa fb-        sameDiv minBound 0 a2b fa fb-        sameDiv maxBound 0 a2b fa fb,-      testCase "min divided by -1" $ do-        sameDiv minBound (-1) a2b fa fb,-      testProperty "prop" $ \(x :: a) y -> ioProperty $ sameDiv x y a2b fa fb-    ]--divModLikeTest ::-  forall a b.-  (Arbitrary a, Eq a, Eq b, Num a, NFData a, Show a, Bounded a, Bits a, Eq b, Show b, Num b, NFData b, Bounded b, Bits b) =>-  TestName ->-  (a -> b) ->-  (a -> a -> (a, a)) ->-  (b -> b -> (b, b)) ->-  Test-divModLikeTest name a2b fa fb =-  testGroup-    name-    [ testCase "divided by zero" $ do-        sameDivMod 1 0 a2b fa fb-        sameDivMod 0 0 a2b fa fb-        sameDivMod (-1) 0 a2b fa fb-        sameDivMod minBound 0 a2b fa fb-        sameDivMod maxBound 0 a2b fa fb,-      testCase "min divided by -1" $ do-        sameDivMod minBound (-1) a2b fa fb,-      testProperty "prop" $ \(x :: a) y -> ioProperty $ sameDivMod x y a2b fa fb-    ]--realConformTest ::-  forall proxy ref typ.-  (Typeable ref, Typeable typ, Integral ref, Num typ, Arbitrary ref, Real typ, Show ref) =>-  proxy ref ->-  proxy typ ->-  Test-realConformTest pref ptyp =-  testGroup-    (show (typeRep ptyp) ++ " conform to " ++ show (typeRep pref) ++ " for Real instances")-    [ testProperty "toRational" $ unaryConform @ref @typ fromIntegral id toRational toRational-    ]--integralConformTest ::-  forall ref typ.-  ( Arbitrary ref,-    Typeable ref,-    Typeable typ,-    Eq ref,-    Eq typ,-    Show ref,-    Show typ,-    Num ref,-    Num typ,-    Integral ref,-    Integral typ,-    Bits ref,-    Bits typ,-    Bounded ref,-    Bounded typ,-    NFData typ,-    NFData ref-  ) =>-  Proxy ref ->-  Proxy typ ->-  Test-integralConformTest pref ptyp =-  testGroup-    (show (typeRep ptyp) ++ " conform to " ++ show (typeRep pref) ++ " for Integral instances")-    [ divLikeTest @ref @typ "quot" fromIntegral quot quot,-      divLikeTest @ref @typ "rem" fromIntegral rem rem,-      divModLikeTest @ref @typ "quotRem" fromIntegral quotRem quotRem,-      divLikeTest @ref @typ "div" fromIntegral div div,-      divLikeTest @ref @typ "mod" fromIntegral mod mod,-      divModLikeTest @ref @typ "divMod" fromIntegral divMod divMod,-      testProperty "toInteger" $ unaryConform @ref @typ fromIntegral id toInteger toInteger-    ]--bvTests :: Test-bvTests =-  testGroup-    "BV"-    [ testGroup-        "WordN 8 conform to Word8 for Bits instances"-        [ testProperty "(.&.)" $ \x y -> ioProperty $ wordBinConform (.&.) (.&.) x y,-          testProperty "(.|.)" $ \x y -> ioProperty $ wordBinConform (.|.) (.|.) x y,-          testProperty "xor" $ \x y -> ioProperty $ wordBinConform xor xor x y,-          testProperty "complement" $ ioProperty . wordUnaryConform complement complement,-          testProperty "shift" $ \x y -> ioProperty $ wordBinIntConform shift shift x y,-          testProperty "rotate" $ \x y -> ioProperty $ wordBinIntConform rotate rotate x y,-          testCase "zeroBits" $ (zeroBits :: WordN 8) @=? 0,-          testProperty "bit" $ ioProperty . wordUnaryNonNegIntConform bit bit,-          testProperty "setBit" $ \x y -> ioProperty $ wordBinNonNegIntConform setBit setBit x y,-          testProperty "clearBit" $ \x y -> ioProperty $ wordBinNonNegIntConform clearBit clearBit x y,-          testProperty "complementBit" $ \x y -> ioProperty $ wordBinNonNegIntConform complementBit complementBit x y,-          testProperty "testBit" $ \(x :: Word8) i -> i < 0 || testBit x i == testBit (fromIntegral x :: WordN 8) i,-          testCase "bitSizeMaybe" $ bitSizeMaybe (0 :: WordN 8) @=? Just 8,-          testCase "isSigned" $ isSigned (0 :: WordN 8) @=? False,-          testProperty "shiftL" $ \x y -> ioProperty $ wordBinNonNegIntConform shiftL shiftL x y,-          testProperty "shiftR" $ \x y -> ioProperty $ wordBinNonNegIntConform shiftR shiftR x y,-          testProperty "rotateL" $ \x y -> ioProperty $ wordBinNonNegIntConform rotateL rotateL x y,-          testProperty "rotateR" $ \x y -> ioProperty $ wordBinNonNegIntConform rotateR rotateR x y,-          testProperty "popCount" $ ioProperty . \(x :: Word8) -> popCount x @=? popCount (fromIntegral x :: WordN 8)-        ],-      finiteBitsConformTest (Proxy @Word8) (Proxy @(WordN 8)) 8,-      boundedConformTest (Proxy @Word8) (Proxy @(WordN 8)),-      enumConformTest (Proxy @Word8) (Proxy @(WordN 8)),-      realConformTest (Proxy @Word8) (Proxy @(WordN 8)),-      integralConformTest (Proxy @Word8) (Proxy @(WordN 8)),-      testGroup-        "WordN 8 conform to Word8 for Num instances"-        [ testProperty "(+)" $ \x y -> ioProperty $ wordBinConform (+) (+) x y,-          testProperty "(*)" $ \x y -> ioProperty $ wordBinConform (*) (*) x y,-          testProperty "(-)" $ \x y -> ioProperty $ wordBinConform (-) (-) x y,-          testProperty "negate" $ ioProperty . wordUnaryConform negate negate,-          testProperty "abs" $ ioProperty . wordUnaryConform abs abs,-          testProperty "signum" $ ioProperty . wordUnaryConform signum signum,-          testProperty "fromInteger" $-            ioProperty . \(x :: Integer) ->-              unWordN (fromInteger x :: WordN 8) @=? toInteger (fromInteger x :: Word8)-        ],-      testGroup-        "WordN 8 conform to Word8 for Ord instances"-        [ testProperty "(<=)" $ \(x :: Word8) y -> ioProperty $ x <= y @=? (fromIntegral x :: WordN 8) <= (fromIntegral y :: WordN 8)-        ],-      testGroup-        "IntN 8 conform to Int8 for Bits instances"-        [ testProperty "(.&.)" $ \x y -> ioProperty $ intBinConform (.&.) (.&.) x y,-          testProperty "(.|.)" $ \x y -> ioProperty $ intBinConform (.|.) (.|.) x y,-          testProperty "xor" $ \x y -> ioProperty $ intBinConform xor xor x y,-          testProperty "complement" $ ioProperty . intUnaryConform complement complement,-          testProperty "shift" $ \x y -> ioProperty $ intBinIntConform shift shift x y,-          testProperty "rotate" $ \x y -> ioProperty $ intBinIntConform rotate rotate x y,-          testCase "zeroBits" $ (zeroBits :: IntN 8) @=? 0,-          testProperty "bit" $ ioProperty . intUnaryNonNegIntConform bit bit,-          testProperty "setBit" $ \x y -> ioProperty $ intBinNonNegIntConform setBit setBit x y,-          testProperty "clearBit" $ \x y -> ioProperty $ intBinNonNegIntConform clearBit clearBit x y,-          testProperty "complementBit" $ \x y -> ioProperty $ intBinNonNegIntConform complementBit complementBit x y,-          testProperty "testBit" $ \(x :: Int8) i -> i < 0 || testBit x i == testBit (fromIntegral x :: IntN 8) i,-          testCase "bitSizeMaybe" $ bitSizeMaybe (0 :: IntN 8) @=? Just 8,-          testCase "isSigned" $ isSigned (0 :: IntN 8) @=? True,-          testProperty "shiftL" $ \x y -> ioProperty $ intBinNonNegIntConform shiftL shiftL x y,-          testProperty "shiftR" $ \x y -> ioProperty $ intBinNonNegIntConform shiftR shiftR x y,-          testProperty "rotateL" $ \x y -> ioProperty $ intBinNonNegIntConform rotateL rotateL x y,-          testProperty "rotateR" $ \x y -> ioProperty $ intBinNonNegIntConform rotateR rotateR x y,-          testProperty "popCount" $ ioProperty . \(x :: Int8) -> popCount x @=? popCount (fromIntegral x :: IntN 8)-        ],-      finiteBitsConformTest (Proxy @Int8) (Proxy @(IntN 8)) 8,-      boundedConformTest (Proxy @Int8) (Proxy @(IntN 8)),-      enumConformTest (Proxy @Int8) (Proxy @(IntN 8)),-      realConformTest (Proxy @Int8) (Proxy @(IntN 8)),-      integralConformTest (Proxy @Int8) (Proxy @(IntN 8)),-      testGroup-        "IntN 8 conform to Int8 for Num instances"-        [ testProperty "(+)" $ \x y -> ioProperty $ intBinConform (+) (+) x y,-          testProperty "(*)" $ \x y -> ioProperty $ intBinConform (*) (*) x y,-          testProperty "(-)" $ \x y -> ioProperty $ intBinConform (-) (-) x y,-          testProperty "negate" $ ioProperty . wordUnaryConform negate negate,-          testProperty "abs" $ ioProperty . wordUnaryConform abs abs,-          testProperty "signum" $ ioProperty . wordUnaryConform signum signum,-          testProperty "fromInteger" $-            ioProperty . \(x :: Integer) ->-              intN8eqint8 (fromInteger x :: IntN 8) (fromInteger x :: Int8)-        ],-      testGroup-        "IntN 8 conform to IntN for Ord instances"-        [ testProperty "(<=)" $ \(x :: Int8) y -> ioProperty $ (fromIntegral x :: IntN 8) <= (fromIntegral y :: IntN 8) @=? x <= y-        ],-      testGroup-        "WordN bvops"-        [ testProperty "sizedBVConcat" $ \(x :: Integer) (y :: Integer) ->-            ioProperty $-              sizedBVConcat (fromInteger x :: WordN 5) (fromInteger y :: WordN 7) @=? fromInteger (x * 128 + y `mod` 128),-          testProperty "sizedBVZext" $ ioProperty . \(x :: Integer) -> sizedBVZext (Proxy :: Proxy 12) (fromInteger x :: WordN 7) @=? fromInteger (x `mod` 128),-          testCase "sizedBVSext" $ do-            sizedBVSext (Proxy :: Proxy 12) (0 :: WordN 8) @=? 0-            sizedBVSext (Proxy :: Proxy 12) (1 :: WordN 8) @=? 1-            sizedBVSext (Proxy :: Proxy 12) (127 :: WordN 8) @=? 127-            sizedBVSext (Proxy :: Proxy 12) (128 :: WordN 8) @=? 3968-            sizedBVSext (Proxy :: Proxy 12) (255 :: WordN 8) @=? 4095,-          testProperty "sizedBVExt is sizedBVZext" $-            ioProperty . \(x :: Integer) ->-              sizedBVExt (Proxy :: Proxy 12) (fromInteger x :: WordN 8) @=? sizedBVZext (Proxy :: Proxy 12) (fromInteger x :: WordN 8),-          testCase "sizedBVSelect" $ do-            sizedBVSelect (Proxy :: Proxy 3) (Proxy :: Proxy 3) (0b11100 :: WordN 8) @=? 0b11-            sizedBVSelect (Proxy :: Proxy 3) (Proxy :: Proxy 3) (0b111000 :: WordN 8) @=? 0b111-            sizedBVSelect (Proxy :: Proxy 3) (Proxy :: Proxy 3) (0b101000 :: WordN 8) @=? 0b101-            sizedBVSelect (Proxy :: Proxy 3) (Proxy :: Proxy 3) (0b1010000 :: WordN 8) @=? 0b10-        ],-      testGroup-        "IntN bvops"-        [ testProperty "sizedBVConcat" $ \(x :: Integer) (y :: Integer) ->-            ioProperty $-              sizedBVConcat (fromInteger x :: IntN 5) (fromInteger y :: IntN 7) @=? fromInteger (x * 128 + y `mod` 128),-          testProperty "sizedBVZext" $ ioProperty . \(x :: Integer) -> sizedBVZext (Proxy :: Proxy 12) (fromInteger x :: IntN 7) @=? fromInteger (x `mod` 128),-          testCase "sizedBVSext" $ do-            sizedBVSext (Proxy :: Proxy 12) (0 :: WordN 8) @=? 0-            sizedBVSext (Proxy :: Proxy 12) (1 :: WordN 8) @=? 1-            sizedBVSext (Proxy :: Proxy 12) (127 :: WordN 8) @=? 127-            sizedBVSext (Proxy :: Proxy 12) (128 :: WordN 8) @=? 3968-            sizedBVSext (Proxy :: Proxy 12) (255 :: WordN 8) @=? 4095,-          testProperty "sizedBVExt is sizedBVSext" $-            ioProperty . \(x :: Integer) ->-              sizedBVExt (Proxy :: Proxy 12) (fromInteger x :: IntN 8) @=? sizedBVSext (Proxy :: Proxy 12) (fromInteger x :: IntN 8),-          testCase "sizedBVSelect" $ do-            sizedBVSelect (Proxy :: Proxy 3) (Proxy :: Proxy 3) (0b11100 :: IntN 8) @=? 0b11-            sizedBVSelect (Proxy :: Proxy 3) (Proxy :: Proxy 3) (0b111000 :: IntN 8) @=? 0b111-            sizedBVSelect (Proxy :: Proxy 3) (Proxy :: Proxy 3) (0b101000 :: IntN 8) @=? 0b101-            sizedBVSelect (Proxy :: Proxy 3) (Proxy :: Proxy 3) (0b1010000 :: IntN 8) @=? 0b10-        ],-      testGroup-        "read"-        [ testProperty "read . show" $ \(x :: IntN 8) -> read (show x) == x,-          testProperty "read . show" $ \(x :: WordN 8) -> read (show x) == x,-          testProperty "read . show" $ \(x :: IntN 9) -> read (show x) == x,-          testProperty "read . show" $ \(x :: WordN 9) -> read (show x) == x-        ],-      testGroup-        "Regression"-        [ testCase "division of min bound and minus one for signed bit vector should throw" $ do-            shouldThrow "divMod" $ divMod (minBound :: IntN 8) (-1 :: IntN 8)-            shouldThrow "div" $ div (minBound :: IntN 8) (-1 :: IntN 8)-            shouldThrow "quotRem" $ quotRem (minBound :: IntN 8) (-1 :: IntN 8)-            shouldThrow "quot" $ quot (minBound :: IntN 8) (-1 :: IntN 8),-          testCase "toInteger for IntN 1" $ do-            toInteger (0 :: IntN 1) @=? 0-            toInteger (1 :: IntN 1) @=? (-1),-          testProperty "WordN shiftL by large amount" $ \(x :: WordN 128) ->-            ioProperty $ shiftL x maxBound @=? 0,-          testProperty "IntN shiftL by large amount" $ \(x :: IntN 128) ->-            ioProperty $ shiftL x maxBound @=? 0-        ]-    ]
+ test/Grisette/Core/Data/Class/BitCastTests.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Grisette.Core.Data.Class.BitCastTests (bitCastTests) where++import Data.Typeable (Proxy (Proxy), Typeable, typeRep)+import Grisette+  ( AsKey,+    BitCast (bitCast),+    FP32,+    IntN,+    IntN32,+    LogicalOp (false, true),+    SymBool,+    SymFP32,+    SymIntN,+    SymIntN32,+    SymWordN,+    SymWordN32,+    WordN,+    WordN32,+    bitCastOrCanonical,+    fpNaN,+  )+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit ((@?=))++bitCastBit1Tests ::+  forall b r.+  ( BitCast b r,+    BitCast r b,+    LogicalOp b,+    Num r,+    Typeable b,+    Typeable r,+    Eq b,+    Eq r,+    Show b,+    Show r+  ) =>+  [Test]+bitCastBit1Tests =+  [ testCase (bname <> " to " <> rname) $ do+      bitCast (true :: b) @?= (1 :: r)+      bitCast (false :: b) @?= (0 :: r),+    testCase (rname <> " to " <> bname) $ do+      bitCast (1 :: r) @?= (true :: b)+      bitCast (0 :: r) @?= (false :: b)+  ]+  where+    bname = show $ typeRep (Proxy :: Proxy b)+    rname = show $ typeRep (Proxy :: Proxy r)++bitCastTests :: Test+bitCastTests =+  testGroup+    "BitCast"+    [ testGroup "1 bit" $+        concat+          [ bitCastBit1Tests @Bool @(IntN 1),+            bitCastBit1Tests @Bool @(WordN 1),+            bitCastBit1Tests @(AsKey SymBool) @(AsKey (SymIntN 1)),+            bitCastBit1Tests @(AsKey SymBool) @(AsKey (SymWordN 1))+          ],+      testGroup+        "FP"+        [ testCase "FP32" $ do+            bitCastOrCanonical (-512.625 :: FP32) @?= (0xc4002800 :: WordN32)+            bitCastOrCanonical (fpNaN :: FP32) @?= (0x7fc00000 :: WordN32)+            bitCast (0xc4002800 :: WordN32) @?= (-512.625 :: FP32)+            bitCastOrCanonical (-512.625 :: FP32) @?= (0xc4002800 :: IntN32)+            bitCastOrCanonical (fpNaN :: FP32) @?= (0x7fc00000 :: IntN32)+            bitCast (0xc4002800 :: IntN32) @?= (-512.625 :: FP32),+          testCase "SymFP32" $ do+            bitCastOrCanonical (-512.625 :: SymFP32)+              @?= (0xc4002800 :: AsKey SymWordN32)+            bitCastOrCanonical (fpNaN :: SymFP32) @?= (0x7fc00000 :: AsKey SymWordN32)+            bitCast (0xc4002800 :: SymWordN32) @?= (-512.625 :: AsKey SymFP32)+            bitCastOrCanonical (-512.625 :: SymFP32)+              @?= (0xc4002800 :: AsKey SymIntN32)+            bitCastOrCanonical (fpNaN :: SymFP32) @?= (0x7fc00000 :: AsKey SymIntN32)+            bitCast (0xc4002800 :: SymIntN32) @?= (-512.625 :: AsKey SymFP32)+        ],+      testCase "Nested" $ do+        let int32 = "x" :: AsKey SymIntN32+        let word32 = bitCast int32 :: AsKey SymWordN32+        let final = bitCast word32 :: AsKey SymIntN32+        final @?= int32+    ]
test/Grisette/Core/Data/Class/BoolTests.hs view
@@ -1,30 +1,36 @@ module Grisette.Core.Data.Class.BoolTests (boolTests) where -import Grisette.Core.Data.Class.LogicalOp-  ( LogicalOp (symImplies, symNot, symXor, (.&&), (.||)),+import Grisette+  ( 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
+ test/Grisette/Core/Data/Class/EvalSymTests.hs view
@@ -0,0 +1,961 @@+{-# LANGUAGE DataKinds #-}+{-# 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+  ( AsKey (AsKey),+    EvalSym (evalSym),+    ITEOp (symIte),+    LogicalOp (symNot, (.&&), (.||)),+    ModelOps (emptyModel),+    ModelRep (buildModel),+    ModelValuePair ((::=)),+    Solvable (con, isym, ssym),+    SymBool,+    SymEq ((.==)),+    SymInteger,+    Symbol (IndexedSymbol),+    solve,+    typedAnySymbol,+    z3,+  )+import Test.Framework (Test, TestOptions' (topt_timeout), plusTestOptions, 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"+    [ plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $+        testCase "proper memo" $ do+          let pair = ("a" :: AsKey SymInteger, "b" :: AsKey SymInteger)+          let iter (x, y) = (y, x + y)+          let r = iterate iter pair !! 100+          Right m <- solve z3 $ snd r .== 0+          evalSym True m (snd r) @?= 0,+      testGroup+        "EvalSym for common types"+        [ testGroup+            "SymBool"+            [ let model = emptyModel+                  eval :: AsKey SymBool -> AsKey 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 (AsKey $ (ssym "a" :: SymBool) .== ssym "b")+                          @?= AsKey ((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 :: AsKey SymBool -> AsKey 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 (AsKey $ (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,+                        typedAnySymbol (IndexedSymbol "a" 1) ::= False,+                        "b" ::= False,+                        "c" ::= True+                      )+                  eval :: AsKey SymBool -> AsKey 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 (AsKey $ (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 -> [AsKey SymBool] -> [AsKey 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 (AsKey SymBool) -> Maybe (AsKey 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 (AsKey SymBool) (AsKey SymBool) ->+                    Either (AsKey SymBool) (AsKey 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 (AsKey SymBool) ->+                    MaybeT Maybe (AsKey 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 (AsKey SymBool) Maybe (AsKey SymBool) ->+                    ExceptT (AsKey SymBool) Maybe (AsKey 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 ->+                    (AsKey SymBool, AsKey SymBool) ->+                    (AsKey SymBool, AsKey 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 ->+                    (AsKey SymBool, AsKey SymBool, AsKey SymBool) ->+                    (AsKey SymBool, AsKey SymBool, AsKey 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 ->+                    (AsKey SymBool, AsKey SymBool, AsKey SymBool, AsKey SymBool) ->+                    (AsKey SymBool, AsKey SymBool, AsKey SymBool, AsKey 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 ->+                    ( AsKey SymBool,+                      AsKey SymBool,+                      AsKey SymBool,+                      AsKey SymBool,+                      AsKey SymBool+                    ) ->+                    ( AsKey SymBool,+                      AsKey SymBool,+                      AsKey SymBool,+                      AsKey SymBool,+                      AsKey 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 ->+                    ( AsKey SymBool,+                      AsKey SymBool,+                      AsKey SymBool,+                      AsKey SymBool,+                      AsKey SymBool,+                      AsKey SymBool+                    ) ->+                    ( AsKey SymBool,+                      AsKey SymBool,+                      AsKey SymBool,+                      AsKey SymBool,+                      AsKey SymBool,+                      AsKey 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 ->+                    ( AsKey SymBool,+                      AsKey SymBool,+                      AsKey SymBool,+                      AsKey SymBool,+                      AsKey SymBool,+                      AsKey SymBool,+                      AsKey SymBool+                    ) ->+                    ( AsKey SymBool,+                      AsKey SymBool,+                      AsKey SymBool,+                      AsKey SymBool,+                      AsKey SymBool,+                      AsKey SymBool,+                      AsKey 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 ->+                    ( AsKey SymBool,+                      AsKey SymBool,+                      AsKey SymBool,+                      AsKey SymBool,+                      AsKey SymBool,+                      AsKey SymBool,+                      AsKey SymBool,+                      AsKey SymBool+                    ) ->+                    ( AsKey SymBool,+                      AsKey SymBool,+                      AsKey SymBool,+                      AsKey SymBool,+                      AsKey SymBool,+                      AsKey SymBool,+                      AsKey SymBool,+                      AsKey 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 (AsKey SymBool) ->+                    Sum Maybe Maybe (AsKey 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 (AsKey SymBool) (Either (AsKey SymBool)) (AsKey SymBool) ->+                        WriterLazy.WriterT (AsKey SymBool) (Either (AsKey SymBool)) (AsKey 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 (AsKey SymBool) (Either (AsKey SymBool)) (AsKey SymBool) ->+                        WriterStrict.WriterT (AsKey SymBool) (Either (AsKey SymBool)) (AsKey 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 (AsKey SymBool) -> Identity (AsKey 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 (AsKey SymBool)) (AsKey SymBool) ->+                    IdentityT (Either (AsKey SymBool)) (AsKey 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)+                        ]+                    ]+            ]+        ]+    ]
− test/Grisette/Core/Data/Class/EvaluateSymTests.hs 
@@ -1,929 +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 (TypedSymbol (IndexedSymbol))-import Grisette.Core.Data.Class.EvaluateSym (EvaluateSym (evaluateSym))-import Grisette.Core.Data.Class.ITEOp (ITEOp (symIte))-import Grisette.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.&&), (.||)))-import Grisette.Core.Data.Class.ModelOps-  ( ModelOps (emptyModel),-    ModelRep (buildModel),-  )-import Grisette.Core.Data.Class.SEq (SEq ((.==)))-import Grisette.Core.Data.Class.Solvable (Solvable (con, isym, ssym))-import Grisette.IR.SymPrim.Data.Prim.Model-  ( ModelValuePair ((::=)),-  )-import Grisette.IR.SymPrim.Data.SymPrim (SymBool)-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,-                        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)-                        ]-                    ]-            ]-        ]-    ]
+ test/Grisette/Core/Data/Class/ExtractSymTests.hs view
@@ -0,0 +1,271 @@+{-# LANGUAGE DataKinds #-}+{-# 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, (.&&), (.||)),+    Solvable (ssym),+    SymBool,+    SymEq ((.==)),+    SymbolSetOps (emptySet),+    SymbolSetRep (buildSymbolSet),+  )+import Grisette.Core.Data.Class.TestValues+  ( isymBool,+    isymbolBool,+    ssymBool,+    ssymbolBool,+    symTrue,+  )+import Grisette.Internal.SymPrim.SymInteger (SymInteger)+import Test.Framework (Test, TestOptions' (topt_timeout), plusTestOptions, 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"+    [ plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $+        testCase "proper memo" $ do+          let pair = ("a" :: SymInteger, "b" :: SymInteger)+          let iter (x, y) = (y, x + y)+          let r = iterate iter pair !! 100+          extractSym r @?= extractSym pair,+      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 (ssym "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 (ssym "a") :: Either SymBool SymBool)+                  @?= buildSymbolSet (ssymbolBool "a"),+              testCase "Right v" $+                extractSym+                  (Right (ssym "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 (ssym "a"))) ::+                      ExceptT SymBool Maybe SymBool+                  )+                  @?= buildSymbolSet (ssymbolBool "a"),+              testCase "ExceptT (Just (Right v))" $+                extractSym+                  ( ExceptT (Just (Right (ssym "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 (ssym "a", ssym "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 (ssym "a", ssym "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 (ssym "a") ::+                      IdentityT (Either SymBool) SymBool+                  )+                  @?= buildSymbolSet (ssymbolBool "a"),+              testCase "Identity (Right v)" $+                extractSym+                  ( IdentityT $ Right (ssym "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 (ssym "a"))+                  @?= buildSymbolSet (ssymbolBool "a"),+              testCase "A3" $+                extractSym (A3 (ssym "a") (ssym "b"))+                  @?= buildSymbolSet (ssymbolBool "a", ssymbolBool "b")+            ]+        ]+    ]
− test/Grisette/Core/Data/Class/ExtractSymbolicsTests.hs 
@@ -1,264 +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.Core.Data.Class.ExtractSymbolics-  ( ExtractSymbolics (extractSymbolics),-  )-import Grisette.Core.Data.Class.ITEOp (ITEOp (symIte))-import Grisette.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.&&), (.||)))-import Grisette.Core.Data.Class.ModelOps-  ( SymbolSetOps (emptySet),-    SymbolSetRep (buildSymbolSet),-  )-import Grisette.Core.Data.Class.SEq (SEq ((.==)))-import Grisette.Core.Data.Class.TestValues-  ( isymBool,-    isymbolBool,-    ssymBool,-    ssymbolBool,-    symTrue,-  )-import Grisette.IR.SymPrim.Data.SymPrim (SymBool)-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")-            ]-        ]-    ]
− test/Grisette/Core/Data/Class/GPrettyTests.hs 
@@ -1,357 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingVia #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Grisette.Core.Data.Class.GPrettyTests (gprettyTests) where--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.Core.Data.BV-  ( IntN,-    SomeIntN (SomeIntN),-    SomeWordN (SomeWordN),-    WordN,-  )-import Grisette.Core.Data.Class.GPretty (GPretty (gpretty))-import Grisette.Core.Data.Class.LogicalOp (LogicalOp ((.&&)))-import Grisette.IR.SymPrim.Data.SymPrim (SymBool)-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))-            )-        ],-      testGroup-        "Symbolic types"-        [ testGPretty-            "enough space"-            80-            ("a" .&& "b" :: SymBool)-            "(&& a b)",-          testGPretty-            "not enough space"-            6-            ("a" .&& "b" :: SymBool)-            "..."-        ]-    ]
test/Grisette/Core/Data/Class/GenSymTests.hs view
@@ -3,1263 +3,1332 @@  module Grisette.Core.Data.Class.GenSymTests (genSymTests) where -import Control.Monad.Except (ExceptT (ExceptT))-import Control.Monad.Trans.Maybe (MaybeT (MaybeT))-import Grisette.Core.Control.Monad.UnionM (UnionM)-import Grisette.Core.Data.Class.GenSym-  ( EnumGenBound (EnumGenBound),-    EnumGenUpperBound (EnumGenUpperBound),-    Fresh,-    FreshT,-    GenSymSimple (simpleFresh),-    ListSpec (ListSpec),-    SimpleListSpec (SimpleListSpec),-    choose,-    chooseFresh,-    chooseSimple,-    chooseSimpleFresh,-    chooseUnion,-    chooseUnionFresh,-    genSym,-    genSymSimple,-    liftFresh,-    runFresh,-    runFreshT,-  )-import Grisette.Core.Data.Class.ITEOp (ITEOp (symIte))-import Grisette.Core.Data.Class.SimpleMergeable-  ( mrgIf,-    mrgSingle,-  )-import Grisette.Core.Data.Class.TestValues (conBool, isymBool, ssymBool)-import Grisette.IR.SymPrim.Data.SymPrim (SymBool)-import Test.Framework (Test, testGroup)-import Test.Framework.Providers.HUnit (testCase)-import Test.HUnit ((@?=))--genSymTests :: Test-genSymTests =-  testGroup-    "GenSym"-    [ testGroup-        "GenSym for common types"-        [ testGroup-            "SymBool"-            [ testGroup-                "() spec"-                [ testCase "genSym" $-                    (genSym () "a" :: UnionM SymBool)-                      @?= mrgSingle (isymBool "a" 0),-                  testCase "genSymSimple" $-                    (genSymSimple () "a" :: SymBool)-                      @?= isymBool "a" 0-                ],-              testGroup-                "SymBool spec"-                [ testCase "genSym" $-                    (genSym (conBool True) "a" :: UnionM SymBool)-                      @?= mrgSingle (isymBool "a" 0),-                  testCase "genSymSimple" $-                    (genSymSimple (conBool True) "a" :: SymBool)-                      @?= isymBool "a" 0-                ]-            ],-          testGroup-            "Bool"-            [ testCase "() spec" $-                (genSym () "a" :: UnionM Bool)-                  @?= mrgIf (isymBool "a" 0) (mrgSingle False) (mrgSingle True),-              testGroup-                "Bool spec"-                [ testGroup-                    "genSym"-                    [ testCase "True" $-                        (genSym True "a" :: UnionM Bool)-                          @?= mrgSingle True,-                      testCase "False" $-                        (genSym False "a" :: UnionM Bool)-                          @?= mrgSingle False-                    ],-                  testGroup-                    "genSymSimple"-                    [ testCase "True" $-                        (genSymSimple True "a" :: Bool)-                          @?= True,-                      testCase "False" $-                        (genSymSimple False "a" :: Bool)-                          @?= False-                    ]-                ]-            ],-          testGroup-            "Integer"-            [ testGroup-                "Integer spec"-                [ testCase "genSym" $-                    (genSym (1 :: Integer) "a" :: UnionM Integer)-                      @?= mrgSingle 1,-                  testCase "genSymSimple" $-                    (genSymSimple (1 :: Integer) "a" :: Integer)-                      @?= 1-                ],-              testCase "Upper bound spec" $-                ( genSym (EnumGenUpperBound (3 :: Integer)) "a" ::-                    UnionM 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)-                  @?= mrgIf-                    (isymBool "a" 0)-                    (mrgSingle (-1))-                    (mrgIf (isymBool "a" 1) (mrgSingle 0) (mrgSingle 1))-            ],-          testGroup-            "Char"-            [ testGroup-                "Char spec"-                [ testCase "genSym" $-                    (genSym 'x' "a" :: UnionM Char)-                      @?= mrgSingle 'x',-                  testCase "genSymSimple" $-                    (genSymSimple 'x' "a" :: Char) @?= 'x'-                ],-              testCase "Upper bound spec" $-                (genSym (EnumGenUpperBound @Char (toEnum 3)) "a" :: UnionM Char)-                  @?= mrgIf-                    (isymBool "a" 0)-                    (mrgSingle $ toEnum 0)-                    ( mrgIf-                        (isymBool "a" 1)-                        (mrgSingle $ toEnum 1)-                        (mrgSingle $ toEnum 2)-                    ),-              testCase "Bound spec" $-                (genSym (EnumGenBound 'a' 'd') "a" :: UnionM Char)-                  @?= mrgIf-                    (isymBool "a" 0)-                    (mrgSingle 'a')-                    (mrgIf (isymBool "a" 1) (mrgSingle 'b') (mrgSingle 'c'))-            ],-          testGroup-            "Maybe SymBool"-            [ testGroup-                "Maybe SymBool spec"-                [ testGroup-                    "Nothing"-                    [ testCase "genSym" $-                        ( genSym (Nothing :: Maybe SymBool) "a" ::-                            UnionM (Maybe SymBool)-                        )-                          @?= mrgSingle Nothing,-                      testCase "genSymSimple" $-                        ( genSymSimple (Nothing :: Maybe SymBool) "a" ::-                            Maybe SymBool-                        )-                          @?= Nothing-                    ],-                  testGroup-                    "Just v"-                    [ testCase "genSym" $-                        ( genSym (Just (ssymBool "a")) "a" ::-                            UnionM (Maybe SymBool)-                        )-                          @?= mrgSingle (Just (isymBool "a" 0)),-                      testCase "genSymSimple" $-                        ( genSymSimple (Just (ssymBool "a")) "a" ::-                            Maybe SymBool-                        )-                          @?= Just (isymBool "a" 0)-                    ]-                ],-              testCase "() spec" $-                (genSym () "a" :: UnionM (Maybe SymBool))-                  @?= mrgIf-                    (isymBool "a" 0)-                    (mrgSingle Nothing)-                    (mrgSingle (Just (isymBool "a" 1)))-            ],-          testGroup-            "Either SymBool SymBool"-            [ testGroup-                "Either SymBool SymBool spec"-                [ testGroup-                    "Left v"-                    [ testCase "genSym" $-                        ( genSym-                            ( Left (ssymBool "a") ::-                                Either SymBool SymBool-                            )-                            "a" ::-                            UnionM (Either SymBool SymBool)-                        )-                          @?= mrgSingle (Left (isymBool "a" 0)),-                      testCase "genSymSimple" $-                        ( genSymSimple-                            ( Left (ssymBool "a") ::-                                Either SymBool SymBool-                            )-                            "a" ::-                            Either SymBool SymBool-                        )-                          @?= Left (isymBool "a" 0)-                    ],-                  testGroup-                    "Right v"-                    [ testCase "genSym" $-                        ( genSym-                            ( Right (ssymBool "a") ::-                                Either SymBool SymBool-                            )-                            "a" ::-                            UnionM (Either SymBool SymBool)-                        )-                          @?= mrgSingle (Right (isymBool "a" 0)),-                      testCase "genSymSimple" $-                        ( genSymSimple-                            ( Right (ssymBool "a") ::-                                Either SymBool SymBool-                            )-                            "a" ::-                            Either SymBool SymBool-                        )-                          @?= Right (isymBool "a" 0)-                    ]-                ],-              testCase "() spec" $ do-                (genSym () "a" :: UnionM (Either SymBool SymBool))-                  @?= mrgIf-                    (isymBool "a" 0)-                    (mrgSingle $ Left $ isymBool "a" 1)-                    (mrgSingle $ Right $ isymBool "a" 2)-            ],-          testGroup-            "lists"-            [ testGroup-                "Max length spec"-                [ testCase "max length = 0" $-                    (genSym (0 :: Integer) "a" :: UnionM [SymBool])-                      @?= mrgSingle [],-                  testCase "max length = 3" $-                    (genSym (3 :: Integer) "a" :: UnionM [SymBool])-                      @?= mrgIf-                        (isymBool "a" 3)-                        (mrgSingle [])-                        ( mrgIf-                            (isymBool "a" 4)-                            (mrgSingle [isymBool "a" 2])-                            ( mrgIf-                                (isymBool "a" 5)-                                (mrgSingle [isymBool "a" 1, isymBool "a" 2])-                                ( mrgSingle-                                    [ isymBool "a" 0,-                                      isymBool "a" 1,-                                      isymBool "a" 2-                                    ]-                                )-                            )-                        )-                ],-              testGroup-                "Min & max length spec"-                [ testCase "min length = 1, max length = 3" $-                    (genSym (ListSpec 1 3 ()) "a" :: UnionM [SymBool])-                      @?= mrgIf-                        (isymBool "a" 3)-                        (mrgSingle [isymBool "a" 2])-                        ( mrgIf-                            (isymBool "a" 4)-                            (mrgSingle [isymBool "a" 1, isymBool "a" 2])-                            ( mrgSingle-                                [ isymBool "a" 0,-                                  isymBool "a" 1,-                                  isymBool "a" 2-                                ]-                            )-                        ),-                  testCase "min length = 1, max length = 2, nested" $-                    ( genSym (ListSpec 1 2 (ListSpec 1 2 ())) "a" ::-                        UnionM [UnionM [SymBool]]-                    )-                      @?= mrgIf-                        (isymBool "a" 6)-                        ( mrgSingle-                            [ mrgIf-                                (isymBool "a" 5)-                                (mrgSingle [isymBool "a" 4])-                                (mrgSingle [isymBool "a" 3, isymBool "a" 4])-                            ]-                        )-                        ( mrgSingle-                            [ mrgIf-                                (isymBool "a" 2)-                                (mrgSingle [isymBool "a" 1])-                                (mrgSingle [isymBool "a" 0, isymBool "a" 1]),-                              mrgIf-                                (isymBool "a" 5)-                                (mrgSingle [isymBool "a" 4])-                                (mrgSingle [isymBool "a" 3, isymBool "a" 4])-                            ]-                        )-                ],-              testGroup-                "Exact length spec"-                [ testGroup-                    "length = 2"-                    [ testCase "genSym" $-                        (genSym (SimpleListSpec 2 ()) "a" :: UnionM [SymBool])-                          @?= mrgSingle [isymBool "a" 0, isymBool "a" 1],-                      testCase "genSymSimple" $-                        (genSymSimple (SimpleListSpec 2 ()) "a" :: [SymBool])-                          @?= [isymBool "a" 0, isymBool "a" 1]-                    ],-                  testGroup-                    "length = 2, nested"-                    [ testCase "genSym" $-                        ( genSym-                            (SimpleListSpec 2 (SimpleListSpec 2 ()))-                            "a" ::-                            UnionM [[SymBool]]-                        )-                          @?= mrgSingle-                            [ [isymBool "a" 0, isymBool "a" 1],-                              [isymBool "a" 2, isymBool "a" 3]-                            ],-                      testCase "genSymSimple" $-                        ( genSymSimple-                            (SimpleListSpec 2 (SimpleListSpec 2 ()))-                            "a" ::-                            [[SymBool]]-                        )-                          @?= [ [isymBool "a" 0, isymBool "a" 1],-                                [isymBool "a" 2, isymBool "a" 3]-                              ]-                    ]-                ],-              testGroup-                "List with same shape spec"-                [ testCase "genSym" $-                    ( genSym-                        [[conBool True], [ssymBool "a", ssymBool "b"]]-                        "a" ::-                        UnionM [[SymBool]]-                    )-                      @?= mrgSingle-                        [ [isymBool "a" 0],-                          [isymBool "a" 1, isymBool "a" 2]-                        ],-                  testCase "genSymSimple" $-                    ( genSymSimple-                        [ [conBool True],-                          [ssymBool "a", ssymBool "b"]-                        ]-                        "a" ::-                        [[SymBool]]-                    )-                      @?= [[isymBool "a" 0], [isymBool "a" 1, isymBool "a" 2]]-                ]-            ],-          testGroup-            "()"-            [ testCase "() spec" $ do-                (genSym () "a" :: UnionM ()) @?= mrgSingle ()-                (genSymSimple () "a" :: ()) @?= ()-            ],-          testGroup-            "(,)"-            [ testGroup-                "Some spec"-                [ testCase "genSym" $-                    ( genSym-                        ( EnumGenUpperBound @Integer 2,-                          EnumGenUpperBound @Integer 2-                        )-                        "a" ::-                        UnionM (Integer, Integer)-                    )-                      @?= do-                        x1 <- mrgIf (isymBool "a" 0) (mrgSingle 0) (mrgSingle 1)-                        x2 <- mrgIf (isymBool "a" 1) (mrgSingle 0) (mrgSingle 1)-                        mrgSingle (x1, x2),-                  testCase "genSymSimple" $-                    ( genSymSimple-                        ( (),-                          [ [ssymBool "b"],-                            [ssymBool "b", ssymBool "c"]-                          ]-                        )-                        "a" ::-                        (SymBool, [[SymBool]])-                    )-                      @?= ( isymBool "a" 0,-                            [ [isymBool "a" 1],-                              [isymBool "a" 2, isymBool "a" 3]-                            ]-                          )-                ],-              testGroup-                "No spec"-                [ testCase "genSym" $-                    (genSym () "a" :: UnionM (SymBool, SymBool))-                      @?= mrgSingle (isymBool "a" 0, isymBool "a" 1),-                  testCase "genSymSimple" $-                    (genSymSimple () "a" :: (SymBool, SymBool))-                      @?= (isymBool "a" 0, isymBool "a" 1)-                ]-            ],-          testGroup-            "(,,)"-            [ testGroup-                "Some spec"-                [ testCase "genSym" $-                    ( genSym-                        ( EnumGenUpperBound @Integer 2,-                          EnumGenUpperBound @Integer 2,-                          EnumGenUpperBound @Integer 2-                        )-                        "a" ::-                        UnionM (Integer, Integer, Integer)-                    )-                      @?= do-                        x1 <- mrgIf (isymBool "a" 0) (mrgSingle 0) (mrgSingle 1)-                        x2 <- mrgIf (isymBool "a" 1) (mrgSingle 0) (mrgSingle 1)-                        x3 <- mrgIf (isymBool "a" 2) (mrgSingle 0) (mrgSingle 1)-                        mrgSingle (x1, x2, x3),-                  testCase "genSymSimple" $-                    ( genSymSimple-                        ((), [[ssymBool "b"], [ssymBool "b", ssymBool "c"]], ())-                        "a" ::-                        (SymBool, [[SymBool]], SymBool)-                    )-                      @?= ( isymBool "a" 0,-                            [ [isymBool "a" 1],-                              [isymBool "a" 2, isymBool "a" 3]-                            ],-                            isymBool "a" 4-                          )-                ],-              testGroup-                "No spec"-                [ testCase "genSym" $-                    (genSym () "a" :: UnionM (SymBool, SymBool, SymBool))-                      @?= mrgSingle-                        (isymBool "a" 0, isymBool "a" 1, isymBool "a" 2),-                  testCase "genSymSimple" $-                    (genSymSimple () "a" :: (SymBool, SymBool, SymBool))-                      @?= (isymBool "a" 0, isymBool "a" 1, isymBool "a" 2)-                ]-            ],-          testGroup-            "(,,,)"-            [ testGroup-                "Some spec"-                [ testCase "genSym" $-                    ( genSym-                        ( EnumGenUpperBound @Integer 2,-                          EnumGenUpperBound @Integer 2,-                          EnumGenUpperBound @Integer 2,-                          EnumGenUpperBound @Integer 2-                        )-                        "a" ::-                        UnionM (Integer, Integer, Integer, Integer)-                    )-                      @?= do-                        x1 <- mrgIf (isymBool "a" 0) (mrgSingle 0) (mrgSingle 1)-                        x2 <- mrgIf (isymBool "a" 1) (mrgSingle 0) (mrgSingle 1)-                        x3 <- mrgIf (isymBool "a" 2) (mrgSingle 0) (mrgSingle 1)-                        x4 <- mrgIf (isymBool "a" 3) (mrgSingle 0) (mrgSingle 1)-                        mrgSingle (x1, x2, x3, x4),-                  testCase "genSymSimple" $-                    ( genSymSimple-                        ( (),-                          [[ssymBool "b"], [ssymBool "b", ssymBool "c"]],-                          (),-                          ()-                        )-                        "a" ::-                        (SymBool, [[SymBool]], SymBool, SymBool)-                    )-                      @?= ( isymBool "a" 0,-                            [ [isymBool "a" 1],-                              [isymBool "a" 2, isymBool "a" 3]-                            ],-                            isymBool "a" 4,-                            isymBool "a" 5-                          )-                ],-              testGroup-                "No spec"-                [ testCase "genSym" $-                    ( genSym () "a" ::-                        UnionM (SymBool, SymBool, SymBool, SymBool)-                    )-                      @?= mrgSingle-                        ( isymBool "a" 0,-                          isymBool "a" 1,-                          isymBool "a" 2,-                          isymBool "a" 3-                        ),-                  testCase "genSymSimple" $-                    ( genSymSimple () "a" ::-                        (SymBool, SymBool, SymBool, SymBool)-                    )-                      @?= ( isymBool "a" 0,-                            isymBool "a" 1,-                            isymBool "a" 2,-                            isymBool "a" 3-                          )-                ]-            ],-          testGroup-            "(,,,,)"-            [ testGroup-                "Some spec"-                [ testCase "genSym" $-                    ( genSym-                        ( EnumGenUpperBound @Integer 2,-                          EnumGenUpperBound @Integer 2,-                          EnumGenUpperBound @Integer 2,-                          EnumGenUpperBound @Integer 2,-                          EnumGenUpperBound @Integer 2-                        )-                        "a" ::-                        UnionM (Integer, Integer, Integer, Integer, Integer)-                    )-                      @?= do-                        x1 <- mrgIf (isymBool "a" 0) (mrgSingle 0) (mrgSingle 1)-                        x2 <- mrgIf (isymBool "a" 1) (mrgSingle 0) (mrgSingle 1)-                        x3 <- mrgIf (isymBool "a" 2) (mrgSingle 0) (mrgSingle 1)-                        x4 <- mrgIf (isymBool "a" 3) (mrgSingle 0) (mrgSingle 1)-                        x5 <- mrgIf (isymBool "a" 4) (mrgSingle 0) (mrgSingle 1)-                        mrgSingle (x1, x2, x3, x4, x5),-                  testCase "genSymSimple" $-                    ( genSymSimple-                        ( (),-                          [ [ssymBool "b"],-                            [ssymBool "b", ssymBool "c"]-                          ],-                          (),-                          (),-                          ()-                        )-                        "a" ::-                        (SymBool, [[SymBool]], SymBool, SymBool, SymBool)-                    )-                      @?= ( isymBool "a" 0,-                            [ [isymBool "a" 1],-                              [isymBool "a" 2, isymBool "a" 3]-                            ],-                            isymBool "a" 4,-                            isymBool "a" 5,-                            isymBool "a" 6-                          )-                ],-              testGroup-                "No spec"-                [ testCase "genSym" $-                    ( genSym () "a" ::-                        UnionM (SymBool, SymBool, SymBool, SymBool, SymBool)-                    )-                      @?= mrgSingle-                        ( isymBool "a" 0,-                          isymBool "a" 1,-                          isymBool "a" 2,-                          isymBool "a" 3,-                          isymBool "a" 4-                        ),-                  testCase "genSymSimple" $-                    ( genSymSimple () "a" ::-                        (SymBool, SymBool, SymBool, SymBool, SymBool)-                    )-                      @?= ( isymBool "a" 0,-                            isymBool "a" 1,-                            isymBool "a" 2,-                            isymBool "a" 3,-                            isymBool "a" 4-                          )-                ]-            ],-          testGroup-            "(,,,,,)"-            [ testGroup-                "Some spec"-                [ testCase "genSym" $-                    ( genSym-                        ( EnumGenUpperBound @Integer 2,-                          EnumGenUpperBound @Integer 2,-                          EnumGenUpperBound @Integer 2,-                          EnumGenUpperBound @Integer 2,-                          EnumGenUpperBound @Integer 2,-                          EnumGenUpperBound @Integer 2-                        )-                        "a" ::-                        UnionM-                          ( Integer,-                            Integer,-                            Integer,-                            Integer,-                            Integer,-                            Integer-                          )-                    )-                      @?= do-                        x1 <- mrgIf (isymBool "a" 0) (mrgSingle 0) (mrgSingle 1)-                        x2 <- mrgIf (isymBool "a" 1) (mrgSingle 0) (mrgSingle 1)-                        x3 <- mrgIf (isymBool "a" 2) (mrgSingle 0) (mrgSingle 1)-                        x4 <- mrgIf (isymBool "a" 3) (mrgSingle 0) (mrgSingle 1)-                        x5 <- mrgIf (isymBool "a" 4) (mrgSingle 0) (mrgSingle 1)-                        x6 <- mrgIf (isymBool "a" 5) (mrgSingle 0) (mrgSingle 1)-                        mrgSingle (x1, x2, x3, x4, x5, x6),-                  testCase "genSymSimple" $-                    ( genSymSimple-                        ( (),-                          [ [ssymBool "b"],-                            [ssymBool "b", ssymBool "c"]-                          ],-                          (),-                          (),-                          (),-                          ()-                        )-                        "a" ::-                        ( SymBool,-                          [[SymBool]],-                          SymBool,-                          SymBool,-                          SymBool,-                          SymBool-                        )-                    )-                      @?= ( isymBool "a" 0,-                            [ [isymBool "a" 1],-                              [isymBool "a" 2, isymBool "a" 3]-                            ],-                            isymBool "a" 4,-                            isymBool "a" 5,-                            isymBool "a" 6,-                            isymBool "a" 7-                          )-                ],-              testGroup-                "No spec"-                [ testCase "genSym" $-                    ( genSym () "a" ::-                        UnionM-                          ( SymBool,-                            SymBool,-                            SymBool,-                            SymBool,-                            SymBool,-                            SymBool-                          )-                    )-                      @?= mrgSingle-                        ( isymBool "a" 0,-                          isymBool "a" 1,-                          isymBool "a" 2,-                          isymBool "a" 3,-                          isymBool "a" 4,-                          isymBool "a" 5-                        ),-                  testCase "genSymSimple" $-                    ( genSymSimple () "a" ::-                        ( SymBool,-                          SymBool,-                          SymBool,-                          SymBool,-                          SymBool,-                          SymBool-                        )-                    )-                      @?= ( isymBool "a" 0,-                            isymBool "a" 1,-                            isymBool "a" 2,-                            isymBool "a" 3,-                            isymBool "a" 4,-                            isymBool "a" 5-                          )-                ]-            ],-          testGroup-            "(,,,,,,)"-            [ testGroup-                "Some spec"-                [ testCase "genSym" $-                    ( genSym-                        ( EnumGenUpperBound @Integer 2,-                          EnumGenUpperBound @Integer 2,-                          EnumGenUpperBound @Integer 2,-                          EnumGenUpperBound @Integer 2,-                          EnumGenUpperBound @Integer 2,-                          EnumGenUpperBound @Integer 2,-                          EnumGenUpperBound @Integer 2-                        )-                        "a" ::-                        UnionM-                          ( Integer,-                            Integer,-                            Integer,-                            Integer,-                            Integer,-                            Integer,-                            Integer-                          )-                    )-                      @?= do-                        x1 <- mrgIf (isymBool "a" 0) (mrgSingle 0) (mrgSingle 1)-                        x2 <- mrgIf (isymBool "a" 1) (mrgSingle 0) (mrgSingle 1)-                        x3 <- mrgIf (isymBool "a" 2) (mrgSingle 0) (mrgSingle 1)-                        x4 <- mrgIf (isymBool "a" 3) (mrgSingle 0) (mrgSingle 1)-                        x5 <- mrgIf (isymBool "a" 4) (mrgSingle 0) (mrgSingle 1)-                        x6 <- mrgIf (isymBool "a" 5) (mrgSingle 0) (mrgSingle 1)-                        x7 <- mrgIf (isymBool "a" 6) (mrgSingle 0) (mrgSingle 1)-                        mrgSingle (x1, x2, x3, x4, x5, x6, x7),-                  testCase "genSymSimple" $-                    ( genSymSimple-                        ( (),-                          [ [ssymBool "b"],-                            [ssymBool "b", ssymBool "c"]-                          ],-                          (),-                          (),-                          (),-                          (),-                          ()-                        )-                        "a" ::-                        ( SymBool,-                          [[SymBool]],-                          SymBool,-                          SymBool,-                          SymBool,-                          SymBool,-                          SymBool-                        )-                    )-                      @?= ( isymBool "a" 0,-                            [ [isymBool "a" 1],-                              [isymBool "a" 2, isymBool "a" 3]-                            ],-                            isymBool "a" 4,-                            isymBool "a" 5,-                            isymBool "a" 6,-                            isymBool "a" 7,-                            isymBool "a" 8-                          )-                ],-              testGroup-                "No spec"-                [ testCase "genSym" $-                    ( genSym () "a" ::-                        UnionM-                          ( SymBool,-                            SymBool,-                            SymBool,-                            SymBool,-                            SymBool,-                            SymBool,-                            SymBool-                          )-                    )-                      @?= mrgSingle-                        ( isymBool "a" 0,-                          isymBool "a" 1,-                          isymBool "a" 2,-                          isymBool "a" 3,-                          isymBool "a" 4,-                          isymBool "a" 5,-                          isymBool "a" 6-                        ),-                  testCase "genSymSimple" $-                    ( genSymSimple () "a" ::-                        ( SymBool,-                          SymBool,-                          SymBool,-                          SymBool,-                          SymBool,-                          SymBool,-                          SymBool-                        )-                    )-                      @?= ( isymBool "a" 0,-                            isymBool "a" 1,-                            isymBool "a" 2,-                            isymBool "a" 3,-                            isymBool "a" 4,-                            isymBool "a" 5,-                            isymBool "a" 6-                          )-                ]-            ],-          testGroup-            "(,,,,,,,)"-            [ testGroup-                "Some spec"-                [ testCase "genSym" $-                    ( genSym-                        ( EnumGenUpperBound @Integer 2,-                          EnumGenUpperBound @Integer 2,-                          EnumGenUpperBound @Integer 2,-                          EnumGenUpperBound @Integer 2,-                          EnumGenUpperBound @Integer 2,-                          EnumGenUpperBound @Integer 2,-                          EnumGenUpperBound @Integer 2,-                          EnumGenUpperBound @Integer 2-                        )-                        "a" ::-                        UnionM-                          ( Integer,-                            Integer,-                            Integer,-                            Integer,-                            Integer,-                            Integer,-                            Integer,-                            Integer-                          )-                    )-                      @?= do-                        x1 <- mrgIf (isymBool "a" 0) (mrgSingle 0) (mrgSingle 1)-                        x2 <- mrgIf (isymBool "a" 1) (mrgSingle 0) (mrgSingle 1)-                        x3 <- mrgIf (isymBool "a" 2) (mrgSingle 0) (mrgSingle 1)-                        x4 <- mrgIf (isymBool "a" 3) (mrgSingle 0) (mrgSingle 1)-                        x5 <- mrgIf (isymBool "a" 4) (mrgSingle 0) (mrgSingle 1)-                        x6 <- mrgIf (isymBool "a" 5) (mrgSingle 0) (mrgSingle 1)-                        x7 <- mrgIf (isymBool "a" 6) (mrgSingle 0) (mrgSingle 1)-                        x8 <- mrgIf (isymBool "a" 7) (mrgSingle 0) (mrgSingle 1)-                        mrgSingle (x1, x2, x3, x4, x5, x6, x7, x8),-                  testCase "genSymSimple" $-                    ( genSymSimple-                        ( (),-                          [ [ssymBool "b"],-                            [ssymBool "b", ssymBool "c"]-                          ],-                          (),-                          (),-                          (),-                          (),-                          (),-                          ()-                        )-                        "a" ::-                        ( SymBool,-                          [[SymBool]],-                          SymBool,-                          SymBool,-                          SymBool,-                          SymBool,-                          SymBool,-                          SymBool-                        )-                    )-                      @?= ( isymBool "a" 0,-                            [ [isymBool "a" 1],-                              [isymBool "a" 2, isymBool "a" 3]-                            ],-                            isymBool "a" 4,-                            isymBool "a" 5,-                            isymBool "a" 6,-                            isymBool "a" 7,-                            isymBool "a" 8,-                            isymBool "a" 9-                          )-                ],-              testGroup-                "No spec"-                [ testCase "genSym" $-                    ( genSym () "a" ::-                        UnionM-                          ( SymBool,-                            SymBool,-                            SymBool,-                            SymBool,-                            SymBool,-                            SymBool,-                            SymBool,-                            SymBool-                          )-                    )-                      @?= mrgSingle-                        ( isymBool "a" 0,-                          isymBool "a" 1,-                          isymBool "a" 2,-                          isymBool "a" 3,-                          isymBool "a" 4,-                          isymBool "a" 5,-                          isymBool "a" 6,-                          isymBool "a" 7-                        ),-                  testCase "genSymSimple" $-                    ( genSymSimple () "a" ::-                        ( SymBool,-                          SymBool,-                          SymBool,-                          SymBool,-                          SymBool,-                          SymBool,-                          SymBool,-                          SymBool-                        )-                    )-                      @?= ( isymBool "a" 0,-                            isymBool "a" 1,-                            isymBool "a" 2,-                            isymBool "a" 3,-                            isymBool "a" 4,-                            isymBool "a" 5,-                            isymBool "a" 6,-                            isymBool "a" 7-                          )-                ]-            ],-          testGroup-            "MaybeT Maybe SymBool"-            [ testGroup-                "Same shape spec"-                [ testGroup-                    "MaybeT Nothing"-                    [ testCase "genSym" $-                        ( genSym (MaybeT Nothing :: MaybeT Maybe SymBool) "a" ::-                            UnionM (MaybeT Maybe SymBool)-                        )-                          @?= mrgSingle (MaybeT Nothing),-                      testCase "genSymSimple" $-                        ( genSymSimple-                            (MaybeT Nothing :: MaybeT Maybe SymBool)-                            "a" ::-                            MaybeT Maybe SymBool-                        )-                          @?= MaybeT Nothing-                    ],-                  testGroup-                    "MaybeT (Just Nothing)"-                    [ testCase "genSym" $-                        ( genSym-                            ( MaybeT (Just Nothing) ::-                                MaybeT Maybe SymBool-                            )-                            "a" ::-                            UnionM (MaybeT Maybe SymBool)-                        )-                          @?= mrgSingle (MaybeT (Just Nothing)),-                      testCase "genSymSimple" $-                        ( genSymSimple-                            ( MaybeT (Just (Just $ ssymBool "a")) ::-                                MaybeT Maybe SymBool-                            )-                            "a" ::-                            MaybeT Maybe SymBool-                        )-                          @?= MaybeT (Just (Just $ isymBool "a" 0))-                    ],-                  testGroup-                    "MaybeT (Just (Just v))"-                    [ testCase "genSym" $-                        ( genSym-                            ( MaybeT (Just (Just $ ssymBool "a")) ::-                                MaybeT Maybe SymBool-                            )-                            "a" ::-                            UnionM (MaybeT Maybe SymBool)-                        )-                          @?= mrgSingle (MaybeT (Just (Just $ isymBool "a" 0))),-                      testCase "genSymSimple" $-                        ( genSymSimple-                            ( MaybeT (Just (Just $ ssymBool "a")) ::-                                MaybeT Maybe SymBool-                            )-                            "a" ::-                            MaybeT Maybe SymBool-                        )-                          @?= MaybeT (Just (Just $ isymBool "a" 0))-                    ]-                ],-              testCase "No spec" $-                (genSym () "a" :: UnionM (MaybeT Maybe SymBool))-                  @?= mrgIf-                    (isymBool "a" 0)-                    (mrgSingle $ MaybeT Nothing)-                    ( mrgIf-                        (isymBool "a" 1)-                        (mrgSingle $ MaybeT $ Just Nothing)-                        (mrgSingle $ MaybeT $ Just $ Just $ isymBool "a" 2)-                    ),-              testGroup-                "Maybe (Maybe SymBool) spec"-                [ testGroup-                    "Nothing"-                    [ testCase "genSym" $-                        ( genSym (Nothing :: Maybe (Maybe SymBool)) "a" ::-                            UnionM (MaybeT Maybe SymBool)-                        )-                          @?= mrgSingle (MaybeT Nothing),-                      testCase "genSymSimple" $-                        ( genSymSimple (Nothing :: Maybe (Maybe SymBool)) "a" ::-                            MaybeT Maybe SymBool-                        )-                          @?= MaybeT Nothing-                    ],-                  testGroup-                    "Just Nothing"-                    [ testCase "genSym" $-                        ( genSym (Just Nothing :: Maybe (Maybe SymBool)) "a" ::-                            UnionM (MaybeT Maybe SymBool)-                        )-                          @?= mrgSingle (MaybeT (Just Nothing)),-                      testCase "genSymSimple" $-                        ( genSymSimple-                            (Just Nothing :: Maybe (Maybe SymBool))-                            "a" ::-                            MaybeT Maybe SymBool-                        )-                          @?= MaybeT (Just Nothing)-                    ],-                  testGroup-                    "Just (Just v)"-                    [ testCase "genSym" $-                        ( genSym-                            ( Just $ Just $ ssymBool "a" ::-                                Maybe (Maybe SymBool)-                            )-                            "a" ::-                            UnionM (MaybeT Maybe SymBool)-                        )-                          @?= mrgSingle (MaybeT (Just (Just $ isymBool "a" 0))),-                      testCase "genSymSimple" $-                        ( genSymSimple-                            ( Just $ Just $ ssymBool "a" ::-                                Maybe (Maybe SymBool)-                            )-                            "a" ::-                            MaybeT Maybe SymBool-                        )-                          @?= MaybeT (Just (Just $ isymBool "a" 0))-                    ]-                ]-            ],-          testGroup-            "ExceptT SymBool Maybe SymBool"-            [ testGroup-                "Same shape spec"-                [ testGroup-                    "ExceptT Nothing"-                    [ testCase "genSym" $-                        ( genSym-                            ( ExceptT Nothing ::-                                ExceptT SymBool Maybe SymBool-                            )-                            "a" ::-                            UnionM (ExceptT SymBool Maybe SymBool)-                        )-                          @?= mrgSingle (ExceptT Nothing),-                      testCase "genSymSimple" $-                        ( genSymSimple-                            ( ExceptT Nothing ::-                                ExceptT SymBool Maybe SymBool-                            )-                            "a" ::-                            ExceptT SymBool Maybe SymBool-                        )-                          @?= ExceptT Nothing-                    ],-                  testGroup-                    "ExceptT (Just (Left v))"-                    [ testCase "genSym" $-                        ( genSym-                            ( ExceptT $ Just $ Left $ ssymBool "a" ::-                                ExceptT SymBool Maybe SymBool-                            )-                            "a" ::-                            UnionM (ExceptT SymBool Maybe SymBool)-                        )-                          @?= mrgSingle-                            (ExceptT $ Just $ Left $ isymBool "a" 0),-                      testCase "genSymSimple" $-                        ( genSymSimple-                            ( ExceptT $ Just $ Left $ ssymBool "a" ::-                                ExceptT SymBool Maybe SymBool-                            )-                            "a" ::-                            ExceptT SymBool Maybe SymBool-                        )-                          @?= ExceptT (Just $ Left $ isymBool "a" 0)-                    ],-                  testGroup-                    "ExceptT (Just (Right v))"-                    [ testCase "genSym" $-                        ( genSym-                            ( ExceptT $ Just $ Right $ ssymBool "a" ::-                                ExceptT SymBool Maybe SymBool-                            )-                            "a" ::-                            UnionM (ExceptT SymBool Maybe SymBool)-                        )-                          @?= mrgSingle-                            (ExceptT $ Just $ Right $ isymBool "a" 0),-                      testCase "genSymSimple" $-                        ( genSymSimple-                            ( ExceptT $ Just $ Right $ ssymBool "a" ::-                                ExceptT SymBool Maybe SymBool-                            )-                            "a" ::-                            ExceptT SymBool Maybe SymBool-                        )-                          @?= ExceptT (Just $ Right $ isymBool "a" 0)-                    ]-                ],-              testCase "() spec" $ do-                (genSym () "a" :: UnionM (ExceptT SymBool Maybe SymBool))-                  @?= mrgIf-                    (isymBool "a" 0)-                    (mrgSingle $ ExceptT Nothing)-                    ( mrgIf-                        (isymBool "a" 1)-                        (mrgSingle $ ExceptT $ Just $ Left $ isymBool "a" 2)-                        (mrgSingle $ ExceptT $ Just $ Right $ isymBool "a" 3)-                    ),-              testGroup-                "Maybe (Either SymBool SymBool) spec"-                [ testGroup-                    "Nothing"-                    [ testCase "genSym" $-                        ( genSym-                            (Nothing :: Maybe (Either SymBool SymBool))-                            "a" ::-                            UnionM (ExceptT SymBool Maybe SymBool)-                        )-                          @?= mrgSingle (ExceptT Nothing),-                      testCase "genSymSimple" $-                        ( genSymSimple-                            (Nothing :: Maybe (Either SymBool SymBool))-                            "a" ::-                            ExceptT SymBool Maybe SymBool-                        )-                          @?= ExceptT Nothing-                    ],-                  testGroup-                    "Just (left v)"-                    [ testCase "genSym" $-                        ( genSym-                            ( Just $ Left $ ssymBool "a" ::-                                Maybe (Either SymBool SymBool)-                            )-                            "a" ::-                            UnionM (ExceptT SymBool Maybe SymBool)-                        )-                          @?= mrgSingle-                            (ExceptT (Just (Left $ isymBool "a" 0))),-                      testCase "genSymSimple" $-                        ( genSymSimple-                            ( Just $ Left $ ssymBool "a" ::-                                Maybe (Either SymBool SymBool)-                            )-                            "a" ::-                            ExceptT SymBool Maybe SymBool-                        )-                          @?= ExceptT (Just (Left $ isymBool "a" 0))-                    ],-                  testGroup-                    "Just (left v)"-                    [ testCase "genSym" $-                        ( genSym-                            ( Just $ Right $ ssymBool "a" ::-                                Maybe (Either SymBool SymBool)-                            )-                            "a" ::-                            UnionM (ExceptT SymBool Maybe SymBool)-                        )-                          @?= mrgSingle-                            (ExceptT (Just (Right $ isymBool "a" 0))),-                      testCase "genSymSimple" $-                        ( genSymSimple-                            ( Just $ Right $ ssymBool "a" ::-                                Maybe (Either SymBool SymBool)-                            )-                            "a" ::-                            ExceptT SymBool Maybe SymBool-                        )-                          @?= ExceptT (Just (Right $ isymBool "a" 0))-                    ]-                ]-            ]-        ],-      testGroup-        "choose*"-        [ testCase "chooseFresh" $ do-            (runFresh (chooseFresh [1, 2, 3]) "a" :: UnionM 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)-              @?= mrgIf-                (isymBool "a" 0)-                (mrgSingle 1)-                (mrgIf (isymBool "a" 1) (mrgSingle 2) (mrgSingle 3)),-          testCase "chooseSimpleFresh" $ do-            (runFresh (chooseSimpleFresh ["x", "y", "z"]) "a" :: SymBool)-              @?= symIte-                (isymBool "a" 0)-                (ssymBool "x")-                (symIte (isymBool "a" 1) (ssymBool "y") (ssymBool "z")),-          testCase "chooseSimple" $ do-            (chooseSimple ["x", "y", "z"] "a" :: SymBool)-              @?= symIte-                (isymBool "a" 0)-                (ssymBool "x")-                (symIte (isymBool "a" 1) (ssymBool "y") (ssymBool "z")),-          testCase "chooseUnionFresh" $ do-            ( runFresh-                ( chooseUnionFresh-                    [ mrgIf (ssymBool "x") 1 2,-                      mrgIf (ssymBool "x") 2 3,-                      mrgIf (ssymBool "x") 3 4-                    ]-                )-                "a" ::-                UnionM Int-              )-              @?= mrgIf-                (isymBool "a" 0)-                (mrgIf (ssymBool "x") 1 2)-                ( mrgIf-                    (isymBool "a" 1)-                    (mrgIf (ssymBool "x") 2 3)-                    (mrgIf (ssymBool "x") 3 4)-                ),-          testCase "chooseUnion" $ do-            ( chooseUnion-                [ mrgIf (ssymBool "x") 1 2,-                  mrgIf (ssymBool "x") 2 3,-                  mrgIf (ssymBool "x") 3 4-                ]-                "a" ::-                UnionM Int-              )-              @?= mrgIf-                (isymBool "a" 0)-                (mrgIf (ssymBool "x") 1 2)-                ( mrgIf-                    (isymBool "a" 1)-                    (mrgIf (ssymBool "x") 2 3)-                    (mrgIf (ssymBool "x") 3 4)-                ),-          testCase "liftFresh" $ do-            let orig = simpleFresh () :: Fresh (SymBool, SymBool)-            let actual = flip runFreshT "a" $ do-                  r1 <- liftFresh orig-                  r2 <- liftFresh orig-                  return (r1, r2) ::-                    FreshT UnionM ((SymBool, SymBool), (SymBool, SymBool))-            let expected =-                  return-                    ( (isymBool "a" 0, isymBool "a" 1),-                      (isymBool "a" 2, isymBool "a" 3)-                    )-            actual @?= expected-        ]+import Control.Monad (replicateM)+import Control.Monad.Except (ExceptT (ExceptT))+import Control.Monad.Trans.Maybe (MaybeT (MaybeT))+import qualified Data.Text as T+import Grisette+  ( AsKey,+    EnumGenBound (EnumGenBound),+    EnumGenUpperBound (EnumGenUpperBound),+    Fresh,+    FreshT,+    GenSymSimple (simpleFresh),+    ITEOp (symIte),+    ListSpec (ListSpec),+    MonadFresh (localIdentifier),+    SExpr (Atom),+    SimpleListSpec (SimpleListSpec),+    Solvable (con, isym, ssym),+    SymBool,+    choose,+    chooseFresh,+    chooseSimple,+    chooseSimpleFresh,+    chooseUnion,+    chooseUnionFresh,+    freshString,+    genSym,+    genSymSimple,+    liftFresh,+    mapMetadata,+    mrgIf,+    mrgSingle,+    runFresh,+    runFreshT,+    withMetadata,+  )+import Grisette.Internal.Core.Control.Monad.Union (Union)+import Grisette.Internal.Core.Data.Class.AsKey (AsKey1 (AsKey1))+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit ((@?=))++genSymTests :: Test+genSymTests =+  testGroup+    "GenSym"+    [ testGroup+        "GenSym for common types"+        [ testGroup+            "SymBool"+            [ testGroup+                "() spec"+                [ testCase "genSym" $+                    AsKey1 (genSym () "a" :: Union (AsKey SymBool))+                      @?= mrgSingle (isym "a" 0),+                  testCase "genSymSimple" $+                    (genSymSimple () "a" :: AsKey SymBool) @?= isym "a" 0+                ],+              testGroup+                "SymBool spec"+                [ testCase "genSym" $+                    AsKey1 (genSym (con True :: AsKey SymBool) "a" :: Union (AsKey SymBool))+                      @?= mrgSingle (isym "a" 0),+                  testCase "genSymSimple" $+                    (genSymSimple (con True :: AsKey SymBool) "a" :: AsKey SymBool)+                      @?= isym "a" 0+                ]+            ],+          testGroup+            "Bool"+            [ testCase "() spec" $+                AsKey1 (genSym () "a" :: Union Bool)+                  @?= AsKey1 (mrgIf (isym "a" 0) (mrgSingle False) (mrgSingle True)),+              testGroup+                "Bool spec"+                [ testGroup+                    "genSym"+                    [ testCase "True" $+                        AsKey1 (genSym True "a" :: Union Bool)+                          @?= mrgSingle True,+                      testCase "False" $+                        AsKey1 (genSym False "a" :: Union Bool)+                          @?= mrgSingle False+                    ],+                  testGroup+                    "genSymSimple"+                    [ testCase "True" $+                        (genSymSimple True "a" :: Bool)+                          @?= True,+                      testCase "False" $+                        (genSymSimple False "a" :: Bool)+                          @?= False+                    ]+                ]+            ],+          testGroup+            "Integer"+            [ testGroup+                "Integer spec"+                [ testCase "genSym" $+                    AsKey1 (genSym (1 :: Integer) "a" :: Union Integer)+                      @?= mrgSingle 1,+                  testCase "genSymSimple" $+                    (genSymSimple (1 :: Integer) "a" :: Integer)+                      @?= 1+                ],+              testCase "Upper bound spec" $+                AsKey1 (genSym (EnumGenUpperBound (3 :: Integer)) "a" :: Union Integer)+                  @?= mrgIf+                    (isym "a" 0)+                    (mrgSingle 0)+                    (mrgIf (isym "a" 1) (mrgSingle 1) (mrgSingle 2)),+              testCase "Bound spec" $+                AsKey1 (genSym (EnumGenBound (-1 :: Integer) 2) "a" :: Union Integer)+                  @?= mrgIf+                    (isym "a" 0)+                    (mrgSingle (-1))+                    (mrgIf (isym "a" 1) (mrgSingle 0) (mrgSingle 1))+            ],+          testGroup+            "Char"+            [ testGroup+                "Char spec"+                [ testCase "genSym" $+                    AsKey1 (genSym 'x' "a" :: Union Char)+                      @?= mrgSingle 'x',+                  testCase "genSymSimple" $+                    (genSymSimple 'x' "a" :: Char) @?= 'x'+                ],+              testCase "Upper bound spec" $+                AsKey1 (genSym (EnumGenUpperBound @Char (toEnum 3)) "a" :: Union Char)+                  @?= mrgIf+                    (isym "a" 0)+                    (mrgSingle $ toEnum 0)+                    ( mrgIf+                        (isym "a" 1)+                        (mrgSingle $ toEnum 1)+                        (mrgSingle $ toEnum 2)+                    ),+              testCase "Bound spec" $+                AsKey1 (genSym (EnumGenBound 'a' 'd') "a" :: Union Char)+                  @?= mrgIf+                    (isym "a" 0)+                    (mrgSingle 'a')+                    (mrgIf (isym "a" 1) (mrgSingle 'b') (mrgSingle 'c'))+            ],+          testGroup+            "Maybe SymBool"+            [ testGroup+                "Maybe SymBool spec"+                [ testGroup+                    "Nothing"+                    [ testCase "genSym" $+                        AsKey1+                          ( genSym (Nothing :: Maybe (AsKey SymBool)) "a" ::+                              Union (Maybe (AsKey SymBool))+                          )+                          @?= mrgSingle Nothing,+                      testCase "genSymSimple" $+                        ( genSymSimple (Nothing :: Maybe (AsKey SymBool)) "a" ::+                            Maybe (AsKey SymBool)+                        )+                          @?= Nothing+                    ],+                  testGroup+                    "Just v"+                    [ testCase "genSym" $+                        AsKey1+                          ( genSym (Just (ssym "a" :: AsKey SymBool)) "a" ::+                              Union (Maybe (AsKey SymBool))+                          )+                          @?= mrgSingle (Just (isym "a" 0)),+                      testCase "genSymSimple" $+                        ( genSymSimple (Just (ssym "a" :: AsKey SymBool)) "a" ::+                            Maybe (AsKey SymBool)+                        )+                          @?= Just (isym "a" 0)+                    ]+                ],+              testCase "() spec" $+                AsKey1 (genSym () "a" :: Union (Maybe (AsKey SymBool)))+                  @?= mrgIf+                    (isym "a" 0)+                    (mrgSingle Nothing)+                    (mrgSingle (Just (isym "a" 1)))+            ],+          testGroup+            "Either SymBool SymBool"+            [ testGroup+                "Either SymBool SymBool spec"+                [ testGroup+                    "Left v"+                    [ testCase "genSym" $+                        ( AsKey1 $+                            genSym+                              ( Left (ssym "a") ::+                                  Either (AsKey SymBool) (AsKey SymBool)+                              )+                              "a" ::+                            AsKey1 Union (Either (AsKey SymBool) (AsKey SymBool))+                        )+                          @?= mrgSingle (Left (isym "a" 0)),+                      testCase "genSymSimple" $+                        ( genSymSimple+                            ( Left (ssym "a") ::+                                Either (AsKey SymBool) (AsKey SymBool)+                            )+                            "a" ::+                            Either (AsKey SymBool) (AsKey SymBool)+                        )+                          @?= Left (isym "a" 0)+                    ],+                  testGroup+                    "Right v"+                    [ testCase "genSym" $+                        ( AsKey1 $+                            genSym+                              ( Right (ssym "a") ::+                                  Either (AsKey SymBool) (AsKey SymBool)+                              )+                              "a" ::+                            AsKey1 Union (Either (AsKey SymBool) (AsKey SymBool))+                        )+                          @?= mrgSingle (Right (isym "a" 0)),+                      testCase "genSymSimple" $+                        ( genSymSimple+                            ( Right (ssym "a") ::+                                Either (AsKey SymBool) (AsKey SymBool)+                            )+                            "a" ::+                            Either (AsKey SymBool) (AsKey SymBool)+                        )+                          @?= Right (isym "a" 0)+                    ]+                ],+              testCase "() spec" $ do+                (AsKey1 (genSym () "a" :: Union (Either (AsKey SymBool) (AsKey SymBool))))+                  @?= mrgIf+                    (isym "a" 0)+                    (mrgSingle $ Left $ isym "a" 1)+                    (mrgSingle $ Right $ isym "a" 2)+            ],+          testGroup+            "lists"+            [ testGroup+                "Max length spec"+                [ testCase "max length = 0" $+                    AsKey1 (genSym (0 :: Integer) "a" :: Union [AsKey SymBool])+                      @?= mrgSingle [],+                  testCase "max length = 3" $+                    AsKey1 (genSym (3 :: Integer) "a" :: Union [AsKey SymBool])+                      @?= mrgIf+                        (isym "a" 3)+                        (mrgSingle [])+                        ( mrgIf+                            (isym "a" 4)+                            (mrgSingle [isym "a" 2])+                            ( mrgIf+                                (isym "a" 5)+                                (mrgSingle [isym "a" 1, isym "a" 2])+                                ( mrgSingle+                                    [ isym "a" 0,+                                      isym "a" 1,+                                      isym "a" 2+                                    ]+                                )+                            )+                        )+                ],+              testGroup+                "Min & max length spec"+                [ testCase "min length = 1, max length = 3" $+                    AsKey1 (genSym (ListSpec 1 3 ()) "a" :: Union [AsKey SymBool])+                      @?= mrgIf+                        (isym "a" 3)+                        (mrgSingle [isym "a" 2])+                        ( mrgIf+                            (isym "a" 4)+                            (mrgSingle [isym "a" 1, isym "a" 2])+                            ( mrgSingle+                                [ isym "a" 0,+                                  isym "a" 1,+                                  isym "a" 2+                                ]+                            )+                        ),+                  testCase "min length = 1, max length = 2, nested" $+                    AsKey1+                      ( genSym (ListSpec 1 2 (ListSpec 1 2 ())) "a" ::+                          Union [AsKey1 Union [AsKey SymBool]]+                      )+                      @?= mrgIf+                        (isym "a" 6)+                        ( mrgSingle+                            [ mrgIf+                                (isym "a" 5)+                                (mrgSingle [isym "a" 4])+                                (mrgSingle [isym "a" 3, isym "a" 4])+                            ]+                        )+                        ( mrgSingle+                            [ mrgIf+                                (isym "a" 2)+                                (mrgSingle [isym "a" 1])+                                (mrgSingle [isym "a" 0, isym "a" 1]),+                              mrgIf+                                (isym "a" 5)+                                (mrgSingle [isym "a" 4])+                                (mrgSingle [isym "a" 3, isym "a" 4])+                            ]+                        )+                ],+              testGroup+                "Exact length spec"+                [ testGroup+                    "length = 2"+                    [ testCase "genSym" $+                        AsKey1+                          (genSym (SimpleListSpec 2 ()) "a" :: Union [AsKey SymBool])+                          @?= mrgSingle [isym "a" 0, isym "a" 1],+                      testCase "genSymSimple" $+                        (genSymSimple (SimpleListSpec 2 ()) "a" :: [AsKey SymBool])+                          @?= [isym "a" 0, isym "a" 1]+                    ],+                  testGroup+                    "length = 2, nested"+                    [ testCase "genSym" $+                        AsKey1+                          ( genSym+                              (SimpleListSpec 2 (SimpleListSpec 2 ()))+                              "a" ::+                              Union [[AsKey SymBool]]+                          )+                          @?= mrgSingle+                            [ [isym "a" 0, isym "a" 1],+                              [isym "a" 2, isym "a" 3]+                            ],+                      testCase "genSymSimple" $+                        ( genSymSimple+                            (SimpleListSpec 2 (SimpleListSpec 2 ()))+                            "a" ::+                            [[AsKey SymBool]]+                        )+                          @?= [ [isym "a" 0, isym "a" 1],+                                [isym "a" 2, isym "a" 3]+                              ]+                    ]+                ],+              testGroup+                "List with same shape spec"+                [ testCase "genSym" $+                    AsKey1+                      ( genSym+                          [[con True :: AsKey SymBool], [ssym "a", ssym "b"]]+                          "a" ::+                          Union [[AsKey SymBool]]+                      )+                      @?= mrgSingle+                        [ [isym "a" 0],+                          [isym "a" 1, isym "a" 2]+                        ],+                  testCase "genSymSimple" $+                    ( genSymSimple+                        [ [con True :: AsKey SymBool],+                          [ssym "a", ssym "b"]+                        ]+                        "a" ::+                        [[AsKey SymBool]]+                    )+                      @?= [[isym "a" 0], [isym "a" 1, isym "a" 2]]+                ]+            ],+          testGroup+            "()"+            [ testCase "() spec" $ do+                AsKey1 (genSym () "a" :: Union ()) @?= mrgSingle ()+                (genSymSimple () "a" :: ()) @?= ()+            ],+          testGroup+            "(,)"+            [ testGroup+                "Some spec"+                [ testCase "genSym" $+                    AsKey1+                      ( genSym+                          ( EnumGenUpperBound @Integer 2,+                            EnumGenUpperBound @Integer 2+                          )+                          "a" ::+                          Union (Integer, Integer)+                      )+                      @?= do+                        x1 <- mrgIf (isym "a" 0) (mrgSingle 0) (mrgSingle 1)+                        x2 <- mrgIf (isym "a" 1) (mrgSingle 0) (mrgSingle 1)+                        mrgSingle (x1, x2),+                  testCase "genSymSimple" $+                    ( genSymSimple+                        ( (),+                          [ [ssym "b" :: AsKey SymBool],+                            [ssym "b", ssym "c"]+                          ]+                        )+                        "a" ::+                        (AsKey SymBool, [[AsKey SymBool]])+                    )+                      @?= ( isym "a" 0,+                            [ [isym "a" 1],+                              [isym "a" 2, isym "a" 3]+                            ]+                          )+                ],+              testGroup+                "No spec"+                [ testCase "genSym" $+                    AsKey1+                      (genSym () "a" :: Union (AsKey SymBool, AsKey SymBool))+                      @?= mrgSingle (isym "a" 0, isym "a" 1),+                  testCase "genSymSimple" $+                    (genSymSimple () "a" :: (AsKey SymBool, AsKey SymBool))+                      @?= (isym "a" 0, isym "a" 1)+                ]+            ],+          testGroup+            "(,,)"+            [ testGroup+                "Some spec"+                [ testCase "genSym" $+                    AsKey1+                      ( genSym+                          ( EnumGenUpperBound @Integer 2,+                            EnumGenUpperBound @Integer 2,+                            EnumGenUpperBound @Integer 2+                          )+                          "a" ::+                          Union (Integer, Integer, Integer)+                      )+                      @?= do+                        x1 <- mrgIf (isym "a" 0) (mrgSingle 0) (mrgSingle 1)+                        x2 <- mrgIf (isym "a" 1) (mrgSingle 0) (mrgSingle 1)+                        x3 <- mrgIf (isym "a" 2) (mrgSingle 0) (mrgSingle 1)+                        mrgSingle (x1, x2, x3),+                  testCase "genSymSimple" $+                    ( genSymSimple+                        ((), [[ssym "b" :: AsKey SymBool], [ssym "b", ssym "c"]], ())+                        "a" ::+                        (AsKey SymBool, [[AsKey SymBool]], AsKey SymBool)+                    )+                      @?= ( isym "a" 0,+                            [ [isym "a" 1],+                              [isym "a" 2, isym "a" 3]+                            ],+                            isym "a" 4+                          )+                ],+              testGroup+                "No spec"+                [ testCase "genSym" $+                    AsKey1+                      (genSym () "a" :: Union (AsKey SymBool, AsKey SymBool, AsKey SymBool))+                      @?= mrgSingle+                        (isym "a" 0, isym "a" 1, isym "a" 2),+                  testCase "genSymSimple" $+                    (genSymSimple () "a" :: (AsKey SymBool, AsKey SymBool, AsKey SymBool))+                      @?= (isym "a" 0, isym "a" 1, isym "a" 2)+                ]+            ],+          testGroup+            "(,,,)"+            [ testGroup+                "Some spec"+                [ testCase "genSym" $+                    AsKey1+                      ( genSym+                          ( EnumGenUpperBound @Integer 2,+                            EnumGenUpperBound @Integer 2,+                            EnumGenUpperBound @Integer 2,+                            EnumGenUpperBound @Integer 2+                          )+                          "a" ::+                          Union (Integer, Integer, Integer, Integer)+                      )+                      @?= do+                        x1 <- mrgIf (isym "a" 0) (mrgSingle 0) (mrgSingle 1)+                        x2 <- mrgIf (isym "a" 1) (mrgSingle 0) (mrgSingle 1)+                        x3 <- mrgIf (isym "a" 2) (mrgSingle 0) (mrgSingle 1)+                        x4 <- mrgIf (isym "a" 3) (mrgSingle 0) (mrgSingle 1)+                        mrgSingle (x1, x2, x3, x4),+                  testCase "genSymSimple" $+                    ( genSymSimple+                        ( (),+                          [[ssym "b" :: AsKey SymBool], [ssym "b", ssym "c"]],+                          (),+                          ()+                        )+                        "a" ::+                        (AsKey SymBool, [[AsKey SymBool]], AsKey SymBool, AsKey SymBool)+                    )+                      @?= ( isym "a" 0,+                            [ [isym "a" 1],+                              [isym "a" 2, isym "a" 3]+                            ],+                            isym "a" 4,+                            isym "a" 5+                          )+                ],+              testGroup+                "No spec"+                [ testCase "genSym" $+                    AsKey1+                      ( genSym () "a" ::+                          Union (AsKey SymBool, AsKey SymBool, AsKey SymBool, AsKey SymBool)+                      )+                      @?= mrgSingle+                        ( isym "a" 0,+                          isym "a" 1,+                          isym "a" 2,+                          isym "a" 3+                        ),+                  testCase "genSymSimple" $+                    ( genSymSimple () "a" ::+                        (AsKey SymBool, AsKey SymBool, AsKey SymBool, AsKey SymBool)+                    )+                      @?= ( isym "a" 0,+                            isym "a" 1,+                            isym "a" 2,+                            isym "a" 3+                          )+                ]+            ],+          testGroup+            "(,,,,)"+            [ testGroup+                "Some spec"+                [ testCase "genSym" $+                    AsKey1+                      ( genSym+                          ( EnumGenUpperBound @Integer 2,+                            EnumGenUpperBound @Integer 2,+                            EnumGenUpperBound @Integer 2,+                            EnumGenUpperBound @Integer 2,+                            EnumGenUpperBound @Integer 2+                          )+                          "a" ::+                          Union (Integer, Integer, Integer, Integer, Integer)+                      )+                      @?= do+                        x1 <- mrgIf (isym "a" 0) (mrgSingle 0) (mrgSingle 1)+                        x2 <- mrgIf (isym "a" 1) (mrgSingle 0) (mrgSingle 1)+                        x3 <- mrgIf (isym "a" 2) (mrgSingle 0) (mrgSingle 1)+                        x4 <- mrgIf (isym "a" 3) (mrgSingle 0) (mrgSingle 1)+                        x5 <- mrgIf (isym "a" 4) (mrgSingle 0) (mrgSingle 1)+                        mrgSingle (x1, x2, x3, x4, x5),+                  testCase "genSymSimple" $+                    ( genSymSimple+                        ( (),+                          [ [ssym "b" :: AsKey SymBool],+                            [ssym "b", ssym "c"]+                          ],+                          (),+                          (),+                          ()+                        )+                        "a" ::+                        (AsKey SymBool, [[AsKey SymBool]], AsKey SymBool, AsKey SymBool, AsKey SymBool)+                    )+                      @?= ( isym "a" 0,+                            [ [isym "a" 1],+                              [isym "a" 2, isym "a" 3]+                            ],+                            isym "a" 4,+                            isym "a" 5,+                            isym "a" 6+                          )+                ],+              testGroup+                "No spec"+                [ testCase "genSym" $+                    AsKey1+                      ( genSym () "a" ::+                          Union (AsKey SymBool, AsKey SymBool, AsKey SymBool, AsKey SymBool, AsKey SymBool)+                      )+                      @?= mrgSingle+                        ( isym "a" 0,+                          isym "a" 1,+                          isym "a" 2,+                          isym "a" 3,+                          isym "a" 4+                        ),+                  testCase "genSymSimple" $+                    ( genSymSimple () "a" ::+                        (AsKey SymBool, AsKey SymBool, AsKey SymBool, AsKey SymBool, AsKey SymBool)+                    )+                      @?= ( isym "a" 0,+                            isym "a" 1,+                            isym "a" 2,+                            isym "a" 3,+                            isym "a" 4+                          )+                ]+            ],+          testGroup+            "(,,,,,)"+            [ testGroup+                "Some spec"+                [ testCase "genSym" $+                    AsKey1+                      ( genSym+                          ( EnumGenUpperBound @Integer 2,+                            EnumGenUpperBound @Integer 2,+                            EnumGenUpperBound @Integer 2,+                            EnumGenUpperBound @Integer 2,+                            EnumGenUpperBound @Integer 2,+                            EnumGenUpperBound @Integer 2+                          )+                          "a" ::+                          Union+                            ( Integer,+                              Integer,+                              Integer,+                              Integer,+                              Integer,+                              Integer+                            )+                      )+                      @?= do+                        x1 <- mrgIf (isym "a" 0) (mrgSingle 0) (mrgSingle 1)+                        x2 <- mrgIf (isym "a" 1) (mrgSingle 0) (mrgSingle 1)+                        x3 <- mrgIf (isym "a" 2) (mrgSingle 0) (mrgSingle 1)+                        x4 <- mrgIf (isym "a" 3) (mrgSingle 0) (mrgSingle 1)+                        x5 <- mrgIf (isym "a" 4) (mrgSingle 0) (mrgSingle 1)+                        x6 <- mrgIf (isym "a" 5) (mrgSingle 0) (mrgSingle 1)+                        mrgSingle (x1, x2, x3, x4, x5, x6),+                  testCase "genSymSimple" $+                    ( genSymSimple+                        ( (),+                          [ [ssym "b" :: AsKey SymBool],+                            [ssym "b", ssym "c"]+                          ],+                          (),+                          (),+                          (),+                          ()+                        )+                        "a" ::+                        ( AsKey SymBool,+                          [[AsKey SymBool]],+                          AsKey SymBool,+                          AsKey SymBool,+                          AsKey SymBool,+                          AsKey SymBool+                        )+                    )+                      @?= ( isym "a" 0,+                            [ [isym "a" 1],+                              [isym "a" 2, isym "a" 3]+                            ],+                            isym "a" 4,+                            isym "a" 5,+                            isym "a" 6,+                            isym "a" 7+                          )+                ],+              testGroup+                "No spec"+                [ testCase "genSym" $+                    AsKey1+                      ( genSym () "a" ::+                          Union+                            ( AsKey SymBool,+                              AsKey SymBool,+                              AsKey SymBool,+                              AsKey SymBool,+                              AsKey SymBool,+                              AsKey SymBool+                            )+                      )+                      @?= mrgSingle+                        ( isym "a" 0,+                          isym "a" 1,+                          isym "a" 2,+                          isym "a" 3,+                          isym "a" 4,+                          isym "a" 5+                        ),+                  testCase "genSymSimple" $+                    ( genSymSimple () "a" ::+                        ( AsKey SymBool,+                          AsKey SymBool,+                          AsKey SymBool,+                          AsKey SymBool,+                          AsKey SymBool,+                          AsKey SymBool+                        )+                    )+                      @?= ( isym "a" 0,+                            isym "a" 1,+                            isym "a" 2,+                            isym "a" 3,+                            isym "a" 4,+                            isym "a" 5+                          )+                ]+            ],+          testGroup+            "(,,,,,,)"+            [ testGroup+                "Some spec"+                [ testCase "genSym" $+                    AsKey1+                      ( genSym+                          ( EnumGenUpperBound @Integer 2,+                            EnumGenUpperBound @Integer 2,+                            EnumGenUpperBound @Integer 2,+                            EnumGenUpperBound @Integer 2,+                            EnumGenUpperBound @Integer 2,+                            EnumGenUpperBound @Integer 2,+                            EnumGenUpperBound @Integer 2+                          )+                          "a" ::+                          Union+                            ( Integer,+                              Integer,+                              Integer,+                              Integer,+                              Integer,+                              Integer,+                              Integer+                            )+                      )+                      @?= do+                        x1 <- mrgIf (isym "a" 0) (mrgSingle 0) (mrgSingle 1)+                        x2 <- mrgIf (isym "a" 1) (mrgSingle 0) (mrgSingle 1)+                        x3 <- mrgIf (isym "a" 2) (mrgSingle 0) (mrgSingle 1)+                        x4 <- mrgIf (isym "a" 3) (mrgSingle 0) (mrgSingle 1)+                        x5 <- mrgIf (isym "a" 4) (mrgSingle 0) (mrgSingle 1)+                        x6 <- mrgIf (isym "a" 5) (mrgSingle 0) (mrgSingle 1)+                        x7 <- mrgIf (isym "a" 6) (mrgSingle 0) (mrgSingle 1)+                        mrgSingle (x1, x2, x3, x4, x5, x6, x7),+                  testCase "genSymSimple" $+                    ( genSymSimple+                        ( (),+                          [ [ssym "b" :: AsKey SymBool],+                            [ssym "b", ssym "c"]+                          ],+                          (),+                          (),+                          (),+                          (),+                          ()+                        )+                        "a" ::+                        ( AsKey SymBool,+                          [[AsKey SymBool]],+                          AsKey SymBool,+                          AsKey SymBool,+                          AsKey SymBool,+                          AsKey SymBool,+                          AsKey SymBool+                        )+                    )+                      @?= ( isym "a" 0,+                            [ [isym "a" 1],+                              [isym "a" 2, isym "a" 3]+                            ],+                            isym "a" 4,+                            isym "a" 5,+                            isym "a" 6,+                            isym "a" 7,+                            isym "a" 8+                          )+                ],+              testGroup+                "No spec"+                [ testCase "genSym" $+                    AsKey1+                      ( genSym () "a" ::+                          Union+                            ( AsKey SymBool,+                              AsKey SymBool,+                              AsKey SymBool,+                              AsKey SymBool,+                              AsKey SymBool,+                              AsKey SymBool,+                              AsKey SymBool+                            )+                      )+                      @?= mrgSingle+                        ( isym "a" 0,+                          isym "a" 1,+                          isym "a" 2,+                          isym "a" 3,+                          isym "a" 4,+                          isym "a" 5,+                          isym "a" 6+                        ),+                  testCase "genSymSimple" $+                    ( genSymSimple () "a" ::+                        ( AsKey SymBool,+                          AsKey SymBool,+                          AsKey SymBool,+                          AsKey SymBool,+                          AsKey SymBool,+                          AsKey SymBool,+                          AsKey SymBool+                        )+                    )+                      @?= ( isym "a" 0,+                            isym "a" 1,+                            isym "a" 2,+                            isym "a" 3,+                            isym "a" 4,+                            isym "a" 5,+                            isym "a" 6+                          )+                ]+            ],+          testGroup+            "(,,,,,,,)"+            [ testGroup+                "Some spec"+                [ testCase "genSym" $+                    AsKey1+                      ( genSym+                          ( EnumGenUpperBound @Integer 2,+                            EnumGenUpperBound @Integer 2,+                            EnumGenUpperBound @Integer 2,+                            EnumGenUpperBound @Integer 2,+                            EnumGenUpperBound @Integer 2,+                            EnumGenUpperBound @Integer 2,+                            EnumGenUpperBound @Integer 2,+                            EnumGenUpperBound @Integer 2+                          )+                          "a" ::+                          Union+                            ( Integer,+                              Integer,+                              Integer,+                              Integer,+                              Integer,+                              Integer,+                              Integer,+                              Integer+                            )+                      )+                      @?= do+                        x1 <- mrgIf (isym "a" 0) (mrgSingle 0) (mrgSingle 1)+                        x2 <- mrgIf (isym "a" 1) (mrgSingle 0) (mrgSingle 1)+                        x3 <- mrgIf (isym "a" 2) (mrgSingle 0) (mrgSingle 1)+                        x4 <- mrgIf (isym "a" 3) (mrgSingle 0) (mrgSingle 1)+                        x5 <- mrgIf (isym "a" 4) (mrgSingle 0) (mrgSingle 1)+                        x6 <- mrgIf (isym "a" 5) (mrgSingle 0) (mrgSingle 1)+                        x7 <- mrgIf (isym "a" 6) (mrgSingle 0) (mrgSingle 1)+                        x8 <- mrgIf (isym "a" 7) (mrgSingle 0) (mrgSingle 1)+                        mrgSingle (x1, x2, x3, x4, x5, x6, x7, x8),+                  testCase "genSymSimple" $+                    ( genSymSimple+                        ( (),+                          [ [ssym "b" :: AsKey SymBool],+                            [ssym "b", ssym "c"]+                          ],+                          (),+                          (),+                          (),+                          (),+                          (),+                          ()+                        )+                        "a" ::+                        ( AsKey SymBool,+                          [[AsKey SymBool]],+                          AsKey SymBool,+                          AsKey SymBool,+                          AsKey SymBool,+                          AsKey SymBool,+                          AsKey SymBool,+                          AsKey SymBool+                        )+                    )+                      @?= ( isym "a" 0,+                            [ [isym "a" 1],+                              [isym "a" 2, isym "a" 3]+                            ],+                            isym "a" 4,+                            isym "a" 5,+                            isym "a" 6,+                            isym "a" 7,+                            isym "a" 8,+                            isym "a" 9+                          )+                ],+              testGroup+                "No spec"+                [ testCase "genSym" $+                    AsKey1+                      ( genSym () "a" ::+                          Union+                            ( AsKey SymBool,+                              AsKey SymBool,+                              AsKey SymBool,+                              AsKey SymBool,+                              AsKey SymBool,+                              AsKey SymBool,+                              AsKey SymBool,+                              AsKey SymBool+                            )+                      )+                      @?= mrgSingle+                        ( isym "a" 0,+                          isym "a" 1,+                          isym "a" 2,+                          isym "a" 3,+                          isym "a" 4,+                          isym "a" 5,+                          isym "a" 6,+                          isym "a" 7+                        ),+                  testCase "genSymSimple" $+                    ( genSymSimple () "a" ::+                        ( AsKey SymBool,+                          AsKey SymBool,+                          AsKey SymBool,+                          AsKey SymBool,+                          AsKey SymBool,+                          AsKey SymBool,+                          AsKey SymBool,+                          AsKey SymBool+                        )+                    )+                      @?= ( isym "a" 0,+                            isym "a" 1,+                            isym "a" 2,+                            isym "a" 3,+                            isym "a" 4,+                            isym "a" 5,+                            isym "a" 6,+                            isym "a" 7+                          )+                ]+            ],+          testGroup+            "MaybeT Maybe SymBool"+            [ testGroup+                "Same shape spec"+                [ testGroup+                    "MaybeT Nothing"+                    [ testCase "genSym" $+                        AsKey1+                          ( genSym+                              (MaybeT Nothing :: MaybeT Maybe (AsKey SymBool))+                              "a" ::+                              Union (MaybeT Maybe (AsKey SymBool))+                          )+                          @?= mrgSingle (MaybeT Nothing),+                      testCase "genSymSimple" $+                        ( genSymSimple+                            (MaybeT Nothing :: MaybeT Maybe (AsKey SymBool))+                            "a" ::+                            MaybeT Maybe (AsKey SymBool)+                        )+                          @?= MaybeT Nothing+                    ],+                  testGroup+                    "MaybeT (Just Nothing)"+                    [ testCase "genSym" $+                        AsKey1+                          ( genSym+                              ( MaybeT (Just Nothing) ::+                                  MaybeT Maybe (AsKey SymBool)+                              )+                              "a" ::+                              Union (MaybeT Maybe (AsKey SymBool))+                          )+                          @?= mrgSingle (MaybeT (Just Nothing)),+                      testCase "genSymSimple" $+                        ( genSymSimple+                            ( MaybeT (Just (Just $ ssym "a")) ::+                                MaybeT Maybe (AsKey SymBool)+                            )+                            "a" ::+                            MaybeT Maybe (AsKey SymBool)+                        )+                          @?= MaybeT (Just (Just $ isym "a" 0))+                    ],+                  testGroup+                    "MaybeT (Just (Just v))"+                    [ testCase "genSym" $+                        AsKey1+                          ( genSym+                              ( MaybeT (Just (Just $ ssym "a")) ::+                                  MaybeT Maybe (AsKey SymBool)+                              )+                              "a" ::+                              Union (MaybeT Maybe (AsKey SymBool))+                          )+                          @?= mrgSingle (MaybeT (Just (Just $ isym "a" 0))),+                      testCase "genSymSimple" $+                        ( genSymSimple+                            ( MaybeT (Just (Just $ ssym "a")) ::+                                MaybeT Maybe (AsKey SymBool)+                            )+                            "a" ::+                            MaybeT Maybe (AsKey SymBool)+                        )+                          @?= MaybeT (Just (Just $ isym "a" 0))+                    ]+                ],+              testCase "No spec" $+                AsKey1+                  (genSym () "a" :: Union (MaybeT Maybe (AsKey SymBool)))+                  @?= mrgIf+                    (isym "a" 0)+                    (mrgSingle $ MaybeT Nothing)+                    ( mrgIf+                        (isym "a" 1)+                        (mrgSingle $ MaybeT $ Just Nothing)+                        (mrgSingle $ MaybeT $ Just $ Just $ isym "a" 2)+                    ),+              testGroup+                "Maybe (Maybe SymBool) spec"+                [ testGroup+                    "Nothing"+                    [ testCase "genSym" $+                        AsKey1+                          ( genSym+                              (Nothing :: Maybe (Maybe (AsKey SymBool)))+                              "a" ::+                              Union (MaybeT Maybe (AsKey SymBool))+                          )+                          @?= mrgSingle (MaybeT Nothing),+                      testCase "genSymSimple" $+                        ( genSymSimple+                            (Nothing :: Maybe (Maybe (AsKey SymBool)))+                            "a" ::+                            MaybeT Maybe (AsKey SymBool)+                        )+                          @?= MaybeT Nothing+                    ],+                  testGroup+                    "Just Nothing"+                    [ testCase "genSym" $+                        AsKey1+                          ( genSym+                              (Just Nothing :: Maybe (Maybe (AsKey SymBool)))+                              "a" ::+                              Union (MaybeT Maybe (AsKey SymBool))+                          )+                          @?= mrgSingle (MaybeT (Just Nothing)),+                      testCase "genSymSimple" $+                        ( genSymSimple+                            (Just Nothing :: Maybe (Maybe (AsKey SymBool)))+                            "a" ::+                            MaybeT Maybe (AsKey SymBool)+                        )+                          @?= MaybeT (Just Nothing)+                    ],+                  testGroup+                    "Just (Just v)"+                    [ testCase "genSym" $+                        AsKey1+                          ( genSym+                              ( Just $ Just $ ssym "a" ::+                                  Maybe (Maybe (AsKey SymBool))+                              )+                              "a" ::+                              Union (MaybeT Maybe (AsKey SymBool))+                          )+                          @?= mrgSingle (MaybeT (Just (Just $ isym "a" 0))),+                      testCase "genSymSimple" $+                        ( genSymSimple+                            ( Just $ Just $ ssym "a" ::+                                Maybe (Maybe (AsKey SymBool))+                            )+                            "a" ::+                            MaybeT Maybe (AsKey SymBool)+                        )+                          @?= MaybeT (Just (Just $ isym "a" 0))+                    ]+                ]+            ],+          testGroup+            "ExceptT SymBool Maybe SymBool"+            [ testGroup+                "Same shape spec"+                [ testGroup+                    "ExceptT Nothing"+                    [ testCase "genSym" $+                        AsKey1+                          ( genSym+                              ( ExceptT Nothing ::+                                  ExceptT (AsKey SymBool) Maybe (AsKey SymBool)+                              )+                              "a" ::+                              Union (ExceptT (AsKey SymBool) Maybe (AsKey SymBool))+                          )+                          @?= mrgSingle (ExceptT Nothing),+                      testCase "genSymSimple" $+                        ( genSymSimple+                            ( ExceptT Nothing ::+                                ExceptT (AsKey SymBool) Maybe (AsKey SymBool)+                            )+                            "a" ::+                            ExceptT (AsKey SymBool) Maybe (AsKey SymBool)+                        )+                          @?= ExceptT Nothing+                    ],+                  testGroup+                    "ExceptT (Just (Left v))"+                    [ testCase "genSym" $+                        AsKey1+                          ( genSym+                              ( ExceptT $ Just $ Left $ ssym "a" ::+                                  ExceptT (AsKey SymBool) Maybe (AsKey SymBool)+                              )+                              "a" ::+                              Union (ExceptT (AsKey SymBool) Maybe (AsKey SymBool))+                          )+                          @?= mrgSingle+                            (ExceptT $ Just $ Left $ isym "a" 0),+                      testCase "genSymSimple" $+                        ( genSymSimple+                            ( ExceptT $ Just $ Left $ ssym "a" ::+                                ExceptT (AsKey SymBool) Maybe (AsKey SymBool)+                            )+                            "a" ::+                            ExceptT (AsKey SymBool) Maybe (AsKey SymBool)+                        )+                          @?= ExceptT (Just $ Left $ isym "a" 0)+                    ],+                  testGroup+                    "ExceptT (Just (Right v))"+                    [ testCase "genSym" $+                        AsKey1+                          ( genSym+                              ( ExceptT $ Just $ Right $ ssym "a" ::+                                  ExceptT (AsKey SymBool) Maybe (AsKey SymBool)+                              )+                              "a" ::+                              Union (ExceptT (AsKey SymBool) Maybe (AsKey SymBool))+                          )+                          @?= mrgSingle+                            (ExceptT $ Just $ Right $ isym "a" 0),+                      testCase "genSymSimple" $+                        ( genSymSimple+                            ( ExceptT $ Just $ Right $ ssym "a" ::+                                ExceptT (AsKey SymBool) Maybe (AsKey SymBool)+                            )+                            "a" ::+                            ExceptT (AsKey SymBool) Maybe (AsKey SymBool)+                        )+                          @?= ExceptT (Just $ Right $ isym "a" 0)+                    ]+                ],+              testCase "() spec" $ do+                AsKey1+                  (genSym () "a" :: Union (ExceptT (AsKey SymBool) Maybe (AsKey SymBool)))+                  @?= mrgIf+                    (isym "a" 0)+                    (mrgSingle $ ExceptT Nothing)+                    ( mrgIf+                        (isym "a" 1)+                        (mrgSingle $ ExceptT $ Just $ Left $ isym "a" 2)+                        (mrgSingle $ ExceptT $ Just $ Right $ isym "a" 3)+                    ),+              testGroup+                "Maybe (Either SymBool SymBool) spec"+                [ testGroup+                    "Nothing"+                    [ testCase "genSym" $+                        AsKey1+                          ( genSym+                              (Nothing :: Maybe (Either (AsKey SymBool) (AsKey SymBool)))+                              "a" ::+                              Union (ExceptT (AsKey SymBool) Maybe (AsKey SymBool))+                          )+                          @?= mrgSingle (ExceptT Nothing),+                      testCase "genSymSimple" $+                        ( genSymSimple+                            (Nothing :: Maybe (Either (AsKey SymBool) (AsKey SymBool)))+                            "a" ::+                            ExceptT (AsKey SymBool) Maybe (AsKey SymBool)+                        )+                          @?= ExceptT Nothing+                    ],+                  testGroup+                    "Just (left v)"+                    [ testCase "genSym" $+                        AsKey1+                          ( genSym+                              ( Just $ Left $ ssym "a" ::+                                  Maybe (Either (AsKey SymBool) (AsKey SymBool))+                              )+                              "a" ::+                              Union (ExceptT (AsKey SymBool) Maybe (AsKey SymBool))+                          )+                          @?= mrgSingle+                            (ExceptT (Just (Left $ isym "a" 0))),+                      testCase "genSymSimple" $+                        ( genSymSimple+                            ( Just $ Left $ ssym "a" ::+                                Maybe (Either (AsKey SymBool) (AsKey SymBool))+                            )+                            "a" ::+                            ExceptT (AsKey SymBool) Maybe (AsKey SymBool)+                        )+                          @?= ExceptT (Just (Left $ isym "a" 0))+                    ],+                  testGroup+                    "Just (left v)"+                    [ testCase "genSym" $+                        AsKey1+                          ( genSym+                              ( Just $ Right $ ssym "a" ::+                                  Maybe (Either (AsKey SymBool) (AsKey SymBool))+                              )+                              "a" ::+                              Union (ExceptT (AsKey SymBool) Maybe (AsKey SymBool))+                          )+                          @?= mrgSingle+                            (ExceptT (Just (Right $ isym "a" 0))),+                      testCase "genSymSimple" $+                        ( genSymSimple+                            ( Just $ Right $ ssym "a" ::+                                Maybe (Either (AsKey SymBool) (AsKey SymBool))+                            )+                            "a" ::+                            ExceptT (AsKey SymBool) Maybe (AsKey SymBool)+                        )+                          @?= ExceptT (Just (Right $ isym "a" 0))+                    ]+                ]+            ]+        ],+      testGroup+        "choose*"+        [ testCase "chooseFresh" $ do+            (AsKey1 (runFresh (chooseFresh [1, 2, 3]) "a" :: Union Int))+              @?= mrgIf+                (isym "a" 0)+                (mrgSingle 1)+                (mrgIf (isym "a" 1) (mrgSingle 2) (mrgSingle 3)),+          testCase "choose" $ do+            (AsKey1 (choose [1, 2, 3] "a" :: Union Int))+              @?= mrgIf+                (isym "a" 0)+                (mrgSingle 1)+                (mrgIf (isym "a" 1) (mrgSingle 2) (mrgSingle 3)),+          testCase "chooseSimpleFresh" $ do+            (runFresh (chooseSimpleFresh ["x", "y", "z"]) "a" :: AsKey SymBool)+              @?= symIte+                (isym "a" 0)+                (ssym "x")+                (symIte (isym "a" 1) (ssym "y") (ssym "z")),+          testCase "chooseSimple" $ do+            (chooseSimple ["x", "y", "z"] "a" :: AsKey SymBool)+              @?= symIte+                (isym "a" 0)+                (ssym "x")+                (symIte (isym "a" 1) (ssym "y") (ssym "z")),+          testCase "chooseUnionFresh" $ do+            AsKey1+              ( runFresh+                  ( chooseUnionFresh+                      [ mrgIf (ssym "x") 1 2,+                        mrgIf (ssym "x") 2 3,+                        mrgIf (ssym "x") 3 4+                      ]+                  )+                  "a" ::+                  Union Int+              )+              @?= mrgIf+                (isym "a" 0)+                (mrgIf (ssym "x") 1 2)+                ( mrgIf+                    (isym "a" 1)+                    (mrgIf (ssym "x") 2 3)+                    (mrgIf (ssym "x") 3 4)+                ),+          testCase "chooseUnion" $ do+            AsKey1+              ( chooseUnion+                  [ mrgIf (ssym "x") 1 2,+                    mrgIf (ssym "x") 2 3,+                    mrgIf (ssym "x") 3 4+                  ]+                  "a" ::+                  Union Int+              )+              @?= mrgIf+                (isym "a" 0)+                (mrgIf (ssym "x") 1 2)+                ( mrgIf+                    (isym "a" 1)+                    (mrgIf (ssym "x") 2 3)+                    (mrgIf (ssym "x") 3 4)+                ),+          testCase "liftFresh" $ do+            let orig = simpleFresh () :: Fresh (AsKey SymBool, AsKey SymBool)+            let actual = flip runFreshT "a" $ do+                  r1 <- liftFresh orig+                  r2 <- liftFresh orig+                  return (r1, r2) ::+                    FreshT (AsKey1 Union) ((AsKey SymBool, AsKey SymBool), (AsKey SymBool, AsKey SymBool))+            let expected =+                  return+                    ( (isym "a" 0, isym "a" 1),+                      (isym "a" 2, isym "a" 3)+                    )+            actual @?= expected+        ],+      testCase "freshString" $ do+        runFresh (replicateM 2 $ freshString "a") "b" @?= ["b@0[a]", "b@1[a]"],+      testCase "localIdentifier" $ do+        let computation = do+              a <- simpleFresh ()+              (b1, b2) <-+                localIdentifier (mapMetadata (const $ Atom ("b" :: T.Text))) $ do+                  b1 <- simpleFresh ()+                  b2 <- simpleFresh ()+                  return (b1, b2)+              c <- simpleFresh ()+              return [a, b1, b2, c :: AsKey SymBool]+        let actual = runFresh computation "c"+        actual+          @?= [ isym "c" 0,+                isym (withMetadata "c" (Atom ("b" :: T.Text))) 0,+                isym (withMetadata "c" (Atom ("b" :: T.Text))) 1,+                isym "c" 1+              ]     ]
test/Grisette/Core/Data/Class/MergeableTests.hs view
@@ -27,23 +27,23 @@ import Data.Int (Int16, Int32, Int64, Int8) import Data.Word (Word16, Word32, Word64, Word8) import GHC.Stack (HasCallStack)-import Grisette.Core.Control.Monad.UnionM (UnionM)-import Grisette.Core.Data.Class.ITEOp (ITEOp (symIte))-import Grisette.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.&&), (.||)))-import Grisette.Core.Data.Class.Mergeable-  ( DynamicSortedIdx (DynamicSortedIdx),+import Grisette+  ( AsKey,+    DynamicSortedIdx (DynamicSortedIdx),+    ITEOp (symIte),+    LogicalOp (symNot, (.&&), (.||)),     Mergeable (rootStrategy),     MergingStrategy (NoStrategy, SimpleStrategy),+    Solvable (con, ssym),     StrategyList (StrategyList),+    SymBool,+    Union,     buildStrategyList,-    resolveStrategy,-  )-import Grisette.Core.Data.Class.SimpleMergeable-  ( mrgIf,+    mrgIf,     mrgSingle,+    resolveStrategy,   )-import Grisette.Core.Data.Class.Solvable (Solvable (con, ssym))-import Grisette.IR.SymPrim.Data.SymPrim (SymBool)+import Grisette.Internal.Core.Data.Class.AsKey (AsKey1) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.Framework.Providers.QuickCheck2 (testProperty)@@ -78,10 +78,10 @@     "Mergeable"     [ testGroup         "Mergeable for common types"-        [ let SimpleStrategy f = rootStrategy :: MergingStrategy SymBool+        [ let SimpleStrategy f = rootStrategy :: MergingStrategy (AsKey SymBool)            in testGroup                 "Mergeable for SymBool"-                [ testCase "true condition" $+                [ testCase "true condition" $ do                     f (con True) (ssym "a") (ssym "b") @?= ssym "a",                   testCase "false condition" $                     f (con False) (ssym "a") (ssym "b") @?= ssym "b",@@ -200,7 +200,7 @@                     let (idxsL, SimpleStrategy fL) =                           resolveStrategy                             rootStrategy-                            (Left (ssym "a") :: Either SymBool SymBool)+                            (Left (ssym "a") :: Either (AsKey SymBool) (AsKey SymBool))                     idxsL @?= [DynamicSortedIdx False]                     fL (ssym "a") (Left $ ssym "b") (Left $ ssym "c")                       @?= Left (symIte (ssym "a") (ssym "b") (ssym "c")),@@ -208,7 +208,7 @@                     let (idxsR, SimpleStrategy fR) =                           resolveStrategy                             rootStrategy-                            (Right (ssym "a") :: Either SymBool SymBool)+                            (Right (ssym "a") :: Either (AsKey SymBool) (AsKey SymBool))                     idxsR @?= [DynamicSortedIdx True]                     fR (ssym "a") (Right $ ssym "b") (Right $ ssym "c")                       @?= Right (symIte (ssym "a") (ssym "b") (ssym "c"))@@ -231,11 +231,11 @@                         [DynamicSortedIdx True, DynamicSortedIdx x]                         [(ssym "a", Just x, Just x, Just x)]                 ],-              testCase "Maybe SymBool / Just v" $ do+              testCase "Maybe AsKey SymBool / Just v" $ do                 let (idxsJ, SimpleStrategy fJ) =                       resolveStrategy                         rootStrategy-                        (Just (ssym "a") :: Maybe SymBool)+                        (Just (ssym "a") :: Maybe (AsKey SymBool))                 idxsJ @?= [DynamicSortedIdx True]                 fJ (ssym "a") (Just $ ssym "b") (Just $ ssym "c")                   @?= Just (symIte (ssym "a") (ssym "b") (ssym "c"))@@ -270,12 +270,12 @@                 "[SymBool]"                 [ testCase "[]" $                     testMergeableSimpleEquivClass-                      ([] :: [SymBool])+                      ([] :: [AsKey SymBool])                       [DynamicSortedIdx (0 :: Int)]                       [(ssym "a", [], [], [])],                   testCase "[v1, v2]" $                     testMergeableSimpleEquivClass-                      [ssym "a" :: SymBool, ssym "b"]+                      [ssym "a" :: AsKey SymBool, ssym "b"]                       [DynamicSortedIdx (2 :: Int)]                       [ ( ssym "a",                           [ssym "b", ssym "c"],@@ -289,7 +289,7 @@             ],           testCase "(,)" $             testMergeableSimpleEquivClass-              ([1 :: Integer], [ssym "b" :: SymBool, ssym "c"])+              ([1 :: Integer], [ssym "b" :: AsKey SymBool, ssym "c"])               [ DynamicSortedIdx (1 :: Int),                 DynamicSortedIdx $                   buildStrategyList rootStrategy [1 :: Integer],@@ -308,8 +308,8 @@           testCase "(,,)" $             testMergeableSimpleEquivClass               ( [1 :: Integer],-                [ssym "b" :: SymBool, ssym "c"],-                ssym "d" :: SymBool+                [ssym "b" :: AsKey SymBool, ssym "c"],+                ssym "d" :: AsKey SymBool               )               [ DynamicSortedIdx (1 :: Int),                 DynamicSortedIdx $@@ -330,9 +330,9 @@           testCase "(,,,)" $             testMergeableSimpleEquivClass               ( [1 :: Integer],-                [ssym "b" :: SymBool, ssym "c"],-                ssym "d" :: SymBool,-                [ssym "f" :: SymBool]+                [ssym "b" :: AsKey SymBool, ssym "c"],+                ssym "d" :: AsKey SymBool,+                [ssym "f" :: AsKey SymBool]               )               [ DynamicSortedIdx (1 :: Int),                 DynamicSortedIdx $@@ -355,9 +355,9 @@           testCase "(,,,,)" $             testMergeableSimpleEquivClass               ( [1 :: Integer],-                [ssym "b" :: SymBool, ssym "c"],-                ssym "d" :: SymBool,-                [ssym "f" :: SymBool],+                [ssym "b" :: AsKey SymBool, ssym "c"],+                ssym "d" :: AsKey SymBool,+                [ssym "f" :: AsKey SymBool],                 [2 :: Integer, 3]               )               [ DynamicSortedIdx (1 :: Int),@@ -385,9 +385,9 @@           testCase "(,,,,,)" $             testMergeableSimpleEquivClass               ( [1 :: Integer],-                [ssym "b" :: SymBool, ssym "c"],-                ssym "d" :: SymBool,-                [ssym "f" :: SymBool],+                [ssym "b" :: AsKey SymBool, ssym "c"],+                ssym "d" :: AsKey SymBool,+                [ssym "f" :: AsKey SymBool],                 [2 :: Integer, 3],                 2 :: Integer               )@@ -418,12 +418,12 @@           testCase "(,,,,,,)" $             testMergeableSimpleEquivClass               ( [1 :: Integer],-                [ssym "b" :: SymBool, ssym "c"],-                ssym "d" :: SymBool,-                [ssym "f" :: SymBool],+                [ssym "b" :: AsKey SymBool, ssym "c"],+                ssym "d" :: AsKey SymBool,+                [ssym "f" :: AsKey SymBool],                 [2 :: Integer, 3],                 2 :: Integer,-                Just (ssym "a" :: SymBool)+                Just (ssym "a" :: AsKey SymBool)               )               [ DynamicSortedIdx (1 :: Int),                 DynamicSortedIdx $@@ -468,12 +468,12 @@           testCase "(,,,,,,,)" $             testMergeableSimpleEquivClass               ( [1 :: Integer],-                [ssym "b" :: SymBool, ssym "c"],-                ssym "d" :: SymBool,-                [ssym "f" :: SymBool],+                [ssym "b" :: AsKey SymBool, ssym "c"],+                ssym "d" :: AsKey SymBool,+                [ssym "f" :: AsKey SymBool],                 [2 :: Integer, 3],                 2 :: Integer,-                Just (ssym "a" :: SymBool),+                Just (ssym "a" :: AsKey SymBool),                 Left 1 :: Either Integer Integer               )               [ DynamicSortedIdx (1 :: Int),@@ -521,15 +521,15 @@                   )                 )               ],-          let f1 :: Maybe SymBool -> SymBool =+          let f1 :: Maybe (AsKey SymBool) -> AsKey SymBool =                 \case Just x -> x; Nothing -> (con True)-              f2 :: Maybe SymBool -> SymBool =+              f2 :: Maybe (AsKey SymBool) -> AsKey SymBool =                 \case Just x -> (symNot x); Nothing -> (con False)            in testGroup                 "Function"                 [ testCase "Simply mergeable result" $ do                     case rootStrategy ::-                           MergingStrategy (Maybe SymBool -> SymBool) of+                           MergingStrategy (Maybe (AsKey SymBool) -> AsKey SymBool) of                       SimpleStrategy f -> do                         let r = f (ssym "a") f1 f2                         r (Just (ssym "x"))@@ -586,7 +586,7 @@                       resolveStrategy                         rootStrategy                         ( MaybeT (Just (Just (ssym "a"))) ::-                            MaybeT Maybe SymBool+                            MaybeT Maybe (AsKey SymBool)                         )                 idxsJ @?= [DynamicSortedIdx True, DynamicSortedIdx True]                 fJ@@ -650,7 +650,7 @@                           resolveStrategy                             rootStrategy                             ( ExceptT (Just (Left (ssym "a"))) ::-                                ExceptT SymBool Maybe SymBool+                                ExceptT (AsKey SymBool) Maybe (AsKey SymBool)                             )                     idxsJL @?= [DynamicSortedIdx True, DynamicSortedIdx False]                     fJL@@ -664,7 +664,7 @@                           resolveStrategy                             rootStrategy                             ( ExceptT (Just (Right (ssym "a"))) ::-                                ExceptT SymBool Maybe SymBool+                                ExceptT (AsKey SymBool) Maybe (AsKey SymBool)                             )                     idxsJR @?= [DynamicSortedIdx True, DynamicSortedIdx True]                     fJR@@ -681,11 +681,11 @@                 let SimpleStrategy s =                       rootStrategy ::                         MergingStrategy-                          (StateLazy.StateT Integer UnionM SymBool)-                let st1 :: StateLazy.StateT Integer UnionM SymBool =+                          (StateLazy.StateT Integer (AsKey1 Union) (AsKey SymBool))+                let st1 :: StateLazy.StateT Integer (AsKey1 Union) (AsKey SymBool) =                       StateLazy.StateT $ \(x :: Integer) ->                         mrgSingle (ssym "a", x + 2)-                let st2 :: StateLazy.StateT Integer UnionM SymBool =+                let st2 :: StateLazy.StateT Integer (AsKey1 Union) (AsKey SymBool) =                       StateLazy.StateT $ \(x :: Integer) ->                         mrgSingle (ssym "b", x * 2)                 let st3 = s (ssym "c") st1 st2@@ -700,11 +700,11 @@                 let SimpleStrategy s =                       rootStrategy ::                         MergingStrategy-                          (StateStrict.StateT Integer UnionM SymBool)-                let st1 :: StateStrict.StateT Integer UnionM SymBool =+                          (StateStrict.StateT Integer (AsKey1 Union) (AsKey SymBool))+                let st1 :: StateStrict.StateT Integer (AsKey1 Union) (AsKey SymBool) =                       StateStrict.StateT $                         \(x :: Integer) -> mrgSingle (ssym "a", x + 2)-                let st2 :: StateStrict.StateT Integer UnionM SymBool =+                let st2 :: StateStrict.StateT Integer (AsKey1 Union) (AsKey SymBool) =                       StateStrict.StateT $                         \(x :: Integer) -> mrgSingle (ssym "b", x * 2)                 let st3 = s (ssym "c") st1 st2@@ -720,10 +720,10 @@             let SimpleStrategy s =                   rootStrategy ::                     MergingStrategy-                      (ContT (SymBool, Integer) UnionM (SymBool, Integer))-            let c1 :: ContT (SymBool, Integer) UnionM (SymBool, Integer) =+                      (ContT (AsKey SymBool, Integer) (AsKey1 Union) (AsKey SymBool, Integer))+            let c1 :: ContT (AsKey SymBool, Integer) (AsKey1 Union) (AsKey SymBool, Integer) =                   ContT $ \f -> f (ssym "a", 2)-            let c2 :: ContT (SymBool, Integer) UnionM (SymBool, Integer) =+            let c2 :: ContT (AsKey SymBool, Integer) (AsKey1 Union) (AsKey SymBool, Integer) =                   ContT $ \f -> f (ssym "b", 3)             let c3 = s (ssym "c") c1 c2             runContT@@ -753,19 +753,19 @@                       rootStrategy ::                         MergingStrategy                           ( RWSTLazy.RWST-                              (Integer, SymBool)-                              (Integer, SymBool)-                              (Integer, SymBool)-                              UnionM-                              (Integer, SymBool)+                              (Integer, AsKey SymBool)+                              (Integer, AsKey SymBool)+                              (Integer, AsKey SymBool)+                              (AsKey1 Union)+                              (Integer, AsKey SymBool)                           )                 let rws1 ::                       RWSTLazy.RWST-                        (Integer, SymBool)-                        (Integer, SymBool)-                        (Integer, SymBool)-                        UnionM-                        (Integer, SymBool) =+                        (Integer, AsKey SymBool)+                        (Integer, AsKey SymBool)+                        (Integer, AsKey SymBool)+                        (AsKey1 Union)+                        (Integer, AsKey SymBool) =                         RWSTLazy.RWST $ \(ir, br) (is, bs) ->                           mrgSingle                             ( (ir + is, br .&& bs),@@ -774,11 +774,11 @@                             )                 let rws2 ::                       RWSTLazy.RWST-                        (Integer, SymBool)-                        (Integer, SymBool)-                        (Integer, SymBool)-                        UnionM-                        (Integer, SymBool) =+                        (Integer, AsKey SymBool)+                        (Integer, AsKey SymBool)+                        (Integer, AsKey SymBool)+                        (AsKey1 Union)+                        (Integer, AsKey SymBool) =                         RWSTLazy.RWST $ \(ir, br) (is, bs) ->                           mrgSingle                             ( (ir + is, br .|| bs),@@ -788,10 +788,11 @@                 let rws3 = s (ssym "c") rws1 rws2                  let res1 ::-                      UnionM-                        ( (Integer, SymBool),-                          (Integer, SymBool),-                          (Integer, SymBool)+                      AsKey1+                        Union+                        ( (Integer, AsKey SymBool),+                          (Integer, AsKey SymBool),+                          (Integer, AsKey SymBool)                         ) =                         mrgIf                           (ssym "c")@@ -813,19 +814,19 @@                       rootStrategy ::                         MergingStrategy                           ( RWSTStrict.RWST-                              (Integer, SymBool)-                              (Integer, SymBool)-                              (Integer, SymBool)-                              UnionM-                              (Integer, SymBool)+                              (Integer, AsKey SymBool)+                              (Integer, AsKey SymBool)+                              (Integer, AsKey SymBool)+                              (AsKey1 Union)+                              (Integer, AsKey SymBool)                           )                 let rws1 ::                       RWSTStrict.RWST-                        (Integer, SymBool)-                        (Integer, SymBool)-                        (Integer, SymBool)-                        UnionM-                        (Integer, SymBool) =+                        (Integer, AsKey SymBool)+                        (Integer, AsKey SymBool)+                        (Integer, AsKey SymBool)+                        (AsKey1 Union)+                        (Integer, AsKey SymBool) =                         RWSTStrict.RWST $ \(ir, br) (is, bs) ->                           mrgSingle                             ( (ir + is, br .&& bs),@@ -834,11 +835,11 @@                             )                 let rws2 ::                       RWSTStrict.RWST-                        (Integer, SymBool)-                        (Integer, SymBool)-                        (Integer, SymBool)-                        UnionM-                        (Integer, SymBool) =+                        (Integer, AsKey SymBool)+                        (Integer, AsKey SymBool)+                        (Integer, AsKey SymBool)+                        (AsKey1 Union)+                        (Integer, AsKey SymBool) =                         RWSTStrict.RWST $ \(ir, br) (is, bs) ->                           mrgSingle                             ( (ir + is, br .|| bs),@@ -848,10 +849,11 @@                 let rws3 = s (ssym "c") rws1 rws2                  let res1 ::-                      UnionM-                        ( (Integer, SymBool),-                          (Integer, SymBool),-                          (Integer, SymBool)+                      AsKey1+                        Union+                        ( (Integer, AsKey SymBool),+                          (Integer, AsKey SymBool),+                          (Integer, AsKey SymBool)                         ) =                         mrgIf                           (ssym "c")@@ -875,12 +877,12 @@                 let SimpleStrategy s =                       rootStrategy ::                         MergingStrategy-                          (WriterLazy.WriterT Integer UnionM SymBool)-                let w1 :: WriterLazy.WriterT Integer UnionM SymBool =+                          (WriterLazy.WriterT Integer (AsKey1 Union) (AsKey SymBool))+                let w1 :: WriterLazy.WriterT Integer (AsKey1 Union) (AsKey SymBool) =                       WriterLazy.WriterT $ mrgSingle (ssym "a", 1)-                let w2 :: WriterLazy.WriterT Integer UnionM SymBool =+                let w2 :: WriterLazy.WriterT Integer (AsKey1 Union) (AsKey SymBool) =                       WriterLazy.WriterT $ mrgSingle (ssym "b", 2)-                let w3 :: WriterLazy.WriterT Integer UnionM SymBool =+                let w3 :: WriterLazy.WriterT Integer (AsKey1 Union) (AsKey SymBool) =                       WriterLazy.WriterT $ mrgSingle (ssym "c", 1)                 let w4 = s (ssym "d") w1 w2                 let w5 = s (ssym "d") w1 w3@@ -895,12 +897,12 @@                 let SimpleStrategy s =                       rootStrategy ::                         MergingStrategy-                          (WriterStrict.WriterT Integer UnionM SymBool)-                let w1 :: WriterStrict.WriterT Integer UnionM SymBool =+                          (WriterStrict.WriterT Integer (AsKey1 Union) (AsKey SymBool))+                let w1 :: WriterStrict.WriterT Integer (AsKey1 Union) (AsKey SymBool) =                       WriterStrict.WriterT $ mrgSingle (ssym "a", 1)-                let w2 :: WriterStrict.WriterT Integer UnionM SymBool =+                let w2 :: WriterStrict.WriterT Integer (AsKey1 Union) (AsKey SymBool) =                       WriterStrict.WriterT $ mrgSingle (ssym "b", 2)-                let w3 :: WriterStrict.WriterT Integer UnionM SymBool =+                let w3 :: WriterStrict.WriterT Integer (AsKey1 Union) (AsKey SymBool) =                       WriterStrict.WriterT $ mrgSingle (ssym "c", 1)                 let w4 = s (ssym "d") w1 w2                 let w5 = s (ssym "d") w1 w3@@ -915,10 +917,10 @@           testCase "ReaderT" $ do             let SimpleStrategy s =                   rootStrategy ::-                    MergingStrategy (ReaderT Integer UnionM Integer)-            let r1 :: ReaderT Integer UnionM Integer =+                    MergingStrategy (ReaderT Integer (AsKey1 Union) Integer)+            let r1 :: ReaderT Integer (AsKey1 Union) Integer =                   ReaderT $ \(x :: Integer) -> mrgSingle $ x + 2-            let r2 :: ReaderT Integer UnionM Integer =+            let r2 :: ReaderT Integer (AsKey1 Union) Integer =                   ReaderT $ \(x :: Integer) -> mrgSingle $ x * 2             let r3 = s (ssym "c") r1 r2             runReaderT r3 2 @?= mrgSingle 4@@ -933,7 +935,7 @@                     [(ssym "a", Identity x, Identity x, Identity x)],               testCase "Identity SymBool" $ do                 testMergeableSimpleEquivClass-                  (Identity (ssym "a" :: SymBool))+                  (Identity (ssym "a" :: AsKey SymBool))                   []                   [ ( ssym "a",                       Identity $ ssym "b",@@ -972,7 +974,7 @@                 "IdentityT Maybe SymBool"                 [ testCase "IdentityT Nothing" $                     testMergeableSimpleEquivClass-                      (IdentityT Nothing :: IdentityT Maybe SymBool)+                      (IdentityT Nothing :: IdentityT Maybe (AsKey SymBool))                       [DynamicSortedIdx False]                       [ ( ssym "a",                           IdentityT Nothing,@@ -982,7 +984,7 @@                       ],                   testCase "IdentityT (Just v)" $                     testMergeableSimpleEquivClass-                      (IdentityT $ Just $ ssym "a" :: IdentityT Maybe SymBool)+                      (IdentityT $ Just $ ssym "a" :: IdentityT Maybe (AsKey SymBool))                       [DynamicSortedIdx True]                       [ ( ssym "a",                           IdentityT $ Just $ ssym "b",@@ -1031,12 +1033,12 @@                 "Sum Maybe Maybe SymBool"                 [ testCase "InL Nothing" $                     testMergeableSimpleEquivClass-                      (InL Nothing :: Sum Maybe Maybe SymBool)+                      (InL Nothing :: Sum Maybe Maybe (AsKey SymBool))                       [DynamicSortedIdx False, DynamicSortedIdx False]                       [(ssym "a", InL Nothing, InL Nothing, InL Nothing)],                   testCase "InL (Just v)" $                     testMergeableSimpleEquivClass-                      (InL $ Just $ ssym "a" :: Sum Maybe Maybe SymBool)+                      (InL $ Just $ ssym "a" :: Sum Maybe Maybe (AsKey SymBool))                       [DynamicSortedIdx False, DynamicSortedIdx True]                       [ ( ssym "a",                           InL $ Just $ ssym "b",@@ -1046,12 +1048,12 @@                       ],                   testCase "InR Nothing" $                     testMergeableSimpleEquivClass-                      (InR Nothing :: Sum Maybe Maybe SymBool)+                      (InR Nothing :: Sum Maybe Maybe (AsKey SymBool))                       [DynamicSortedIdx True, DynamicSortedIdx False]                       [(ssym "a", InR Nothing, InR Nothing, InR Nothing)],                   testCase "InR (Just v)" $                     testMergeableSimpleEquivClass-                      (InR $ Just $ ssym "a" :: Sum Maybe Maybe SymBool)+                      (InR $ Just $ ssym "a" :: Sum Maybe Maybe (AsKey SymBool))                       [DynamicSortedIdx True, DynamicSortedIdx True]                       [ ( ssym "a",                           InR $ Just $ ssym "b",@@ -1066,17 +1068,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)]             ]         ]
+ test/Grisette/Core/Data/Class/PPrintTests.hs view
@@ -0,0 +1,814 @@+{-# 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++#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++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.Trans.Writer.Lazy as WriterLazy+import qualified Control.Monad.Writer.Strict as WriterStrict+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)++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.+  (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.+  (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))),+          testPPrint1+            "Identity"+            0+            (Identity $ Just $ Just 1 :: Identity (Maybe (Maybe Int)))+            "Just (Just 1)",+          testPPrint1+            "Maybe (MaybeT Maybe Int)"+            0+            (Just $ MaybeT (Just (Just 1)) :: Maybe (MaybeT Maybe Int))+            "Just (MaybeT {runMaybeT = Just (Just 1)})",+          propertyPFormatRead+            "Maybe (ExceptT Int Maybe Int)"+            ( Just . ExceptT <$> arbitrary ::+                Gen (Maybe (ExceptT Int Maybe Int))+            ),+          testPPrint1+            "Maybe (LazyWriterT Int Maybe Int)"+            0+            ( Just $ WriterLazy.WriterT (Just (1, 2)) ::+                Maybe (WriterLazy.WriterT Int Maybe Int)+            )+            "Just (WriterT {runWriterT = Just (1, 2)})",+          testPPrint1+            "Maybe (StrictWriterT Int Maybe Int)"+            0+            ( Just $ WriterStrict.WriterT (Just (1, 2)) ::+                Maybe (WriterStrict.WriterT Int Maybe Int)+            )+            "Just (WriterT {runWriterT = Just (1, 2)})",+          propertyPFormatRead+            "Maybe (IdentityT Maybe Int)"+            ( Just . IdentityT <$> arbitrary ::+                Gen (Maybe (IdentityT Maybe Int))+            ),+          testGroup+            "HashSet"+            [ testPPrint1+                "Unbounded empty"+                0+                (HS.fromList [] :: HS.HashSet Int)+                "HashSet []",+              testPPrint1+                "Unbounded singleton"+                0+                (HS.fromList [1] :: HS.HashSet Int)+                "HashSet [1]",+              testPPrint1+                "Unbounded two elem"+                0+                (HS.fromList [1, 2] :: HS.HashSet Int)+                "HashSet [1, 2]",+              testPPrint1+                "Compact empty"+                1+                (HS.fromList [] :: HS.HashSet Int)+                "HashSet\n  []",+              testPPrint1+                "Compact singleton"+                1+                (HS.fromList [1] :: HS.HashSet Int)+                "HashSet\n  [ 1\n  ]",+              testPPrint1+                "Unbounded two elem"+                1+                (HS.fromList [1, 2] :: HS.HashSet Int)+                "HashSet\n  [ 1,\n    2\n  ]"+            ],+          testGroup+            "HashMap"+            [ testPPrint1+                "Unbounded empty"+                0+                (HM.fromList [] :: HM.HashMap Int Int)+                "HashMap []",+              testPPrint1+                "Unbounded singleton"+                0+                (HM.fromList [(1, 2)] :: HM.HashMap Int Int)+                "HashMap [(1, 2)]",+              testPPrint1+                "Unbounded two elem"+                0+                (HM.fromList [(1, 2), (3, 4)] :: HM.HashMap Int Int)+                "HashMap [(1, 2), (3, 4)]",+              testPPrint1+                "Compact empty"+                1+                (HM.fromList [] :: HM.HashMap Int Int)+                "HashMap\n  []",+              testPPrint1+                "Compact singleton"+                1+                (HM.fromList [(1, 2)] :: HM.HashMap Int Int)+                ( T.intercalate+                    "\n"+                    [ "HashMap",+                      "  [ ( 1,",+                      "      2",+                      "    )",+                      "  ]"+                    ]+                ),+              testPPrint1+                "Unbounded two elem"+                1+                (HM.fromList [(1, 2), (3, 4)] :: HM.HashMap Int Int)+                ( T.intercalate+                    "\n"+                    [ "HashMap",+                      "  [ ( 1,",+                      "      2",+                      "    ),",+                      "    ( 3,",+                      "      4",+                      "    )",+                      "  ]"+                    ]+                )+            ]+        ],+      testGroup+        "Symbolic types"+        [ testPPrint+            "enough space"+            80+            ("a" .&& "b" :: SymBool)+            "(&& a b)",+          testPPrint+            "not enough space"+            6+            ("a" .&& "b" :: SymBool)+            "..."+        ]+    ]
− test/Grisette/Core/Data/Class/SEqTests.hs 
@@ -1,715 +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.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.&&)))-import Grisette.Core.Data.Class.SEq (SEq ((./=), (.==)))-import Grisette.Core.Data.Class.Solvable (Solvable (con))-import Grisette.Core.Data.Class.TestValues (conBool, ssymBool)-import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool (pevalEqvTerm)-import Grisette.IR.SymPrim.Data.SymPrim (SymBool (SymBool))-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 (pevalEqvTerm 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")-            ]-        ]-    ]
− test/Grisette/Core/Data/Class/SOrdTests.hs 
@@ -1,1383 +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.Core.Control.Monad.UnionM (UnionM)-import Grisette.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.&&), (.||)))-import Grisette.Core.Data.Class.SEq (SEq ((.==)))-import Grisette.Core.Data.Class.SOrd-  ( SOrd (symCompare, (.<), (.<=), (.>), (.>=)),-  )-import Grisette.Core.Data.Class.SimpleMergeable-  ( mrgIf,-    mrgSingle,-  )-import Grisette.Core.Data.Class.TestValues (conBool, ssymBool)-import Grisette.IR.SymPrim.Data.SymPrim (SymBool)-import Grisette.Lib.Control.Monad (mrgReturn)-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]-        ]-    ]
+ test/Grisette/Core/Data/Class/SafeDivTests.hs view
@@ -0,0 +1,400 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Grisette.Core.Data.Class.SafeDivTests (safeDivTests) where++import Control.DeepSeq (NFData, force)+import Control.Exception (ArithException, catch)+import Control.Monad.Except (ExceptT, runExceptT)+import Data.Bifunctor (Bifunctor (bimap))+import Data.Data (Typeable, typeRep)+import Data.Proxy (Proxy (Proxy))+import GHC.IO (evaluate)+import GHC.Int (Int16, Int32, Int64, Int8)+import GHC.Word (Word16, Word32, Word64, Word8)+import Grisette+  ( BV (bv),+    IntN,+    Mergeable,+    SafeDiv (safeDiv, safeDivMod, safeMod, safeQuot, safeQuotRem, safeRem),+    SomeBVException (BitwidthMismatch),+    SomeIntN,+    SomeWordN,+    Union,+    WordN,+    mrgPure,+    pattern SomeIntN,+    pattern SomeWordN,+  )+import Grisette.Internal.Core.Control.Monad.Union (isMerged)+import Grisette.Internal.Core.Data.Class.SafeDiv+  ( DivOr (divModOr, divOr, modOr, quotOr, quotRemOr, remOr),+  )+import Grisette.Lib.Control.Monad.Except (mrgThrowError)+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.HUnit (assertBool, (@?=))+import Test.QuickCheck (Arbitrary, ioProperty)++divOrMatches ::+  (NFData r, Eq r', Show r') =>+  (t -> t') ->+  (r -> r') ->+  (r' -> t' -> t' -> r') ->+  (t -> t -> r) ->+  r ->+  t ->+  t ->+  IO ()+divOrMatches wrapInput wrapOutput f fref d x y = do+  rref <-+    (wrapOutput <$> evaluate (force (fref x y)))+      `catch` \(_ :: ArithException) -> return $ wrapOutput d+  let r = f (wrapOutput d) (wrapInput x) (wrapInput y)+  r @?= rref++generalOpDivOrTestBase ::+  ( NFData r,+    Arbitrary t,+    Show t,+    Arbitrary r,+    Show r,+    Eq r',+    Show r',+    Num t+  ) =>+  (t -> t') ->+  (r -> r') ->+  String ->+  (r' -> t' -> t' -> r') ->+  (t -> t -> r) ->+  Test+generalOpDivOrTestBase wrapInput wrapOutput name f fref =+  testGroup+    name+    [ testProperty "random" $ \d x y ->+        ioProperty $ divOrMatches wrapInput wrapOutput f fref d x y,+      testProperty "divided by zero" $ \d ->+        ioProperty $ divOrMatches wrapInput wrapOutput f fref d 1 0+    ]++generalOpDivOrTest ::+  ( NFData r,+    Arbitrary t,+    Show t,+    Arbitrary r,+    Show r,+    Eq r,+    Num t+  ) =>+  String ->+  (r -> t -> t -> r) ->+  (t -> t -> r) ->+  Test+generalOpDivOrTest = generalOpDivOrTestBase id id++opBoundedDivOrTestBase ::+  ( NFData r,+    Arbitrary t,+    Show t,+    Arbitrary r,+    Show r,+    Eq r',+    Show r',+    Bounded t,+    Num t+  ) =>+  (t -> t') ->+  (r -> r') ->+  String ->+  (r' -> t' -> t' -> r') ->+  (t -> t -> r) ->+  Test+opBoundedDivOrTestBase wrapInput wrapOutput name f fref =+  testGroup+    name+    [ testProperty "random" $ \d x y ->+        ioProperty $ divOrMatches wrapInput wrapOutput f fref d x y,+      testProperty "divided by zero" $ \d ->+        ioProperty $ divOrMatches wrapInput wrapOutput f fref d 1 0,+      testProperty "minBound/-1" $ \d ->+        ioProperty $ divOrMatches wrapInput wrapOutput f fref d minBound (-1)+    ]++opBoundedDivOrTest ::+  ( NFData r,+    Arbitrary t,+    Show t,+    Arbitrary r,+    Show r,+    Eq r,+    Bounded t,+    Num t+  ) =>+  String ->+  (r -> t -> t -> r) ->+  (t -> t -> r) ->+  Test+opBoundedDivOrTest = opBoundedDivOrTestBase id id++safeDivMatches ::+  (NFData r, Eq r', Show r', Mergeable r', Mergeable e, Eq e, Show e) =>+  (t -> t') ->+  (r -> r') ->+  (ArithException -> e) ->+  (t' -> t' -> ExceptT e Union r') ->+  (t -> t -> r) ->+  t ->+  t ->+  IO ()+safeDivMatches wrapInput wrapOutput wrapError f fref x y = do+  rref <-+    (mrgPure . wrapOutput <$> evaluate (force (fref x y)))+      `catch` \(e :: ArithException) -> return $ mrgThrowError $ wrapError e+  let r = f (wrapInput x) (wrapInput y)+  assertBool "Is merged" $ isMerged $ runExceptT r+  r @?= rref++generalOpSafeDivTestBase ::+  ( NFData r,+    Arbitrary t,+    Show t,+    Eq r',+    Show r',+    Num t,+    Mergeable r',+    Mergeable e,+    Show e,+    Eq e+  ) =>+  (t -> t') ->+  (r -> r') ->+  (ArithException -> e) ->+  String ->+  (t' -> t' -> ExceptT e Union r') ->+  (t -> t -> r) ->+  Test+generalOpSafeDivTestBase wrapInput wrapOutput wrapError name f fref =+  testGroup+    name+    [ testProperty "random" $ \x y ->+        ioProperty $ safeDivMatches wrapInput wrapOutput wrapError f fref x y,+      testCase "divided by zero" $+        safeDivMatches wrapInput wrapOutput wrapError f fref 1 0+    ]++generalOpSafeDivTest ::+  (NFData r, Arbitrary t, Show t, Show r, Eq r, Num t, Mergeable r) =>+  String ->+  (t -> t -> ExceptT ArithException Union r) ->+  (t -> t -> r) ->+  Test+generalOpSafeDivTest = generalOpSafeDivTestBase id id id++opBoundedSafeDivTestBase ::+  ( NFData r,+    Arbitrary t,+    Show t,+    Show r',+    Eq r',+    Num t,+    Bounded t,+    Mergeable r',+    Mergeable e,+    Show e,+    Eq e+  ) =>+  (t -> t') ->+  (r -> r') ->+  (ArithException -> e) ->+  String ->+  (t' -> t' -> ExceptT e Union r') ->+  (t -> t -> r) ->+  Test+opBoundedSafeDivTestBase wrapInput wrapOutput wrapError name f fref =+  testGroup+    name+    [ testProperty "random" $ \x y ->+        ioProperty $ safeDivMatches wrapInput wrapOutput wrapError f fref x y,+      testCase "divided by zero" $+        safeDivMatches wrapInput wrapOutput wrapError f fref 1 0,+      testCase "minBound/-1" $+        safeDivMatches wrapInput wrapOutput wrapError f fref minBound (-1)+    ]++opBoundedSafeDivTest ::+  ( NFData r,+    Arbitrary t,+    Show t,+    Show r,+    Eq r,+    Num t,+    Bounded t,+    Mergeable r+  ) =>+  String ->+  (t -> t -> ExceptT ArithException Union r) ->+  (t -> t -> r) ->+  Test+opBoundedSafeDivTest = opBoundedSafeDivTestBase id id id++type OpSafeDivTestFunc t =+  forall r.+  (Eq r, Show r, Eq r, NFData r, Mergeable r) =>+  String ->+  (t -> t -> ExceptT ArithException Union r) ->+  (t -> t -> r) ->+  Test++type OpDivOrTestFunc t =+  forall r.+  (Eq r, Show r, Eq r, NFData r, Mergeable r, Arbitrary r) =>+  String ->+  (r -> t -> t -> r) ->+  (t -> t -> r) ->+  Test++testType ::+  forall t.+  ( NFData t,+    Show t,+    SafeDiv ArithException t (ExceptT ArithException Union),+    Integral t,+    Typeable t,+    Arbitrary t+  ) =>+  OpSafeDivTestFunc t ->+  OpDivOrTestFunc t ->+  Proxy t ->+  Test+testType safeDivTestFunc divOrTestFunc p =+  testGroup+    (show $ typeRep p)+    [ divOrTestFunc "divOr" divOr (div @t),+      divOrTestFunc "modOr" modOr (mod @t),+      divOrTestFunc "divModOr" divModOr (divMod @t),+      divOrTestFunc "quotOr" quotOr (quot @t),+      divOrTestFunc "remOr" remOr (rem @t),+      divOrTestFunc "quotRemOr" quotRemOr (quotRem @t),+      safeDivTestFunc "safeDiv" safeDiv (div @t),+      safeDivTestFunc "safeMod" safeMod (mod @t),+      safeDivTestFunc "safeDivMod" safeDivMod (divMod @t),+      safeDivTestFunc "safeQuot" safeQuot (quot @t),+      safeDivTestFunc "safeRem" safeRem (rem @t),+      safeDivTestFunc "safeQuotRem" safeQuotRem (quotRem @t)+    ]++safeDivTests :: Test+safeDivTests =+  testGroup+    "SafeDiv"+    [ testType generalOpSafeDivTest generalOpDivOrTest (Proxy :: Proxy Integer),+      testType opBoundedSafeDivTest opBoundedDivOrTest (Proxy :: Proxy Int8),+      testType opBoundedSafeDivTest opBoundedDivOrTest (Proxy :: Proxy Int16),+      testType opBoundedSafeDivTest opBoundedDivOrTest (Proxy :: Proxy Int32),+      testType opBoundedSafeDivTest opBoundedDivOrTest (Proxy :: Proxy Int64),+      testType opBoundedSafeDivTest opBoundedDivOrTest (Proxy :: Proxy Int),+      testType+        opBoundedSafeDivTest+        opBoundedDivOrTest+        (Proxy :: Proxy (IntN 8)),+      testType opBoundedSafeDivTest opBoundedDivOrTest (Proxy :: Proxy Word),+      testType opBoundedSafeDivTest opBoundedDivOrTest (Proxy :: Proxy Word8),+      testType opBoundedSafeDivTest opBoundedDivOrTest (Proxy :: Proxy Word16),+      testType opBoundedSafeDivTest opBoundedDivOrTest (Proxy :: Proxy Word32),+      testType opBoundedSafeDivTest opBoundedDivOrTest (Proxy :: Proxy Word64),+      testType+        opBoundedSafeDivTest+        opBoundedDivOrTest+        (Proxy :: Proxy (WordN 8)),+      testGroup "SomeWordN" $ do+        let singleOutputDivOrTest =+              opBoundedDivOrTestBase+                SomeWordN+                SomeWordN+        let doubleOutputDivOrTest =+              opBoundedDivOrTestBase+                SomeWordN+                (bimap SomeWordN SomeWordN)+        let singleOutputSafeDivTest =+              opBoundedSafeDivTestBase+                SomeWordN+                SomeWordN+                (\e -> Right e :: Either SomeBVException ArithException)+        let doubleOutputSafeDivTest =+              opBoundedSafeDivTestBase+                SomeWordN+                (bimap SomeWordN SomeWordN)+                (\e -> Right e :: Either SomeBVException ArithException)+        [ singleOutputDivOrTest "divOr" divOr (div @(WordN 8)),+          singleOutputDivOrTest "modOr" modOr (mod @(WordN 8)),+          doubleOutputDivOrTest "divModOr" divModOr (divMod @(WordN 8)),+          singleOutputDivOrTest "quotOr" quotOr (quot @(WordN 8)),+          singleOutputDivOrTest "remOr" remOr (rem @(WordN 8)),+          doubleOutputDivOrTest "quotRemOr" quotRemOr (quotRem @(WordN 8)),+          singleOutputSafeDivTest "safeDiv" safeDiv (div @(WordN 8)),+          singleOutputSafeDivTest "safeMod" safeMod (mod @(WordN 8)),+          doubleOutputSafeDivTest "safeDivMod" safeDivMod (divMod @(WordN 8)),+          singleOutputSafeDivTest "safeQuot" safeQuot (quot @(WordN 8)),+          singleOutputSafeDivTest "safeRem" safeRem (rem @(WordN 8)),+          doubleOutputSafeDivTest+            "safeQuotRem"+            safeQuotRem+            (quotRem @(WordN 8)),+          testCase "Bitwidth mismatch" $ do+            let actual =+                  safeDiv (bv 10 2) (bv 11 3) ::+                    ExceptT+                      (Either SomeBVException ArithException)+                      Union+                      SomeWordN+            let expected = mrgThrowError $ Left BitwidthMismatch+            actual @?= expected+          ],+      testGroup "SomeIntN" $ do+        let singleOutputDivOrTest =+              opBoundedDivOrTestBase+                SomeIntN+                SomeIntN+        let doubleOutputDivOrTest =+              opBoundedDivOrTestBase+                SomeIntN+                (bimap SomeIntN SomeIntN)+        let singleOutputSafeDivTest =+              opBoundedSafeDivTestBase+                SomeIntN+                SomeIntN+                (\e -> Right e :: Either SomeBVException ArithException)+        let doubleOutputSafeDivTest =+              opBoundedSafeDivTestBase+                SomeIntN+                (bimap SomeIntN SomeIntN)+                (\e -> Right e :: Either SomeBVException ArithException)+        [ singleOutputDivOrTest "divOr" divOr (div @(IntN 8)),+          singleOutputDivOrTest "modOr" modOr (mod @(IntN 8)),+          doubleOutputDivOrTest "divModOr" divModOr (divMod @(IntN 8)),+          singleOutputDivOrTest "quotOr" quotOr (quot @(IntN 8)),+          singleOutputDivOrTest "remOr" remOr (rem @(IntN 8)),+          doubleOutputDivOrTest "quotRemOr" quotRemOr (quotRem @(IntN 8)),+          singleOutputSafeDivTest "div" safeDiv (div @(IntN 8)),+          singleOutputSafeDivTest "mod" safeMod (mod @(IntN 8)),+          doubleOutputSafeDivTest "divMod" safeDivMod (divMod @(IntN 8)),+          singleOutputSafeDivTest "quot" safeQuot (quot @(IntN 8)),+          singleOutputSafeDivTest "rem" safeRem (rem @(IntN 8)),+          doubleOutputSafeDivTest "quotRem" safeQuotRem (quotRem @(IntN 8)),+          testCase "Bitwidth mismatch" $ do+            let actual =+                  safeDiv (bv 10 2) (bv 11 3) ::+                    ExceptT+                      (Either SomeBVException ArithException)+                      Union+                      SomeIntN+            let expected = mrgThrowError $ Left BitwidthMismatch+            actual @?= expected+          ]+    ]
+ test/Grisette/Core/Data/Class/SafeLinearArithTests.hs view
@@ -0,0 +1,190 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Grisette.Core.Data.Class.SafeLinearArithTests+  ( safeLinearArithTests,+  )+where++import Control.Exception (ArithException (Overflow, Underflow))+import Control.Monad.Except (ExceptT, MonadError)+import Data.Data (Proxy (Proxy), Typeable, typeRep)+import Data.Int (Int16, Int32, Int64, Int8)+import Data.Word (Word16, Word32, Word64, Word8)+import Grisette+  ( BV (bv),+    IntN,+    Mergeable,+    SafeLinearArith (safeAdd, safeNeg, safeSub),+    SomeBVException (BitwidthMismatch),+    SomeIntN,+    SomeWordN,+    TryMerge,+    Union,+    WordN,+    mrgSingle,+    pattern SomeIntN,+    pattern SomeWordN,+  )+import Grisette.Lib.Control.Monad.Except (mrgModifyError, mrgThrowError)+import Grisette.Lib.Data.Functor (mrgFmap)+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.HUnit ((@?=))+import Test.QuickCheck (Arbitrary, ioProperty)++binSafeOp ::+  forall a m.+  ( Integral a,+    Bounded a,+    MonadError ArithException m,+    TryMerge m,+    Mergeable a+  ) =>+  (Integer -> Integer -> Integer) ->+  a ->+  a ->+  m a+binSafeOp op l r+  | result > fromIntegral (maxBound :: a) =+      mrgThrowError Overflow+  | result < fromIntegral (minBound :: a) =+      mrgThrowError Underflow+  | otherwise = mrgSingle $ fromIntegral result+  where+    result = op (fromIntegral l) (fromIntegral r)++unarySafeOp ::+  forall a m.+  ( Integral a,+    Bounded a,+    MonadError ArithException m,+    TryMerge m,+    Mergeable a+  ) =>+  (Integer -> Integer) ->+  a ->+  m a+unarySafeOp op l+  | result > fromIntegral (maxBound :: a) =+      mrgThrowError Overflow+  | result < fromIntegral (minBound :: a) =+      mrgThrowError Underflow+  | otherwise = mrgSingle $ fromIntegral result+  where+    result = op (fromIntegral l)++safeLinearArithTest ::+  forall a b e.+  ( SafeLinearArith e b (ExceptT e Union),+    Integral a,+    Bounded a,+    Arbitrary a,+    Show a,+    Show b,+    Eq b,+    Eq e,+    Show e,+    Typeable a,+    Mergeable a,+    Mergeable e+  ) =>+  (a -> b) ->+  (ArithException -> e) ->+  Test+safeLinearArithTest wrap transformError =+  testGroup+    (show $ typeRep (Proxy @a))+    [ 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 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 Union b),+      testProperty "safeNeg" $ \(l :: a) -> ioProperty $ do+        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 Union),+    Integral a,+    Bounded a,+    Arbitrary a,+    Show a,+    Typeable a+  ) =>+  Test+safeLinearArithTestSimple = safeLinearArithTest @a @a id id++safeLinearArithTests :: Test+safeLinearArithTests =+  testGroup+    "SafeLinearArith"+    [ safeLinearArithTestSimple @Int,+      safeLinearArithTestSimple @Int8,+      safeLinearArithTestSimple @Int16,+      safeLinearArithTestSimple @Int32,+      safeLinearArithTestSimple @Int64,+      safeLinearArithTestSimple @(IntN 1),+      safeLinearArithTestSimple @(IntN 2),+      safeLinearArithTestSimple @(IntN 3),+      safeLinearArithTestSimple @(IntN 128),+      safeLinearArithTest @(IntN 2)+        @SomeIntN+        @(Either SomeBVException ArithException)+        SomeIntN+        Right,+      safeLinearArithTest @(IntN 128)+        @SomeIntN+        @(Either SomeBVException ArithException)+        SomeIntN+        Right,+      testCase "SomeIntN different bit width" $ do+        let l = bv 2 1 :: SomeIntN+        let r = bv 3 1 :: SomeIntN+        let actual =+              safeAdd l r ::+                ExceptT (Either SomeBVException ArithException) Union SomeIntN+        let expected = mrgThrowError $ Left BitwidthMismatch+        actual @?= expected,+      safeLinearArithTestSimple @Word,+      safeLinearArithTestSimple @Word8,+      safeLinearArithTestSimple @Word16,+      safeLinearArithTestSimple @Word32,+      safeLinearArithTestSimple @Word64,+      safeLinearArithTestSimple @(WordN 1),+      safeLinearArithTestSimple @(WordN 2),+      safeLinearArithTestSimple @(WordN 3),+      safeLinearArithTestSimple @(WordN 128),+      safeLinearArithTest @(WordN 2)+        @SomeWordN+        @(Either SomeBVException ArithException)+        SomeWordN+        Right,+      safeLinearArithTest @(WordN 128)+        @SomeWordN+        @(Either SomeBVException ArithException)+        SomeWordN+        Right,+      testCase "SomeWordN different bit width" $ do+        let l = bv 2 1 :: SomeWordN+        let r = bv 3 1 :: SomeWordN+        let actual =+              safeAdd l r ::+                ExceptT+                  (Either SomeBVException ArithException)+                  Union+                  SomeWordN+        let expected = mrgThrowError $ Left BitwidthMismatch+        actual @?= expected+    ]
test/Grisette/Core/Data/Class/SafeSymRotateTests.hs view
@@ -13,19 +13,23 @@ import Control.Monad.Except (ExceptT) import Data.Bits (Bits (rotateL, rotateR), FiniteBits (finiteBitSize)) import Data.Int (Int16, Int32, Int64, Int8)-import Data.Typeable (Proxy (Proxy), Typeable)+import Data.Typeable (Proxy (Proxy)) import Data.Word (Word16, Word32, Word64, Word8)-import Grisette.Core.Control.Monad.UnionM (UnionM)-import Grisette.Core.Data.BV (IntN, WordN)-import Grisette.Core.Data.Class.Mergeable (Mergeable)-import Grisette.Core.Data.Class.SafeSymRotate-  ( SafeSymRotate (safeSymRotateL, safeSymRotateR),+import Grisette+  ( EvalSym,+    IntN,+    Mergeable,+    SafeSymRotate (safeSymRotateL, safeSymRotateR),+    Solvable (con),+    SymEq,+    SymIntN,+    SymWordN,+    Union,+    WordN,   )-import Grisette.Core.Data.Class.Solvable (Solvable (con))-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term (LinkedRep)-import Grisette.IR.SymPrim.Data.SymPrim (SymIntN, SymWordN) import Grisette.Lib.Control.Monad (mrgReturn) import Grisette.Lib.Control.Monad.Except (mrgThrowError)+import Grisette.TestUtil.SymbolicAssertion ((.@?=)) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.Framework.Providers.QuickCheck2 (testProperty)@@ -34,7 +38,7 @@ import Test.QuickCheck.Gen (chooseInt) import Test.QuickCheck.Property (forAll) -type EM a = ExceptT ArithException UnionM a+type EM = ExceptT ArithException Union  overflowError :: (Mergeable a) => EM a overflowError = mrgThrowError Overflow@@ -43,14 +47,10 @@   forall proxy a.   ( Arbitrary a,     Show a,-    Num a,-    Eq a,-    SafeSymRotate ArithException a,+    SafeSymRotate ArithException a EM,     FiniteBits a,     Bounded a,-    Typeable a,-    Integral a,-    Mergeable a+    Integral a   ) =>   proxy a ->   [Test]@@ -73,14 +73,10 @@   forall proxy a.   ( Arbitrary a,     Show a,-    Num a,-    Eq a,-    SafeSymRotate ArithException a,+    SafeSymRotate ArithException a EM,     FiniteBits a,     Bounded a,-    Typeable a,-    Integral a,-    Mergeable a+    Integral a   ) =>   proxy a ->   [Test]@@ -100,16 +96,14 @@   ( Arbitrary c,     Show s,     Num s,-    Eq s,-    SafeSymRotate ArithException s,+    SafeSymRotate ArithException s EM,     FiniteBits c,-    FiniteBits s,     Bounded c,-    Typeable s,     Integral c,-    LinkedRep c s,     Solvable c s,-    Mergeable s+    Show c,+    SymEq s,+    EvalSym s   ) =>   proxy s ->   [Test]@@ -124,8 +118,8 @@             let rotateAmount = fromIntegral s             let rotateLExpected = mrgReturn (con (rotateL x s)) :: EM s             let rotateRExpected = mrgReturn (con (rotateR x s)) :: EM s-            safeSymRotateL (con x) rotateAmount @?= rotateLExpected-            safeSymRotateR (con x) rotateAmount @?= rotateRExpected+            safeSymRotateL (con x) rotateAmount .@?= rotateLExpected+            safeSymRotateR (con x) rotateAmount .@?= rotateRExpected   ]  concreteSignedAtLeastThreeBitsSymTypeSafeSymRotateTests ::@@ -133,16 +127,14 @@   ( Arbitrary c,     Show s,     Num s,-    Eq s,-    SafeSymRotate ArithException s,+    SafeSymRotate ArithException s EM,     FiniteBits c,-    FiniteBits s,     Bounded c,-    Typeable s,     Integral c,-    LinkedRep c s,     Solvable c s,-    Mergeable s+    Show c,+    SymEq s,+    EvalSym s   ) =>   proxy s ->   [Test]@@ -152,8 +144,8 @@     ( do         let x = con (-1 :: c)         let rotateAmount = con (minBound :: c)-        safeSymRotateL x rotateAmount @?= (overflowError :: EM s)-        safeSymRotateR x rotateAmount @?= overflowError+        safeSymRotateL x rotateAmount .@?= (overflowError :: EM s)+        safeSymRotateR x rotateAmount .@?= overflowError     )     : concreteUnsignedSymTypeSafeSymRotateTests p @@ -205,11 +197,11 @@             [ testGroup                 "rotate left"                 [ testCase "By 0" $ do-                    safeSymRotateL (-1) 0 @?= (mrgReturn $ -1 :: EM (IntN 1))-                    safeSymRotateR (-1) 0 @?= (mrgReturn $ -1 :: EM (IntN 1)),+                    safeSymRotateL (-1) 0 .@?= (mrgReturn $ -1 :: EM (IntN 1))+                    safeSymRotateR (-1) 0 .@?= (mrgReturn $ -1 :: EM (IntN 1)),                   testCase "By -1" $ do-                    safeSymRotateL (-1) (-1 :: IntN 1) @?= overflowError-                    safeSymRotateR (-1) (-1 :: IntN 1) @?= overflowError+                    safeSymRotateL (-1) (-1 :: IntN 1) .@?= overflowError+                    safeSymRotateR (-1) (-1 :: IntN 1) .@?= overflowError                 ]             ]         ],@@ -220,17 +212,17 @@             [ testGroup                 "rotate left"                 [ testCase "By 0" $ do-                    safeSymRotateL (-2) 0 @?= (mrgReturn $ -2 :: EM (IntN 2))-                    safeSymRotateR (-2) 0 @?= (mrgReturn $ -2 :: EM (IntN 2)),+                    safeSymRotateL (-2) 0 .@?= (mrgReturn $ -2 :: EM (IntN 2))+                    safeSymRotateR (-2) 0 .@?= (mrgReturn $ -2 :: EM (IntN 2)),                   testCase "By 1" $ do-                    safeSymRotateL (-2) 1 @?= (mrgReturn 1 :: EM (IntN 2))-                    safeSymRotateR (-2) 1 @?= (mrgReturn 1 :: EM (IntN 2)),+                    safeSymRotateL (-2) 1 .@?= (mrgReturn 1 :: EM (IntN 2))+                    safeSymRotateR (-2) 1 .@?= (mrgReturn 1 :: EM (IntN 2)),                   testCase "By -1" $ do-                    safeSymRotateL (-1) (-1 :: IntN 2) @?= overflowError-                    safeSymRotateR (-1) (-1 :: IntN 2) @?= overflowError,+                    safeSymRotateL (-1) (-1 :: IntN 2) .@?= overflowError+                    safeSymRotateR (-1) (-1 :: IntN 2) .@?= overflowError,                   testCase "By -2" $ do-                    safeSymRotateL (-1) (-2 :: IntN 2) @?= overflowError-                    safeSymRotateR (-1) (-2 :: IntN 2) @?= overflowError+                    safeSymRotateL (-1) (-2 :: IntN 2) .@?= overflowError+                    safeSymRotateR (-1) (-2 :: IntN 2) .@?= overflowError                 ]             ]         ],@@ -267,12 +259,12 @@             [ testGroup                 "rotate left"                 [ testCase "By 0" $ do-                    safeSymRotateL (-1) 0 @?= (mrgReturn $ -1 :: EM (SymIntN 1))+                    safeSymRotateL (-1) 0 .@?= (mrgReturn $ -1 :: EM (SymIntN 1))                     safeSymRotateR (-1) 0-                      @?= (mrgReturn $ -1 :: EM (SymIntN 1)),+                      .@?= (mrgReturn $ -1 :: EM (SymIntN 1)),                   testCase "By -1" $ do-                    safeSymRotateL (-1) (-1 :: SymIntN 1) @?= overflowError-                    safeSymRotateR (-1) (-1 :: SymIntN 1) @?= overflowError+                    safeSymRotateL (-1) (-1 :: SymIntN 1) .@?= overflowError+                    safeSymRotateR (-1) (-1 :: SymIntN 1) .@?= overflowError                 ]             ]         ],@@ -283,18 +275,18 @@             [ testGroup                 "rotate left"                 [ testCase "By 0" $ do-                    safeSymRotateL (-2) 0 @?= (mrgReturn $ -2 :: EM (SymIntN 2))+                    safeSymRotateL (-2) 0 .@?= (mrgReturn $ -2 :: EM (SymIntN 2))                     safeSymRotateR (-2) 0-                      @?= (mrgReturn $ -2 :: EM (SymIntN 2)),+                      .@?= (mrgReturn $ -2 :: EM (SymIntN 2)),                   testCase "By 1" $ do-                    safeSymRotateL (-2) 1 @?= (mrgReturn 1 :: EM (IntN 2))-                    safeSymRotateR (-2) 1 @?= (mrgReturn 1 :: EM (IntN 2)),+                    safeSymRotateL (-2) 1 .@?= (mrgReturn 1 :: EM (IntN 2))+                    safeSymRotateR (-2) 1 .@?= (mrgReturn 1 :: EM (IntN 2)),                   testCase "By -1" $ do-                    safeSymRotateL (-1) (-1 :: SymIntN 2) @?= overflowError-                    safeSymRotateR (-1) (-1 :: SymIntN 2) @?= overflowError,+                    safeSymRotateL (-1) (-1 :: SymIntN 2) .@?= overflowError+                    safeSymRotateR (-1) (-1 :: SymIntN 2) .@?= overflowError,                   testCase "By -2" $ do-                    safeSymRotateL (-1) (-2 :: SymIntN 2) @?= overflowError-                    safeSymRotateR (-1) (-2 :: SymIntN 2) @?= overflowError+                    safeSymRotateL (-1) (-2 :: SymIntN 2) .@?= overflowError+                    safeSymRotateR (-1) (-2 :: SymIntN 2) .@?= overflowError                 ]             ]         ]
test/Grisette/Core/Data/Class/SafeSymShiftTests.hs view
@@ -10,24 +10,29 @@ import Control.Monad.Except (ExceptT) import Data.Bits (Bits (shiftL, shiftR), FiniteBits (finiteBitSize)) import Data.Int (Int16, Int32, Int64, Int8)-import Data.Typeable (Proxy (Proxy), Typeable)+import Data.Typeable (Proxy (Proxy)) import Data.Word (Word16, Word32, Word64, Word8)-import Grisette.Core.Control.Monad.UnionM (UnionM)-import Grisette.Core.Data.BV (IntN, WordN)-import Grisette.Core.Data.Class.Mergeable (Mergeable)-import Grisette.Core.Data.Class.SafeSymShift-  ( SafeSymShift+import Grisette+  ( EvalSym,+    IntN,+    Mergeable,+    SafeSymShift       ( safeSymShiftL,         safeSymShiftR,         safeSymStrictShiftL,         safeSymStrictShiftR       ),+    Solvable (con),+    SymEq,+    SymIntN,+    SymWordN,+    Union,+    WordN,   )-import Grisette.Core.Data.Class.Solvable (Solvable (con))-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term (LinkedRep)-import Grisette.IR.SymPrim.Data.SymPrim (SymIntN, SymWordN)+import Grisette.Internal.Core.Data.Class.AsKey (AsKey1) import Grisette.Lib.Control.Monad (mrgReturn) import Grisette.Lib.Control.Monad.Except (mrgThrowError)+import Grisette.TestUtil.SymbolicAssertion ((.@?=)) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.Framework.Providers.QuickCheck2 (testProperty)@@ -36,7 +41,7 @@ import Test.QuickCheck.Gen (chooseInt) import Test.QuickCheck.Property (forAll) -type EM a = ExceptT ArithException UnionM a+type EM = ExceptT ArithException (AsKey1 Union)  overflowError :: (Mergeable a) => EM a overflowError = mrgThrowError Overflow@@ -46,13 +51,9 @@   ( Arbitrary a,     Show a,     Num a,-    Eq a,-    SafeSymShift ArithException a,+    SafeSymShift ArithException a EM,     FiniteBits a,-    Bounded a,-    Typeable a,-    Integral a,-    Mergeable a+    Bounded a   ) =>   proxy a ->   [Test]@@ -89,13 +90,9 @@   ( Arbitrary a,     Show a,     Num a,-    Eq a,-    SafeSymShift ArithException a,+    SafeSymShift ArithException a EM,     FiniteBits a,-    Bounded a,-    Typeable a,-    Integral a,-    Mergeable a+    Bounded a   ) =>   proxy a ->   [Test]@@ -117,16 +114,14 @@   ( Arbitrary c,     Show s,     Num s,-    Eq s,-    SafeSymShift ArithException s,+    SafeSymShift ArithException s EM,     FiniteBits c,     FiniteBits s,     Bounded c,-    Typeable s,-    Integral c,-    LinkedRep c s,     Solvable c s,-    Mergeable s+    Show c,+    SymEq s,+    EvalSym s   ) =>   proxy s ->   [Test]@@ -138,24 +133,24 @@             let shiftAmount = fromIntegral s             let shiftLExpected = mrgReturn (con (shiftL x s)) :: EM s             let shiftRExpected = mrgReturn (con (shiftR x s)) :: EM s-            safeSymShiftL (con x) shiftAmount @?= shiftLExpected-            safeSymStrictShiftL (con x) shiftAmount @?= shiftLExpected-            safeSymShiftR (con x) shiftAmount @?= shiftRExpected-            safeSymStrictShiftR (con x) shiftAmount @?= shiftRExpected,+            safeSymShiftL (con x) shiftAmount .@?= shiftLExpected+            safeSymStrictShiftL (con x) shiftAmount .@?= shiftLExpected+            safeSymShiftR (con x) shiftAmount .@?= shiftRExpected+            safeSymStrictShiftR (con x) shiftAmount .@?= shiftRExpected,     testCase "Bit size" $ do       let x = con (maxBound :: c)       let shiftAmount = fromIntegral $ finiteBitSize x-      safeSymShiftL x shiftAmount @?= (mrgReturn 0 :: EM s)-      safeSymStrictShiftL x shiftAmount @?= overflowError-      safeSymShiftR x shiftAmount @?= (mrgReturn 0 :: EM s)-      safeSymStrictShiftR x shiftAmount @?= overflowError,+      safeSymShiftL x shiftAmount .@?= (mrgReturn 0 :: EM s)+      safeSymStrictShiftL x shiftAmount .@?= overflowError+      safeSymShiftR x shiftAmount .@?= (mrgReturn 0 :: EM s)+      safeSymStrictShiftR x shiftAmount .@?= overflowError,     testCase "Max bound" $ do       let x = con (maxBound :: c)       let shiftAmount = con (maxBound :: c)-      safeSymShiftL x shiftAmount @?= (mrgReturn 0 :: EM s)-      safeSymStrictShiftL x shiftAmount @?= overflowError-      safeSymShiftR x shiftAmount @?= (mrgReturn 0 :: EM s)-      safeSymStrictShiftR x shiftAmount @?= overflowError+      safeSymShiftL x shiftAmount .@?= (mrgReturn 0 :: EM s)+      safeSymStrictShiftL x shiftAmount .@?= overflowError+      safeSymShiftR x shiftAmount .@?= (mrgReturn 0 :: EM s)+      safeSymStrictShiftR x shiftAmount .@?= overflowError   ]  concreteSignedAtLeastThreeBitsSymTypeSafeSymShiftTests ::@@ -163,16 +158,15 @@   ( Arbitrary c,     Show s,     Num s,-    Eq s,-    SafeSymShift ArithException s,+    SafeSymShift ArithException s EM,     FiniteBits c,     FiniteBits s,     Bounded c,-    Typeable s,     Integral c,-    LinkedRep c s,     Solvable c s,-    Mergeable s+    Show c,+    EvalSym s,+    SymEq s   ) =>   proxy s ->   [Test]@@ -182,10 +176,10 @@     ( do         let x = con (-1 :: c)         let shiftAmount = con (minBound :: c)-        safeSymShiftL x shiftAmount @?= (overflowError :: EM s)-        safeSymStrictShiftL x shiftAmount @?= overflowError-        safeSymShiftR x shiftAmount @?= overflowError-        safeSymStrictShiftR x shiftAmount @?= overflowError+        safeSymShiftL x shiftAmount .@?= (overflowError :: EM s)+        safeSymStrictShiftL x shiftAmount .@?= overflowError+        safeSymShiftR x shiftAmount .@?= overflowError+        safeSymStrictShiftR x shiftAmount .@?= overflowError     )     : concreteUnsignedSymTypeSafeSymShiftTests p @@ -237,17 +231,17 @@             [ testGroup                 "shift left"                 [ testCase "By 0" $ do-                    safeSymShiftL (-1) 0 @?= (mrgReturn $ -1 :: EM (IntN 1))+                    safeSymShiftL (-1) 0 .@?= (mrgReturn $ -1 :: EM (IntN 1))                     safeSymStrictShiftL (-1) 0-                      @?= (mrgReturn $ -1 :: EM (IntN 1))-                    safeSymShiftR (-1) 0 @?= (mrgReturn $ -1 :: EM (IntN 1))+                      .@?= (mrgReturn $ -1 :: EM (IntN 1))+                    safeSymShiftR (-1) 0 .@?= (mrgReturn $ -1 :: EM (IntN 1))                     safeSymStrictShiftR (-1) 0-                      @?= (mrgReturn $ -1 :: EM (IntN 1)),+                      .@?= (mrgReturn $ -1 :: EM (IntN 1)),                   testCase "By -1" $ do-                    safeSymShiftL (-1) (-1 :: IntN 1) @?= overflowError-                    safeSymStrictShiftL (-1) (-1 :: IntN 1) @?= overflowError-                    safeSymShiftR (-1) (-1 :: IntN 1) @?= overflowError-                    safeSymStrictShiftR (-1) (-1 :: IntN 1) @?= overflowError+                    safeSymShiftL (-1) (-1 :: IntN 1) .@?= overflowError+                    safeSymStrictShiftL (-1) (-1 :: IntN 1) .@?= overflowError+                    safeSymShiftR (-1) (-1 :: IntN 1) .@?= overflowError+                    safeSymStrictShiftR (-1) (-1 :: IntN 1) .@?= overflowError                 ]             ]         ],@@ -258,31 +252,31 @@             [ testGroup                 "shift left"                 [ testCase "By 0" $ do-                    safeSymShiftL (-1) 0 @?= (mrgReturn $ -1 :: EM (IntN 2))+                    safeSymShiftL (-1) 0 .@?= (mrgReturn $ -1 :: EM (IntN 2))                     safeSymStrictShiftL (-1) 0-                      @?= (mrgReturn $ -1 :: EM (IntN 2))-                    safeSymShiftR (-1) 0 @?= (mrgReturn $ -1 :: EM (IntN 2))+                      .@?= (mrgReturn $ -1 :: EM (IntN 2))+                    safeSymShiftR (-1) 0 .@?= (mrgReturn $ -1 :: EM (IntN 2))                     safeSymStrictShiftR (-1) 0-                      @?= (mrgReturn $ -1 :: EM (IntN 2)),+                      .@?= (mrgReturn $ -1 :: EM (IntN 2)),                   testCase "By 1" $ do-                    safeSymShiftL (-1) 1 @?= (mrgReturn $ -2 :: EM (IntN 2))+                    safeSymShiftL (-1) 1 .@?= (mrgReturn $ -2 :: EM (IntN 2))                     safeSymStrictShiftL (-1) 1-                      @?= (mrgReturn $ -2 :: EM (IntN 2))-                    safeSymShiftR (-1) 1 @?= (mrgReturn $ -1 :: EM (IntN 2))+                      .@?= (mrgReturn $ -2 :: EM (IntN 2))+                    safeSymShiftR (-1) 1 .@?= (mrgReturn $ -1 :: EM (IntN 2))                     safeSymStrictShiftR (-1) 1-                      @?= (mrgReturn $ -1 :: EM (IntN 2))-                    safeSymShiftR 1 1 @?= (mrgReturn 0 :: EM (IntN 2))-                    safeSymStrictShiftR 1 1 @?= (mrgReturn 0 :: EM (IntN 2)),+                      .@?= (mrgReturn $ -1 :: EM (IntN 2))+                    safeSymShiftR 1 1 .@?= (mrgReturn 0 :: EM (IntN 2))+                    safeSymStrictShiftR 1 1 .@?= (mrgReturn 0 :: EM (IntN 2)),                   testCase "By -1" $ do-                    safeSymShiftL (-1) (-1 :: IntN 2) @?= overflowError-                    safeSymStrictShiftL (-1) (-1 :: IntN 2) @?= overflowError-                    safeSymShiftR (-1) (-1 :: IntN 2) @?= overflowError-                    safeSymStrictShiftR (-1) (-1 :: IntN 2) @?= overflowError,+                    safeSymShiftL (-1) (-1 :: IntN 2) .@?= overflowError+                    safeSymStrictShiftL (-1) (-1 :: IntN 2) .@?= overflowError+                    safeSymShiftR (-1) (-1 :: IntN 2) .@?= overflowError+                    safeSymStrictShiftR (-1) (-1 :: IntN 2) .@?= overflowError,                   testCase "By -2" $ do-                    safeSymShiftL (-1) (-2 :: IntN 2) @?= overflowError-                    safeSymStrictShiftL (-1) (-2 :: IntN 2) @?= overflowError-                    safeSymShiftR (-1) (-2 :: IntN 2) @?= overflowError-                    safeSymStrictShiftR (-1) (-2 :: IntN 2) @?= overflowError+                    safeSymShiftL (-1) (-2 :: IntN 2) .@?= overflowError+                    safeSymStrictShiftL (-1) (-2 :: IntN 2) .@?= overflowError+                    safeSymShiftR (-1) (-2 :: IntN 2) .@?= overflowError+                    safeSymStrictShiftR (-1) (-2 :: IntN 2) .@?= overflowError                 ]             ]         ],@@ -318,17 +312,17 @@             [ testGroup                 "shift left"                 [ testCase "By 0" $ do-                    safeSymShiftL (-1) 0 @?= (mrgReturn $ -1 :: EM (SymIntN 1))+                    safeSymShiftL (-1) 0 .@?= (mrgReturn $ -1 :: EM (SymIntN 1))                     safeSymStrictShiftL (-1) 0-                      @?= (mrgReturn $ -1 :: EM (SymIntN 1))-                    safeSymShiftR (-1) 0 @?= (mrgReturn $ -1 :: EM (SymIntN 1))+                      .@?= (mrgReturn $ -1 :: EM (SymIntN 1))+                    safeSymShiftR (-1) 0 .@?= (mrgReturn $ -1 :: EM (SymIntN 1))                     safeSymStrictShiftR (-1) 0-                      @?= (mrgReturn $ -1 :: EM (SymIntN 1)),+                      .@?= (mrgReturn $ -1 :: EM (SymIntN 1)),                   testCase "By -1" $ do-                    safeSymShiftL (-1) (-1 :: SymIntN 1) @?= overflowError-                    safeSymStrictShiftL (-1) (-1 :: SymIntN 1) @?= overflowError-                    safeSymShiftR (-1) (-1 :: SymIntN 1) @?= overflowError-                    safeSymStrictShiftR (-1) (-1 :: SymIntN 1) @?= overflowError+                    safeSymShiftL (-1) (-1 :: SymIntN 1) .@?= overflowError+                    safeSymStrictShiftL (-1) (-1 :: SymIntN 1) .@?= overflowError+                    safeSymShiftR (-1) (-1 :: SymIntN 1) .@?= overflowError+                    safeSymStrictShiftR (-1) (-1 :: SymIntN 1) .@?= overflowError                 ]             ]         ],@@ -339,32 +333,32 @@             [ testGroup                 "shift left"                 [ testCase "By 0" $ do-                    safeSymShiftL (-1) 0 @?= (mrgReturn $ -1 :: EM (SymIntN 2))+                    safeSymShiftL (-1) 0 .@?= (mrgReturn $ -1 :: EM (SymIntN 2))                     safeSymStrictShiftL (-1) 0-                      @?= (mrgReturn $ -1 :: EM (SymIntN 2))-                    safeSymShiftR (-1) 0 @?= (mrgReturn $ -1 :: EM (SymIntN 2))+                      .@?= (mrgReturn $ -1 :: EM (SymIntN 2))+                    safeSymShiftR (-1) 0 .@?= (mrgReturn $ -1 :: EM (SymIntN 2))                     safeSymStrictShiftR (-1) 0-                      @?= (mrgReturn $ -1 :: EM (SymIntN 2)),+                      .@?= (mrgReturn $ -1 :: EM (SymIntN 2)),                   testCase "By 1" $ do-                    safeSymShiftL (-1) 1 @?= (mrgReturn $ -2 :: EM (SymIntN 2))+                    safeSymShiftL (-1) 1 .@?= (mrgReturn $ -2 :: EM (SymIntN 2))                     safeSymStrictShiftL (-1) 1-                      @?= (mrgReturn $ -2 :: EM (SymIntN 2))-                    safeSymShiftR (-1) 1 @?= (mrgReturn $ -1 :: EM (SymIntN 2))+                      .@?= (mrgReturn $ -2 :: EM (SymIntN 2))+                    safeSymShiftR (-1) 1 .@?= (mrgReturn $ -1 :: EM (SymIntN 2))                     safeSymStrictShiftR (-1) 1-                      @?= (mrgReturn $ -1 :: EM (SymIntN 2))-                    safeSymShiftR 1 1 @?= (mrgReturn 0 :: EM (SymIntN 2))-                    safeSymStrictShiftR 1 1 @?= (mrgReturn 0 :: EM (SymIntN 2)),+                      .@?= (mrgReturn $ -1 :: EM (SymIntN 2))+                    safeSymShiftR 1 1 .@?= (mrgReturn 0 :: EM (SymIntN 2))+                    safeSymStrictShiftR 1 1 .@?= (mrgReturn 0 :: EM (SymIntN 2)),                   testCase "By -1" $ do-                    safeSymShiftL (-1) (-1 :: SymIntN 2) @?= overflowError-                    safeSymStrictShiftL (-1) (-1 :: SymIntN 2) @?= overflowError-                    safeSymShiftR (-1) (-1 :: SymIntN 2) @?= overflowError+                    safeSymShiftL (-1) (-1 :: SymIntN 2) .@?= overflowError+                    safeSymStrictShiftL (-1) (-1 :: SymIntN 2) .@?= overflowError+                    safeSymShiftR (-1) (-1 :: SymIntN 2) .@?= overflowError                     safeSymStrictShiftR (-1) (-1 :: SymIntN 2)-                      @?= overflowError,+                      .@?= overflowError,                   testCase "By -2" $ do-                    safeSymShiftL (-1) (-2 :: SymIntN 2) @?= overflowError-                    safeSymStrictShiftL (-1) (-2 :: SymIntN 2) @?= overflowError-                    safeSymShiftR (-1) (-2 :: SymIntN 2) @?= overflowError-                    safeSymStrictShiftR (-1) (-2 :: SymIntN 2) @?= overflowError+                    safeSymShiftL (-1) (-2 :: SymIntN 2) .@?= overflowError+                    safeSymStrictShiftL (-1) (-2 :: SymIntN 2) .@?= overflowError+                    safeSymShiftR (-1) (-2 :: SymIntN 2) .@?= overflowError+                    safeSymStrictShiftR (-1) (-2 :: SymIntN 2) .@?= overflowError                 ]             ]         ]
test/Grisette/Core/Data/Class/SimpleMergeableTests.hs view
@@ -26,26 +26,25 @@ import qualified Data.Monoid as Monoid import GHC.Generics (Generic) import Generics.Deriving (Default (Default))-import Grisette.Core.Control.Monad.UnionM (UnionM, (.#))-import Grisette.Core.Data.Class.ITEOp (ITEOp (symIte))-import Grisette.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.&&), (.||)))-import Grisette.Core.Data.Class.Mergeable (Mergeable)-import Grisette.Core.Data.Class.SimpleMergeable-  ( SimpleMergeable (mrgIte),-    UnionLike (unionIf),+import Grisette+  ( ITEOp (symIte),+    LogicalOp (symNot, (.&&), (.||)),+    Mergeable,+    SimpleMergeable (mrgIte),+    Solvable (con, ssym),+    SymBool,+    Union,     mrgIf,     mrgIte1,     mrgSingle,-    onUnion,-    simpleMerge,   )-import Grisette.Core.Data.Class.TestValues (conBool, ssymBool)-import Grisette.IR.SymPrim.Data.SymPrim (SymBool)+import Grisette.Core.Data.Class.TestValues (ssymBool)+import Grisette.Internal.Core.Data.Class.AsKey (AsKey, AsKey1) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit ((@?=)) -newtype AndMonoidSymBool = AndMonoidSymBool SymBool+newtype AndMonoidSymBool = AndMonoidSymBool (AsKey SymBool)   deriving (Show, Generic, Eq)   deriving (Mergeable) via (Default AndMonoidSymBool) @@ -53,7 +52,7 @@   (AndMonoidSymBool a) <> (AndMonoidSymBool b) = AndMonoidSymBool (a .&& b)  instance Monoid AndMonoidSymBool where-  mempty = AndMonoidSymBool $ conBool True+  mempty = AndMonoidSymBool $ con True  simpleMergeableTests :: Test simpleMergeableTests =@@ -62,324 +61,332 @@     [ testGroup         "SimpleMergeable for common types"         [ testCase "SymBool" $ do-            mrgIte (ssymBool "a") (ssymBool "b") (ssymBool "c")-              @?= symIte (ssymBool "a") (ssymBool "b") (ssymBool "c"),+            mrgIte (ssym "a") (ssym "b" :: AsKey SymBool) (ssym "c")+              @?= symIte (ssym "a") (ssym "b") (ssym "c"),           testCase "()" $ do-            mrgIte (ssymBool "a") () () @?= (),+            mrgIte (ssym "a") () () @?= (),           testCase "(SymBool, SymBool)" $ do             mrgIte-              (ssymBool "a")-              (ssymBool "b", ssymBool "d")-              (ssymBool "c", ssymBool "e")-              @?= ( symIte (ssymBool "a") (ssymBool "b") (ssymBool "c"),-                    symIte (ssymBool "a") (ssymBool "d") (ssymBool "e")+              (ssym "a")+              (ssym "b" :: AsKey SymBool, ssym "d" :: AsKey SymBool)+              (ssym "c", ssym "e")+              @?= ( symIte (ssym "a") (ssym "b") (ssym "c"),+                    symIte (ssym "a") (ssym "d") (ssym "e")                   ),           testCase "(SymBool, SymBool, SymBool)" $ do             mrgIte-              (ssymBool "a")-              (ssymBool "b", ssymBool "d", ssymBool "f")-              (ssymBool "c", ssymBool "e", ssymBool "g")-              @?= ( symIte (ssymBool "a") (ssymBool "b") (ssymBool "c"),-                    symIte (ssymBool "a") (ssymBool "d") (ssymBool "e"),-                    symIte (ssymBool "a") (ssymBool "f") (ssymBool "g")+              (ssym "a")+              ( ssym "b" :: AsKey SymBool,+                ssym "d" :: AsKey SymBool,+                ssym "f" :: AsKey SymBool+              )+              (ssym "c", ssym "e", ssym "g")+              @?= ( symIte (ssym "a") (ssym "b") (ssym "c"),+                    symIte (ssym "a") (ssym "d") (ssym "e"),+                    symIte (ssym "a") (ssym "f") (ssym "g")                   ),           testCase "(SymBool, SymBool, SymBool, SymBool)" $ do             mrgIte-              (ssymBool "a")-              (ssymBool "b", ssymBool "d", ssymBool "f", ssymBool "h")-              (ssymBool "c", ssymBool "e", ssymBool "g", ssymBool "i")-              @?= ( symIte (ssymBool "a") (ssymBool "b") (ssymBool "c"),-                    symIte (ssymBool "a") (ssymBool "d") (ssymBool "e"),-                    symIte (ssymBool "a") (ssymBool "f") (ssymBool "g"),-                    symIte (ssymBool "a") (ssymBool "h") (ssymBool "i")+              (ssym "a")+              ( ssym "b" :: AsKey SymBool,+                ssym "d" :: AsKey SymBool,+                ssym "f" :: AsKey SymBool,+                ssym "h" :: AsKey SymBool+              )+              (ssym "c", ssym "e", ssym "g", ssym "i")+              @?= ( symIte (ssym "a") (ssym "b") (ssym "c"),+                    symIte (ssym "a") (ssym "d") (ssym "e"),+                    symIte (ssym "a") (ssym "f") (ssym "g"),+                    symIte (ssym "a") (ssym "h") (ssym "i")                   ),           testCase "(SymBool, SymBool, SymBool, SymBool, SymBool)" $ do             mrgIte-              (ssymBool "a")-              ( ssymBool "b",-                ssymBool "d",-                ssymBool "f",-                ssymBool "h",-                ssymBool "j"+              (ssym "a")+              ( ssym "b" :: AsKey SymBool,+                ssym "d" :: AsKey SymBool,+                ssym "f" :: AsKey SymBool,+                ssym "h" :: AsKey SymBool,+                ssym "j" :: AsKey SymBool               )-              ( ssymBool "c",-                ssymBool "e",-                ssymBool "g",-                ssymBool "i",-                ssymBool "k"+              ( ssym "c",+                ssym "e",+                ssym "g",+                ssym "i",+                ssym "k"               )-              @?= ( symIte (ssymBool "a") (ssymBool "b") (ssymBool "c"),-                    symIte (ssymBool "a") (ssymBool "d") (ssymBool "e"),-                    symIte (ssymBool "a") (ssymBool "f") (ssymBool "g"),-                    symIte (ssymBool "a") (ssymBool "h") (ssymBool "i"),-                    symIte (ssymBool "a") (ssymBool "j") (ssymBool "k")+              @?= ( symIte (ssym "a") (ssym "b") (ssym "c"),+                    symIte (ssym "a") (ssym "d") (ssym "e"),+                    symIte (ssym "a") (ssym "f") (ssym "g"),+                    symIte (ssym "a") (ssym "h") (ssym "i"),+                    symIte (ssym "a") (ssym "j") (ssym "k")                   ),           testCase "(SymBool, SymBool, SymBool, SymBool, SymBool, SymBool)" $ do             mrgIte-              (ssymBool "a")-              ( ssymBool "b",-                ssymBool "d",-                ssymBool "f",-                ssymBool "h",-                ssymBool "j",-                ssymBool "l"+              (ssym "a")+              ( ssym "b" :: AsKey SymBool,+                ssym "d" :: AsKey SymBool,+                ssym "f" :: AsKey SymBool,+                ssym "h" :: AsKey SymBool,+                ssym "j" :: AsKey SymBool,+                ssym "l" :: AsKey SymBool               )-              ( ssymBool "c",-                ssymBool "e",-                ssymBool "g",-                ssymBool "i",-                ssymBool "k",-                ssymBool "m"+              ( ssym "c",+                ssym "e",+                ssym "g",+                ssym "i",+                ssym "k",+                ssym "m"               )-              @?= ( symIte (ssymBool "a") (ssymBool "b") (ssymBool "c"),-                    symIte (ssymBool "a") (ssymBool "d") (ssymBool "e"),-                    symIte (ssymBool "a") (ssymBool "f") (ssymBool "g"),-                    symIte (ssymBool "a") (ssymBool "h") (ssymBool "i"),-                    symIte (ssymBool "a") (ssymBool "j") (ssymBool "k"),-                    symIte (ssymBool "a") (ssymBool "l") (ssymBool "m")+              @?= ( symIte (ssym "a") (ssym "b") (ssym "c"),+                    symIte (ssym "a") (ssym "d") (ssym "e"),+                    symIte (ssym "a") (ssym "f") (ssym "g"),+                    symIte (ssym "a") (ssym "h") (ssym "i"),+                    symIte (ssym "a") (ssym "j") (ssym "k"),+                    symIte (ssym "a") (ssym "l") (ssym "m")                   ),           testCase             "(SymBool, SymBool, SymBool, SymBool, SymBool, SymBool, SymBool)"             $ do               mrgIte-                (ssymBool "a")-                ( ssymBool "b",-                  ssymBool "d",-                  ssymBool "f",-                  ssymBool "h",-                  ssymBool "j",-                  ssymBool "l",-                  ssymBool "n"+                (ssym "a")+                ( ssym "b" :: AsKey SymBool,+                  ssym "d" :: AsKey SymBool,+                  ssym "f" :: AsKey SymBool,+                  ssym "h" :: AsKey SymBool,+                  ssym "j" :: AsKey SymBool,+                  ssym "l" :: AsKey SymBool,+                  ssym "n" :: AsKey SymBool                 )-                ( ssymBool "c",-                  ssymBool "e",-                  ssymBool "g",-                  ssymBool "i",-                  ssymBool "k",-                  ssymBool "m",-                  ssymBool "o"+                ( ssym "c",+                  ssym "e",+                  ssym "g",+                  ssym "i",+                  ssym "k",+                  ssym "m",+                  ssym "o"                 )-                @?= ( symIte (ssymBool "a") (ssymBool "b") (ssymBool "c"),-                      symIte (ssymBool "a") (ssymBool "d") (ssymBool "e"),-                      symIte (ssymBool "a") (ssymBool "f") (ssymBool "g"),-                      symIte (ssymBool "a") (ssymBool "h") (ssymBool "i"),-                      symIte (ssymBool "a") (ssymBool "j") (ssymBool "k"),-                      symIte (ssymBool "a") (ssymBool "l") (ssymBool "m"),-                      symIte (ssymBool "a") (ssymBool "n") (ssymBool "o")+                @?= ( symIte (ssym "a") (ssym "b") (ssym "c"),+                      symIte (ssym "a") (ssym "d") (ssym "e"),+                      symIte (ssym "a") (ssym "f") (ssym "g"),+                      symIte (ssym "a") (ssym "h") (ssym "i"),+                      symIte (ssym "a") (ssym "j") (ssym "k"),+                      symIte (ssym "a") (ssym "l") (ssym "m"),+                      symIte (ssym "a") (ssym "n") (ssym "o")                     ),           testCase             "(SymBool, SymBool, SymBool, SymBool, SymBool, SymBool, SymBool, SymBool)"             $ do               mrgIte                 (ssymBool "a")-                ( ssymBool "b",-                  ssymBool "d",-                  ssymBool "f",-                  ssymBool "h",-                  ssymBool "j",-                  ssymBool "l",-                  ssymBool "n",-                  ssymBool "p"+                ( ssym "b" :: AsKey SymBool,+                  ssym "d" :: AsKey SymBool,+                  ssym "f" :: AsKey SymBool,+                  ssym "h" :: AsKey SymBool,+                  ssym "j" :: AsKey SymBool,+                  ssym "l" :: AsKey SymBool,+                  ssym "n" :: AsKey SymBool,+                  ssym "p" :: AsKey SymBool                 )-                ( ssymBool "c",-                  ssymBool "e",-                  ssymBool "g",-                  ssymBool "i",-                  ssymBool "k",-                  ssymBool "m",-                  ssymBool "o",-                  ssymBool "q"+                ( ssym "c" :: AsKey SymBool,+                  ssym "e" :: AsKey SymBool,+                  ssym "g" :: AsKey SymBool,+                  ssym "i" :: AsKey SymBool,+                  ssym "k" :: AsKey SymBool,+                  ssym "m" :: AsKey SymBool,+                  ssym "o" :: AsKey SymBool,+                  ssym "q" :: AsKey SymBool                 )-                @?= ( symIte (ssymBool "a") (ssymBool "b") (ssymBool "c"),-                      symIte (ssymBool "a") (ssymBool "d") (ssymBool "e"),-                      symIte (ssymBool "a") (ssymBool "f") (ssymBool "g"),-                      symIte (ssymBool "a") (ssymBool "h") (ssymBool "i"),-                      symIte (ssymBool "a") (ssymBool "j") (ssymBool "k"),-                      symIte (ssymBool "a") (ssymBool "l") (ssymBool "m"),-                      symIte (ssymBool "a") (ssymBool "n") (ssymBool "o"),-                      symIte (ssymBool "a") (ssymBool "p") (ssymBool "q")+                @?= ( symIte (ssym "a") (ssym "b") (ssym "c"),+                      symIte (ssym "a") (ssym "d") (ssym "e"),+                      symIte (ssym "a") (ssym "f") (ssym "g"),+                      symIte (ssym "a") (ssym "h") (ssym "i"),+                      symIte (ssym "a") (ssym "j") (ssym "k"),+                      symIte (ssym "a") (ssym "l") (ssym "m"),+                      symIte (ssym "a") (ssym "n") (ssym "o"),+                      symIte (ssym "a") (ssym "p") (ssym "q")                     ),           testCase "SymBool -> SymBool" $ do-            let f = mrgIte (ssymBool "a") symNot ((ssymBool "b") .&&)-            f (ssymBool "c")+            let f = mrgIte (ssym "a") symNot ((ssym "b" :: AsKey SymBool) .&&)+            f (ssym "c")               @?= symIte-                (ssymBool "a")-                (symNot $ ssymBool "c")-                ((ssymBool "b") .&& (ssymBool "c")),-          testCase "MaybeT (UnionM) SymBool" $ do-            let l :: MaybeT (UnionM) SymBool =+                (ssym "a")+                (symNot $ ssym "c")+                ((ssym "b") .&& (ssym "c")),+          testCase "MaybeT (Union) SymBool" $ do+            let l :: MaybeT (AsKey1 Union) (AsKey SymBool) =                   MaybeT                     ( mrgIf-                        (ssymBool "b")+                        (ssym "b")                         (mrgSingle Nothing)-                        (mrgSingle $ Just $ ssymBool "c")+                        (mrgSingle $ Just $ ssym "c")                     )-            let r :: MaybeT (UnionM) SymBool =+            let r :: MaybeT (AsKey1 Union) (AsKey SymBool) =                   MaybeT                     ( mrgIf-                        (ssymBool "d")+                        (ssym "d")                         (mrgSingle Nothing)-                        (mrgSingle $ Just $ ssymBool "e")+                        (mrgSingle $ Just $ ssym "e")                     )-            let res :: MaybeT (UnionM) SymBool =+            let res :: MaybeT (AsKey1 Union) (AsKey SymBool) =                   MaybeT                     ( mrgIf-                        (ssymBool "a")+                        (ssym "a")                         ( mrgIf-                            (ssymBool "b")+                            (ssym "b")                             (mrgSingle Nothing)-                            (mrgSingle $ Just $ ssymBool "c")+                            (mrgSingle $ Just $ ssym "c")                         )                         ( mrgIf-                            (ssymBool "d")+                            (ssym "d")                             (mrgSingle Nothing)-                            (mrgSingle $ Just $ ssymBool "e")+                            (mrgSingle $ Just $ ssym "e")                         )                     )-            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 =+            mrgIte (ssym "a") l r @?= res+            mrgIte1 (ssym "a") l r @?= res+            mrgIf (ssym "a") l r @?= res,+          testCase "ExceptT SymBool (Union) SymBool" $ do+            let l :: ExceptT (AsKey SymBool) (AsKey1 Union) (AsKey SymBool) =                   ExceptT                     ( mrgIf-                        (ssymBool "b")-                        (mrgSingle $ Left $ ssymBool "c")-                        (mrgSingle $ Right $ ssymBool "d")+                        (ssym "b")+                        (mrgSingle $ Left $ ssym "c")+                        (mrgSingle $ Right $ ssym "d")                     )             let r =                   ExceptT                     ( mrgIf-                        (ssymBool "e")-                        (mrgSingle $ Left $ ssymBool "f")-                        (mrgSingle $ Right $ ssymBool "g")+                        (ssym "e")+                        (mrgSingle $ Left $ ssym "f")+                        (mrgSingle $ Right $ ssym "g")                     )             let res =                   ExceptT                     ( mrgIf-                        (ssymBool "a")+                        (ssym "a")                         ( mrgIf-                            (ssymBool "b")-                            (mrgSingle $ Left $ ssymBool "c")-                            (mrgSingle $ Right $ ssymBool "d")+                            (ssym "b")+                            (mrgSingle $ Left $ ssym "c")+                            (mrgSingle $ Right $ ssym "d")                         )                         ( mrgIf-                            (ssymBool "e")-                            (mrgSingle $ Left $ ssymBool "f")-                            (mrgSingle $ Right $ ssymBool "g")+                            (ssym "e")+                            (mrgSingle $ Left $ ssym "f")+                            (mrgSingle $ Right $ ssym "g")                         )                     )-            mrgIte (ssymBool "a") l r @?= res-            mrgIte1 (ssymBool "a") l r @?= res-            mrgIf (ssymBool "a") l r @?= res,+            mrgIte (ssym "a") l r @?= res+            mrgIte1 (ssym "a") l r @?= res+            mrgIf (ssym "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 (AsKey1 Union) (AsKey SymBool) =                       StateLazy.StateT $ \(x :: Integer) ->-                        mrgSingle (ssymBool "a", x + 2)-                let st2 :: StateLazy.StateT Integer (UnionM) SymBool =+                        mrgSingle (ssym "a", x + 2)+                let st2 :: StateLazy.StateT Integer (AsKey1 Union) (AsKey SymBool) =                       StateLazy.StateT $ \(x :: Integer) ->-                        mrgSingle (ssymBool "b", x * 2)-                let st3 = mrgIte (ssymBool "c") st1 st2-                let st31 = mrgIte1 (ssymBool "c") st1 st2-                let st3u1 = mrgIf (ssymBool "c") st1 st2+                        mrgSingle (ssym "b", x * 2)+                let st3 = mrgIte (ssym "c") st1 st2+                let st31 = mrgIte1 (ssym "c") st1 st2+                let st3u1 = mrgIf (ssym "c") st1 st2                 StateLazy.runStateT st3 2                   @?= mrgSingle-                    (symIte (ssymBool "c") (ssymBool "a") (ssymBool "b"), 4)+                    (symIte (ssym "c") (ssym "a") (ssym "b"), 4)                 StateLazy.runStateT st3 3                   @?= mrgIf-                    (ssymBool "c")-                    (mrgSingle (ssymBool "a", 5))-                    (mrgSingle (ssymBool "b", 6))+                    (ssym "c")+                    (mrgSingle (ssym "a", 5))+                    (mrgSingle (ssym "b", 6))                 StateLazy.runStateT st31 2                   @?= mrgSingle-                    (symIte (ssymBool "c") (ssymBool "a") (ssymBool "b"), 4)+                    (symIte (ssym "c") (ssym "a") (ssym "b"), 4)                 StateLazy.runStateT st31 3                   @?= mrgIf-                    (ssymBool "c")-                    (mrgSingle (ssymBool "a", 5))-                    (mrgSingle (ssymBool "b", 6))+                    (ssym "c")+                    (mrgSingle (ssym "a", 5))+                    (mrgSingle (ssym "b", 6))                 StateLazy.runStateT st3u1 2                   @?= mrgSingle-                    (symIte (ssymBool "c") (ssymBool "a") (ssymBool "b"), 4)+                    (symIte (ssym "c") (ssym "a") (ssym "b"), 4)                 StateLazy.runStateT st3u1 3                   @?= mrgIf-                    (ssymBool "c")-                    (mrgSingle (ssymBool "a", 5))-                    (mrgSingle (ssymBool "b", 6)),+                    (ssym "c")+                    (mrgSingle (ssym "a", 5))+                    (mrgSingle (ssym "b", 6)),               testCase "Strict" $ do-                let st1 :: StateStrict.StateT Integer (UnionM) SymBool =+                let st1 :: StateStrict.StateT Integer (AsKey1 Union) (AsKey SymBool) =                       StateStrict.StateT $ \(x :: Integer) ->-                        mrgSingle (ssymBool "a", x + 2)-                let st2 :: StateStrict.StateT Integer (UnionM) SymBool =+                        mrgSingle (ssym "a", x + 2)+                let st2 :: StateStrict.StateT Integer (AsKey1 Union) (AsKey SymBool) =                       StateStrict.StateT $ \(x :: Integer) ->-                        mrgSingle (ssymBool "b", x * 2)-                let st3 = mrgIte (ssymBool "c") st1 st2-                let st31 = mrgIte1 (ssymBool "c") st1 st2-                let st3u1 = mrgIf (ssymBool "c") st1 st2+                        mrgSingle (ssym "b", x * 2)+                let st3 = mrgIte (ssym "c") st1 st2+                let st31 = mrgIte1 (ssym "c") st1 st2+                let st3u1 = mrgIf (ssym "c") st1 st2                 StateStrict.runStateT st3 2                   @?= mrgSingle-                    (symIte (ssymBool "c") (ssymBool "a") (ssymBool "b"), 4)+                    (symIte (ssym "c") (ssym "a") (ssym "b"), 4)                 StateStrict.runStateT st3 3                   @?= mrgIf-                    (ssymBool "c")-                    (mrgSingle (ssymBool "a", 5))-                    (mrgSingle (ssymBool "b", 6))+                    (ssym "c")+                    (mrgSingle (ssym "a", 5))+                    (mrgSingle (ssym "b", 6))                 StateStrict.runStateT st31 2                   @?= mrgSingle-                    (symIte (ssymBool "c") (ssymBool "a") (ssymBool "b"), 4)+                    (symIte (ssym "c") (ssym "a") (ssym "b"), 4)                 StateStrict.runStateT st31 3                   @?= mrgIf-                    (ssymBool "c")-                    (mrgSingle (ssymBool "a", 5))-                    (mrgSingle (ssymBool "b", 6))+                    (ssym "c")+                    (mrgSingle (ssym "a", 5))+                    (mrgSingle (ssym "b", 6))                 StateStrict.runStateT st3u1 2                   @?= mrgSingle-                    (symIte (ssymBool "c") (ssymBool "a") (ssymBool "b"), 4)+                    (symIte (ssym "c") (ssym "a") (ssym "b"), 4)                 StateStrict.runStateT st3u1 3                   @?= mrgIf-                    (ssymBool "c")-                    (mrgSingle (ssymBool "a", 5))-                    (mrgSingle (ssymBool "b", 6))+                    (ssym "c")+                    (mrgSingle (ssym "a", 5))+                    (mrgSingle (ssym "b", 6))             ],-          testCase "ContT (SymBool, Integer) (UnionM) (SymBool, Integer)" $ do-            let c1 :: ContT (SymBool, Integer) (UnionM) (SymBool, Integer) =-                  ContT $ \f -> f (ssymBool "a", 2)-            let c2 :: ContT (SymBool, Integer) (UnionM) (SymBool, Integer) =-                  ContT $ \f -> f (ssymBool "b", 3)-            let c3 = mrgIte (ssymBool "c") c1 c2-            let c3u1 = mrgIf (ssymBool "c") c1 c2+          testCase "ContT (SymBool, Integer) (Union) (SymBool, Integer)" $ do+            let c1 :: ContT (AsKey SymBool, Integer) (AsKey1 Union) (AsKey SymBool, Integer) =+                  ContT $ \f -> f (ssym "a", 2)+            let c2 :: ContT (AsKey SymBool, Integer) (AsKey1 Union) (AsKey SymBool, Integer) =+                  ContT $ \f -> f (ssym "b", 3)+            let c3 = mrgIte (ssym "c") c1 c2+            let c3u1 = mrgIf (ssym "c") c1 c2             let r =                   mrgIf-                    (ssymBool "c")+                    (ssym "c")                     ( mrgIf-                        (ssymBool "p")-                        (mrgSingle (ssymBool "a", 2))-                        (mrgSingle (symNot $ ssymBool "a", 3))+                        (ssym "p")+                        (mrgSingle (ssym "a", 2))+                        (mrgSingle (symNot $ ssym "a", 3))                     )                     ( mrgIf-                        (ssymBool "p")-                        (mrgSingle (ssymBool "b", 3))-                        (mrgSingle (symNot $ ssymBool "b", 4))+                        (ssym "p")+                        (mrgSingle (ssym "b", 3))+                        (mrgSingle (symNot $ ssym "b", 4))                     )             let f (a, x) =                   mrgIf-                    (ssymBool "p")+                    (ssym "p")                     (mrgSingle (a, x))-                    (mrgSingle (symNot a, x + 1))+                    (mrgSingle (symNot a, x + 1)) ::+                    AsKey1 Union (AsKey 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)+                        (Integer, AsKey SymBool)                         (Monoid.Sum Integer, AndMonoidSymBool)-                        (Integer, SymBool)-                        (UnionM)-                        (Integer, SymBool) =+                        (Integer, AsKey SymBool)+                        (AsKey1 Union)+                        (Integer, AsKey SymBool) =                         RWSTLazy.RWST $ \(ir, br) (is, bs) ->                           mrgSingle                             ( (ir + is, br .&& bs),@@ -390,11 +397,11 @@                             )                 let rws2 ::                       RWSTLazy.RWST-                        (Integer, SymBool)+                        (Integer, AsKey SymBool)                         (Monoid.Sum Integer, AndMonoidSymBool)-                        (Integer, SymBool)-                        (UnionM)-                        (Integer, SymBool) =+                        (Integer, AsKey SymBool)+                        (AsKey1 Union)+                        (Integer, AsKey SymBool) =                         RWSTLazy.RWST $ \(ir, br) (is, bs) ->                           mrgSingle                             ( (ir + is, br .|| bs),@@ -407,43 +414,44 @@                 let rws3u1 = mrgIf (ssymBool "c") rws1 rws2                  let res1 ::-                      UnionM-                        ( (Integer, SymBool),-                          (Integer, SymBool),+                      AsKey1+                        Union+                        ( (Integer, AsKey SymBool),+                          (Integer, AsKey SymBool),                           (Monoid.Sum Integer, AndMonoidSymBool)                         ) =                         mrgIf-                          (ssymBool "c")+                          (ssym "c")                           ( mrgSingle-                              ( (1, ssymBool "a" .&& ssymBool "b"),-                                (-1, ssymBool "a" .|| ssymBool "b"),+                              ( (1, ssym "a" .&& ssym "b"),+                                (-1, ssym "a" .|| ssym "b"),                                 ( 0,                                   AndMonoidSymBool $-                                    ssymBool "b" .&& ssymBool "a"+                                    ssym "b" .&& ssym "a"                                 )                               )                           )                           ( mrgSingle-                              ( (1, ssymBool "a" .|| ssymBool "b"),-                                (-1, ssymBool "a" .&& ssymBool "b"),+                              ( (1, ssym "a" .|| ssym "b"),+                                (-1, ssym "a" .&& ssym "b"),                                 ( 0,                                   AndMonoidSymBool $-                                    ssymBool "b" .|| ssymBool "a"+                                    ssym "b" .|| ssym "a"                                 )                               )                           )-                RWSTLazy.runRWST rws3 (0, ssymBool "a") (1, ssymBool "b")+                RWSTLazy.runRWST rws3 (0, ssym "a") (1, ssym "b")                   @?= res1-                RWSTLazy.runRWST rws3u1 (0, ssymBool "a") (1, ssymBool "b")+                RWSTLazy.runRWST rws3u1 (0, ssym "a") (1, ssym "b")                   @?= res1,               testCase "Strict" $ do                 let rws1 ::                       RWSTStrict.RWST-                        (Integer, SymBool)+                        (Integer, AsKey SymBool)                         (Monoid.Sum Integer, AndMonoidSymBool)-                        (Integer, SymBool)-                        (UnionM)-                        (Integer, SymBool) =+                        (Integer, AsKey SymBool)+                        (AsKey1 Union)+                        (Integer, AsKey SymBool) =                         RWSTStrict.RWST $ \(ir, br) (is, bs) ->                           mrgSingle                             ( (ir + is, br .&& bs),@@ -454,11 +462,11 @@                             )                 let rws2 ::                       RWSTStrict.RWST-                        (Integer, SymBool)+                        (Integer, AsKey SymBool)                         (Monoid.Sum Integer, AndMonoidSymBool)-                        (Integer, SymBool)-                        (UnionM)-                        (Integer, SymBool) =+                        (Integer, AsKey SymBool)+                        (AsKey1 Union)+                        (Integer, AsKey SymBool) =                         RWSTStrict.RWST $ \(ir, br) (is, bs) ->                           mrgSingle                             ( (ir + is, br .|| bs),@@ -471,208 +479,187 @@                 let rws3u1 = mrgIf (ssymBool "c") rws1 rws2                  let res1 ::-                      UnionM-                        ( (Integer, SymBool),-                          (Integer, SymBool),+                      AsKey1+                        Union+                        ( (Integer, AsKey SymBool),+                          (Integer, AsKey SymBool),                           (Monoid.Sum Integer, AndMonoidSymBool)                         ) =                         mrgIf                           (ssymBool "c")                           ( mrgSingle-                              ( (1, ssymBool "a" .&& ssymBool "b"),-                                (-1, ssymBool "a" .|| ssymBool "b"),+                              ( (1, ssym "a" .&& ssym "b"),+                                (-1, ssym "a" .|| ssym "b"),                                 ( 0,                                   AndMonoidSymBool $-                                    ssymBool "b" .&& ssymBool "a"+                                    ssym "b" .&& ssym "a"                                 )                               )                           )                           ( mrgSingle-                              ( (1, ssymBool "a" .|| ssymBool "b"),-                                (-1, ssymBool "a" .&& ssymBool "b"),+                              ( (1, ssym "a" .|| ssym "b"),+                                (-1, ssym "a" .&& ssym "b"),                                 ( 0,                                   AndMonoidSymBool $-                                    ssymBool "b" .|| ssymBool "a"+                                    ssym "b" .|| ssym "a"                                 )                               )                           )-                RWSTStrict.runRWST rws3 (0, ssymBool "a") (1, ssymBool "b")+                RWSTStrict.runRWST rws3 (0, ssym "a") (1, ssym "b")                   @?= res1-                RWSTStrict.runRWST rws3u1 (0, ssymBool "a") (1, ssymBool "b")+                RWSTStrict.runRWST rws3u1 (0, ssym "a") (1, ssym "b")                   @?= 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)-                        SymBool =-                        WriterLazy.WriterT $ mrgSingle (ssymBool "a", 1)+                        (AsKey1 Union)+                        (AsKey SymBool) =+                        WriterLazy.WriterT $ mrgSingle (ssym "a", 1)                 let st2 ::                       WriterLazy.WriterT                         (Monoid.Sum Integer)-                        (UnionM)-                        SymBool =-                        WriterLazy.WriterT $ mrgSingle (ssymBool "b", 2)+                        (AsKey1 Union)+                        (AsKey SymBool) =+                        WriterLazy.WriterT $ mrgSingle (ssym "b", 2)                 let st3 ::                       WriterLazy.WriterT                         (Monoid.Sum Integer)-                        (UnionM)-                        SymBool =-                        WriterLazy.WriterT $ mrgSingle (ssymBool "c", 1)-                let st4 = mrgIte (ssymBool "d") st1 st2-                let st41 = mrgIte1 (ssymBool "d") st1 st2-                let st4u1 = mrgIf (ssymBool "d") st1 st2-                let st5 = mrgIte (ssymBool "d") st1 st3-                let st51 = mrgIte1 (ssymBool "d") st1 st3-                let st5u1 = mrgIf (ssymBool "d") st1 st3+                        (AsKey1 Union)+                        (AsKey SymBool) =+                        WriterLazy.WriterT $ mrgSingle (ssym "c", 1)+                let st4 = mrgIte (ssym "d") st1 st2+                let st41 = mrgIte1 (ssym "d") st1 st2+                let st4u1 = mrgIf (ssym "d") st1 st2+                let st5 = mrgIte (ssym "d") st1 st3+                let st51 = mrgIte1 (ssym "d") st1 st3+                let st5u1 = mrgIf (ssym "d") st1 st3                 WriterLazy.runWriterT st4                   @?= mrgIf-                    (ssymBool "d")-                    (mrgSingle (ssymBool "a", 1))-                    (mrgSingle (ssymBool "b", 2))+                    (ssym "d")+                    (mrgSingle (ssym "a", 1))+                    (mrgSingle (ssym "b", 2))                 WriterLazy.runWriterT st41                   @?= mrgIf-                    (ssymBool "d")-                    (mrgSingle (ssymBool "a", 1))-                    (mrgSingle (ssymBool "b", 2))+                    (ssym "d")+                    (mrgSingle (ssym "a", 1))+                    (mrgSingle (ssym "b", 2))                 WriterLazy.runWriterT st4u1                   @?= mrgIf-                    (ssymBool "d")-                    (mrgSingle (ssymBool "a", 1))-                    (mrgSingle (ssymBool "b", 2))+                    (ssym "d")+                    (mrgSingle (ssym "a", 1))+                    (mrgSingle (ssym "b", 2))                 WriterLazy.runWriterT st5                   @?= mrgSingle-                    (symIte (ssymBool "d") (ssymBool "a") (ssymBool "c"), 1)+                    (symIte (ssym "d") (ssym "a") (ssym "c"), 1)                 WriterLazy.runWriterT st51                   @?= mrgSingle-                    (symIte (ssymBool "d") (ssymBool "a") (ssymBool "c"), 1)+                    (symIte (ssym "d") (ssym "a") (ssym "c"), 1)                 WriterLazy.runWriterT st5u1                   @?= mrgSingle-                    (symIte (ssymBool "d") (ssymBool "a") (ssymBool "c"), 1),+                    (symIte (ssym "d") (ssym "a") (ssym "c"), 1),               testCase "Strict" $ do                 let st1 ::                       WriterStrict.WriterT                         (Monoid.Sum Integer)-                        (UnionM)-                        SymBool =-                        WriterStrict.WriterT $ mrgSingle (ssymBool "a", 1)+                        (AsKey1 Union)+                        (AsKey SymBool) =+                        WriterStrict.WriterT $ mrgSingle (ssym "a", 1)                 let st2 ::                       WriterStrict.WriterT                         (Monoid.Sum Integer)-                        (UnionM)-                        SymBool =-                        WriterStrict.WriterT $ mrgSingle (ssymBool "b", 2)+                        (AsKey1 Union)+                        (AsKey SymBool) =+                        WriterStrict.WriterT $ mrgSingle (ssym "b", 2)                 let st3 ::                       WriterStrict.WriterT                         (Monoid.Sum Integer)-                        (UnionM)-                        SymBool =-                        WriterStrict.WriterT $ mrgSingle (ssymBool "c", 1)-                let st4 = mrgIte (ssymBool "d") st1 st2-                let st41 = mrgIte1 (ssymBool "d") st1 st2-                let st4u1 = mrgIf (ssymBool "d") st1 st2-                let st5 = mrgIte (ssymBool "d") st1 st3-                let st51 = mrgIte1 (ssymBool "d") st1 st3-                let st5u1 = mrgIf (ssymBool "d") st1 st3+                        (AsKey1 Union)+                        (AsKey SymBool) =+                        WriterStrict.WriterT $ mrgSingle (ssym "c", 1)+                let st4 = mrgIte (ssym "d") st1 st2+                let st41 = mrgIte1 (ssym "d") st1 st2+                let st4u1 = mrgIf (ssym "d") st1 st2+                let st5 = mrgIte (ssym "d") st1 st3+                let st51 = mrgIte1 (ssym "d") st1 st3+                let st5u1 = mrgIf (ssym "d") st1 st3                 WriterStrict.runWriterT st4                   @?= mrgIf-                    (ssymBool "d")-                    (mrgSingle (ssymBool "a", 1))-                    (mrgSingle (ssymBool "b", 2))+                    (ssym "d")+                    (mrgSingle (ssym "a", 1))+                    (mrgSingle (ssym "b", 2))                 WriterStrict.runWriterT st41                   @?= mrgIf-                    (ssymBool "d")-                    (mrgSingle (ssymBool "a", 1))-                    (mrgSingle (ssymBool "b", 2))+                    (ssym "d")+                    (mrgSingle (ssym "a", 1))+                    (mrgSingle (ssym "b", 2))                 WriterStrict.runWriterT st4u1                   @?= mrgIf-                    (ssymBool "d")-                    (mrgSingle (ssymBool "a", 1))-                    (mrgSingle (ssymBool "b", 2))+                    (ssym "d")+                    (mrgSingle (ssym "a", 1))+                    (mrgSingle (ssym "b", 2))                 WriterStrict.runWriterT st5                   @?= mrgSingle-                    (symIte (ssymBool "d") (ssymBool "a") (ssymBool "c"), 1)+                    (symIte (ssym "d") (ssym "a") (ssym "c"), 1)                 WriterStrict.runWriterT st51                   @?= mrgSingle-                    (symIte (ssymBool "d") (ssymBool "a") (ssymBool "c"), 1)+                    (symIte (ssym "d") (ssym "a") (ssym "c"), 1)                 WriterStrict.runWriterT st5u1                   @?= mrgSingle-                    (symIte (ssymBool "d") (ssymBool "a") (ssymBool "c"), 1)+                    (symIte (ssym "d") (ssym "a") (ssym "c"), 1)             ],-          testCase "ReaderT Integer (UnionM) Integer" $ do-            let r1 :: ReaderT Integer (UnionM) Integer =+          testCase "ReaderT Integer (Union) Integer" $ do+            let r1 :: ReaderT Integer (AsKey1 Union) Integer =                   ReaderT $ \(x :: Integer) -> mrgSingle $ x + 2-            let r2 :: ReaderT Integer (UnionM) Integer =+            let r2 :: ReaderT Integer (AsKey1 Union) Integer =                   ReaderT $ \(x :: Integer) -> mrgSingle $ x * 2-            let r3 = mrgIte (ssymBool "c") r1 r2-            let r3u1 = mrgIf (ssymBool "c") r1 r2+            let r3 = mrgIte (ssym "c") r1 r2+            let r3u1 = mrgIf (ssym "c") r1 r2             runReaderT r3 2 @?= mrgSingle 4-            runReaderT r3 3 @?= mrgIf (ssymBool "c") (mrgSingle 5) (mrgSingle 6)+            runReaderT r3 3 @?= mrgIf (ssym "c") (mrgSingle 5) (mrgSingle 6)             runReaderT r3u1 2 @?= mrgSingle 4             runReaderT r3u1 3               @?= mrgIf-                (ssymBool "c")+                (ssym "c")                 (mrgSingle 5)                 (mrgSingle 6) -            let r4 :: ReaderT SymBool (UnionM) SymBool =-                  ReaderT $ \x -> mrgSingle $ x .&& ssymBool "x"-            let r5 :: ReaderT SymBool (UnionM) SymBool =-                  ReaderT $ \x -> mrgSingle $ x .|| ssymBool "y"-            let r61 = mrgIte1 (ssymBool "c") r4 r5-            runReaderT r61 (ssymBool "a")+            let r4 :: ReaderT (AsKey SymBool) (AsKey1 Union) (AsKey SymBool) =+                  ReaderT $ \x -> mrgSingle $ x .&& ssym "x"+            let r5 :: ReaderT (AsKey SymBool) (AsKey1 Union) (AsKey SymBool) =+                  ReaderT $ \x -> mrgSingle $ x .|| ssym "y"+            let r61 = mrgIte1 (ssym "c") r4 r5+            runReaderT r61 (ssym "a")               @?= mrgSingle                 ( symIte-                    (ssymBool "c")-                    (ssymBool "a" .&& ssymBool "x")-                    (ssymBool "a" .|| ssymBool "y")+                    (ssym "c")+                    (ssym "a" .&& ssym "x")+                    (ssym "a" .|| ssym "y")                 ),           testCase "Identity SymBool" $ do-            let i1 :: Identity SymBool = Identity $ ssymBool "a"-            let i2 :: Identity SymBool = Identity $ ssymBool "b"-            let i3 = mrgIte (ssymBool "c") i1 i2-            let i31 = mrgIte1 (ssymBool "c") i1 i2-            runIdentity i3 @?= symIte (ssymBool "c") (ssymBool "a") (ssymBool "b")+            let i1 :: Identity (AsKey SymBool) = Identity $ ssym "a"+            let i2 :: Identity (AsKey SymBool) = Identity $ ssym "b"+            let i3 = mrgIte (ssym "c") i1 i2+            let i31 = mrgIte1 (ssym "c") i1 i2+            runIdentity i3 @?= symIte (ssym "c") (ssym "a") (ssym "b")             runIdentity i31-              @?= symIte (ssymBool "c") (ssymBool "a") (ssymBool "b"),-          testCase "IdentityT (UnionM) SymBool" $ do-            let i1 :: IdentityT (UnionM) SymBool =-                  IdentityT $ mrgSingle $ ssymBool "a"-            let i2 :: IdentityT (UnionM) SymBool =-                  IdentityT $ mrgSingle $ ssymBool "b"-            let i3 = mrgIte (ssymBool "c") i1 i2-            let i31 = mrgIte1 (ssymBool "c") i1 i2-            let i3u1 = mrgIf (ssymBool "c") i1 i2+              @?= symIte (ssym "c") (ssym "a") (ssym "b"),+          testCase "IdentityT (Union) SymBool" $ do+            let i1 :: IdentityT (AsKey1 Union) (AsKey SymBool) =+                  IdentityT $ mrgSingle $ ssym "a"+            let i2 :: IdentityT (AsKey1 Union) (AsKey SymBool) =+                  IdentityT $ mrgSingle $ ssym "b"+            let i3 = mrgIte (ssym "c") i1 i2+            let i31 = mrgIte1 (ssym "c") i1 i2+            let i3u1 = mrgIf (ssym "c") i1 i2             runIdentityT i3-              @?= mrgSingle (symIte (ssymBool "c") (ssymBool "a") (ssymBool "b"))+              @?= mrgSingle (symIte (ssym "c") (ssym "a") (ssym "b"))             runIdentityT i31-              @?= mrgSingle (symIte (ssymBool "c") (ssymBool "a") (ssymBool "b"))+              @?= mrgSingle (symIte (ssym "c") (ssym "a") (ssym "b"))             runIdentityT i3u1-              @?= mrgSingle (symIte (ssymBool "c") (ssymBool "a") (ssymBool "b"))-        ],-      testGroup-        "Combinators"-        [ testCase "simpleMerge" $ do-            simpleMerge-              (unionIf "a" (return "b") (return "c") :: UnionM SymBool)-              @?= symIte (ssymBool "a") (ssymBool "b") (ssymBool "c"),-          testCase "onUnion" $ do-            let symAll = foldl (.&&) (conBool True)-            let symAllU = onUnion symAll-            symAllU-              ( unionIf "cond" (return ["a"]) (return ["b", "c"]) ::-                  UnionM [SymBool]-              )-              @?= symIte "cond" "a" ("b" .&& "c"),-          testCase "(.#)" $ do-            let symAll = foldl (.&&) (conBool True)-            symAll-              .# ( unionIf "cond" (return ["a"]) (return ["b", "c"]) ::-                     UnionM [SymBool]-                 )-              @?= symIte "cond" "a" ("b" .&& "c")+              @?= mrgSingle (symIte (ssym "c") (ssym "a") (ssym "b"))         ]     ]
+ test/Grisette/Core/Data/Class/SubstSymTests.hs view
@@ -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 (AsKey (getAsKey), LogicalOp ((.||)), Solvable (ssym), 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 = ssym "a" :: AsKey SymBool+            let b = ssym "b" :: AsKey SymBool+            let c = ssym "c" :: AsKey SymBool+            let subst = substSym asym (getAsKey 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 = ssym "a" :: AsKey SymBool+                let b = ssym "b" :: AsKey SymBool+                let c = ssym "c" :: AsKey SymBool+                let subst = substSym asym (getAsKey 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 = ssym "a" :: AsKey SymBool+                let b = ssym "b" :: AsKey SymBool+                let c = ssym "c" :: AsKey SymBool+                let subst :: Maybe (AsKey SymBool) -> Maybe (AsKey SymBool)+                    subst = substSym asym (getAsKey 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 = ssym "a" :: AsKey SymBool+                let b = ssym "b" :: AsKey SymBool+                let c = ssym "c" :: AsKey SymBool+                let subst :: Either (AsKey SymBool) (AsKey SymBool) -> Either (AsKey SymBool) (AsKey SymBool)+                    subst = substSym asym (getAsKey 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 = ssym "a" :: AsKey SymBool+                let b = ssym "b" :: AsKey SymBool+                let c = ssym "c" :: AsKey SymBool+                let subst :: MaybeT Maybe (AsKey SymBool) -> MaybeT Maybe (AsKey SymBool)+                    subst = substSym asym (getAsKey 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 = ssym "a" :: AsKey SymBool+                let b = ssym "b" :: AsKey SymBool+                let c = ssym "c" :: AsKey SymBool+                let subst ::+                      ExceptT (AsKey SymBool) Maybe (AsKey SymBool) ->+                      ExceptT (AsKey SymBool) Maybe (AsKey SymBool)+                    subst = substSym asym (getAsKey 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 = ssym "a" :: AsKey SymBool+                let b = ssym "b" :: AsKey SymBool+                let c = ssym "c" :: AsKey SymBool+                substSym asym (getAsKey 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 = ssym "a" :: AsKey SymBool+                let b = ssym "b" :: AsKey SymBool+                let c = ssym "c" :: AsKey SymBool+                substSym asym (getAsKey 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 = ssym "a" :: AsKey SymBool+                let b = ssym "b" :: AsKey SymBool+                let c = ssym "c" :: AsKey SymBool+                substSym asym (getAsKey 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 = ssym "a" :: AsKey SymBool+                let b = ssym "b" :: AsKey SymBool+                let c = ssym "c" :: AsKey SymBool+                substSym asym (getAsKey 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 = ssym "a" :: AsKey SymBool+                  let b = ssym "b" :: AsKey SymBool+                  let c = ssym "c" :: AsKey SymBool+                  substSym asym (getAsKey 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 = ssym "a" :: AsKey SymBool+                  let b = ssym "b" :: AsKey SymBool+                  let c = ssym "c" :: AsKey SymBool+                  substSym asym (getAsKey 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 = ssym "a" :: AsKey SymBool+                  let b = ssym "b" :: AsKey SymBool+                  let c = ssym "c" :: AsKey SymBool+                  substSym asym (getAsKey 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 = ssym "a"+                    let b = ssym "b"+                    let c = ssym "c"+                    let subst ::+                          Sum Maybe Maybe (AsKey SymBool) ->+                          Sum Maybe Maybe (AsKey SymBool)+                        subst = substSym asym (getAsKey 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 = ssym "a"+                    let b = ssym "b"+                    let c = ssym "c"+                    let subst ::+                          WriterLazy.WriterT (AsKey SymBool) (Either (AsKey SymBool)) (AsKey SymBool) ->+                          WriterLazy.WriterT (AsKey SymBool) (Either (AsKey SymBool)) (AsKey SymBool)+                        subst = substSym asym (getAsKey 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 = ssym "a"+                    let b = ssym "b"+                    let c = ssym "c"+                    let subst ::+                          WriterStrict.WriterT+                            (AsKey SymBool)+                            (Either (AsKey SymBool))+                            (AsKey SymBool) ->+                          WriterStrict.WriterT+                            (AsKey SymBool)+                            (Either (AsKey SymBool))+                            (AsKey SymBool)+                        subst = substSym asym (getAsKey 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 = ssym "a"+                let b = ssym "b"+                let c = ssym "c"+                let subst :: Identity (AsKey SymBool) -> Identity (AsKey SymBool)+                    subst = substSym asym (getAsKey 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 = ssym "a"+                let b = ssym "b"+                let c = ssym "c"+                let subst ::+                      IdentityT (Either (AsKey SymBool)) (AsKey SymBool) ->+                      IdentityT (Either (AsKey SymBool)) (AsKey SymBool)+                    subst = substSym asym (getAsKey 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)+            ]+        ]+    ]
− test/Grisette/Core/Data/Class/SubstituteSymTests.hs 
@@ -1,418 +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.Core.Data.Class.LogicalOp (LogicalOp ((.||)))-import Grisette.Core.Data.Class.SubstituteSym (SubstituteSym (substituteSym))-import Grisette.Core.Data.Class.TestValues (ssymBool, ssymbolBool)-import Grisette.IR.SymPrim.Data.SymPrim (SymBool)-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)-            ]-        ]-    ]
+ test/Grisette/Core/Data/Class/SymEqTests.hs view
@@ -0,0 +1,735 @@+{-# 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+  ( AsKey (AsKey),+    LogicalOp (false, symNot, true, (.&&)),+    Solvable (con),+    SymBool (SymBool),+    SymEq ((./=), (.==)),+  )+import Grisette.Core.Data.Class.TestValues+  ( conBool,+    ssymBool,+  )+import Grisette.Internal.SymPrim.Prim.Term (pevalEqTerm)+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)++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+  AsKey (i .== j) @?= con (i == j)+  AsKey (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)" $+                        AsKey+                          ( ( WriterStrict.WriterT+                                (Right (ssymBool "a", ssymBool "b")) ::+                                WriterStrict.WriterT+                                  SymBool+                                  (Either SymBool)+                                  SymBool+                            )+                              .== WriterStrict.WriterT+                                (Right (ssymBool "c", ssymBool "d"))+                          )+                          .@?= AsKey (ssymBool "a" .== ssymBool "c")+                          .&& AsKey (ssymBool "b" .== ssymBool "d")+                    ]+                ]+            ],+          testGroup+            "Identity"+            [ testProperty+                "Identity Integer"+                ( ioProperty . \(v1 :: Integer, v2) ->+                    concreteSymEqOkProp (Identity v1, Identity v2)+                ),+              testCase "Identity SymBool" $ do+                AsKey+                  ( (Identity $ ssymBool "a" :: Identity SymBool)+                      .== Identity (ssymBool "b")+                  )+                  .@?= AsKey (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)" $+                    AsKey+                      ( ( IdentityT $ Left $ ssymBool "a" ::+                            IdentityT (Either SymBool) SymBool+                        )+                          .== IdentityT (Left $ ssymBool "b")+                      )+                      .@?= AsKey (ssymBool "a" .== ssymBool "b"),+                  testCase "IdentityT (Left v) vs IdentityT (Right v)" $+                    AsKey+                      ( ( IdentityT $ Left $ ssymBool "a" ::+                            IdentityT (Either SymBool) SymBool+                        )+                          .== IdentityT (Right $ ssymBool "b")+                      )+                      .@?= false,+                  testCase "IdentityT (Right v) vs IdentityT (Left v)" $+                    AsKey+                      ( ( IdentityT $ Right $ ssymBool "a" ::+                            IdentityT (Either SymBool) SymBool+                        )+                          .== IdentityT (Left $ ssymBool "b")+                      )+                      .@?= false,+                  testCase "IdentityT (Right v) vs IdentityT (Right v)" $+                    AsKey+                      ( ( IdentityT $ Right $ ssymBool "a" ::+                            IdentityT (Either SymBool) SymBool+                        )+                          .== IdentityT (Right $ ssymBool "b")+                      )+                      .@?= AsKey (ssymBool "a" .== ssymBool "b")+                ]+            ]+        ],+      testGroup+        "deriving SymEq for ADT"+        [ testGroup+            "Simple ADT"+            [ testCase "A1 vs A1" $+                AsKey (A1 .== A1) .@?= true,+              testCase "A1 vs A2" $+                AsKey (A1 .== A2 (ssymBool "a")) .@?= false,+              testCase "A1 vs A3" $+                AsKey (A1 .== A3 (ssymBool "a") (ssymBool "b")) .@?= false,+              testCase "A2 vs A1" $+                AsKey (A2 (ssymBool "a") .== A1) .@?= false,+              testCase "A2 vs A2" $+                AsKey (A2 (ssymBool "a") .== A2 (ssymBool "b"))+                  .@?= AsKey+                    ( ssymBool "a"+                        .== ssymBool "b"+                    ),+              testCase "A2 vs A3" $+                AsKey (A2 (ssymBool "a") .== A3 (ssymBool "b") (ssymBool "c"))+                  .@?= false,+              testCase "A3 vs A1" $+                AsKey (A3 (ssymBool "a") (ssymBool "b") .== A1) .@?= false,+              testCase "A3 vs A2" $+                AsKey+                  ( A3 (ssymBool "a") (ssymBool "b")+                      .== A2 (ssymBool "c")+                  )+                  .@?= false,+              testCase "A3 vs A3" $+                AsKey+                  ( A3 (ssymBool "a") (ssymBool "b")+                      .== A3 (ssymBool "c") (ssymBool "d")+                  )+                  .@?= AsKey+                    ( (ssymBool "a" .== ssymBool "c")+                        .&& (ssymBool "b" .== ssymBool "d")+                    )+            ]+        ]+    ]
+ test/Grisette/Core/Data/Class/SymFiniteBitsTests.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE BinaryLiterals #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Grisette.Core.Data.Class.SymFiniteBitsTests (symFiniteBitsTests) where++import Data.Proxy (Proxy (Proxy))+import Grisette+  ( BV (bv),+    EvalSym,+    ITEOp (symIte),+    LogicalOp (false, true),+    SomeSymIntN,+    SomeSymWordN,+    SymEq,+    SymIntN,+    SymWordN,+  )+import Grisette.Internal.Core.Data.Class.SymFiniteBits+  ( SymFiniteBits (symFromBits, symSetBitTo, symTestBit),+    symBitBlast,+    symCountLeadingZeros,+    symCountTrailingZeros,+    symLsb,+    symMsb,+    symPopCount,+  )+import Grisette.TestUtil.SymbolicAssertion ((.@?=))+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Type.Reflection (Typeable, typeRep)++someBVSymFiniteBitsTest ::+  forall p bv.+  ( Typeable bv,+    BV bv,+    SymFiniteBits bv,+    Show bv,+    SymEq bv,+    Num bv,+    EvalSym bv+  ) =>+  p bv ->+  Test+someBVSymFiniteBitsTest _ =+  testGroup+    (show $ typeRep @bv)+    [ testCase "symTestBit" $ do+        let a = bv 4 0b0101 :: bv+        symTestBit a 0 .@?= true+        symTestBit a 1 .@?= false+        symTestBit a 2 .@?= true+        symTestBit a 3 .@?= false,+      testCase "symSetBitTo" $ do+        let a = bv 4 0b0101 :: bv+        symSetBitTo a 0 "b" .@?= symIte "b" (bv 4 0b0101) (bv 4 0b0100)+        symSetBitTo a 1 "b" .@?= symIte "b" (bv 4 0b0111) (bv 4 0b0101),+      testCase "symFromBits" $ do+        let actual = symFromBits ["a", "b", true, false] :: bv+        let expected =+              symIte+                "a"+                (symIte "b" (bv 4 0b0111) (bv 4 0b0101))+                (symIte "b" (bv 4 0b0110) (bv 4 0b0100))+        actual .@?= expected,+      testCase "symBitBlast" $ do+        symBitBlast (bv 4 0b0101 :: bv) .@?= [true, false, true, false],+      testCase "symLsb" $ do+        symLsb (bv 4 0b0101 :: bv) .@?= true+        symLsb (bv 4 0b0100 :: bv) .@?= false,+      testCase "symMsb" $ do+        symMsb (bv 4 0b0101 :: bv) .@?= false+        symMsb (bv 4 0b1101 :: bv) .@?= true,+      testCase "symPopCount" $ do+        symPopCount (bv 4 0 :: bv) .@?= 0+        symPopCount (bv 4 0b0101 :: bv) .@?= 2+        symPopCount (bv 4 0b1101 :: bv) .@?= 3+        symPopCount (bv 4 0b1111 :: bv) .@?= 4,+      testCase "symCountLeadingZeros" $ do+        symCountLeadingZeros (bv 4 0 :: bv) .@?= 4+        symCountLeadingZeros (bv 4 0b0101 :: bv) .@?= 1+        symCountLeadingZeros (bv 4 0b1101 :: bv) .@?= 0+        symCountLeadingZeros (bv 4 0b0011 :: bv) .@?= 2,+      testCase "symCountTrailingZeros" $ do+        symCountTrailingZeros (bv 4 0 :: bv) .@?= 4+        symCountTrailingZeros (bv 4 0b1010 :: bv) .@?= 1+        symCountTrailingZeros (bv 4 0b1011 :: bv) .@?= 0+        symCountTrailingZeros (bv 4 0b1100 :: bv) .@?= 2+    ]++bvSymFiniteBitsTest ::+  forall p bv.+  ( Num (bv 4),+    Typeable bv,+    SymFiniteBits (bv 4),+    Show (bv 4),+    SymEq (bv 4),+    EvalSym (bv 4)+  ) =>+  p bv ->+  Test+bvSymFiniteBitsTest _ =+  testGroup+    (show $ typeRep @bv)+    [ testCase "symTestBit" $ do+        let a = 5 :: bv 4+        symTestBit a 0 .@?= true+        symTestBit a 1 .@?= false+        symTestBit a 2 .@?= true+        symTestBit a 3 .@?= false,+      testCase "symSetBitTo" $ do+        let a = 5 :: bv 4+        symSetBitTo a 0 "b" .@?= symIte "b" 0b0101 0b0100+        symSetBitTo a 1 "b" .@?= symIte "b" 0b0111 0b0101,+      testCase "symFromBits" $ do+        let actual = symFromBits ["a", "b", true, false] :: bv 4+        let expected =+              symIte+                "a"+                (symIte "b" 0b0111 0b0101)+                (symIte "b" 0b0110 0b0100)+        actual .@?= expected,+      testCase "symBitBlast" $ do+        symBitBlast (0b0101 :: bv 4) .@?= [true, false, true, false],+      testCase "symLsb" $ do+        symLsb (0b0101 :: bv 4) .@?= true+        symLsb (0b0100 :: bv 4) .@?= false,+      testCase "symMsb" $ do+        symMsb (0b0101 :: bv 4) .@?= false+        symMsb (0b1101 :: bv 4) .@?= true,+      testCase "symPopCount" $ do+        symPopCount (0 :: bv 4) .@?= 0+        symPopCount (0b0101 :: bv 4) .@?= 2+        symPopCount (0b1101 :: bv 4) .@?= 3+        symPopCount (0b1111 :: bv 4) .@?= 4,+      testCase "symCountLeadingZeros" $ do+        symCountLeadingZeros (0 :: bv 4) .@?= 4+        symCountLeadingZeros (0b0101 :: bv 4) .@?= 1+        symCountLeadingZeros (0b1101 :: bv 4) .@?= 0+        symCountLeadingZeros (0b0011 :: bv 4) .@?= 2,+      testCase "symCountTrailingZeros" $ do+        symCountTrailingZeros (0 :: bv 4) .@?= 4+        symCountTrailingZeros (0b1010 :: bv 4) .@?= 1+        symCountTrailingZeros (0b1011 :: bv 4) .@?= 0+        symCountTrailingZeros (0b1100 :: bv 4) .@?= 2+    ]++symFiniteBitsTests :: Test+symFiniteBitsTests =+  testGroup+    "SymFiniteBits"+    [ testGroup+        "SymFiniteBits"+        [ someBVSymFiniteBitsTest (Proxy @SomeSymWordN),+          someBVSymFiniteBitsTest (Proxy @SomeSymIntN),+          bvSymFiniteBitsTest (Proxy @SymWordN),+          bvSymFiniteBitsTest (Proxy @SymIntN)+        ]+    ]
+ test/Grisette/Core/Data/Class/SymOrdTests.hs view
@@ -0,0 +1,1411 @@+{-# 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+  ( AsKey (AsKey),+    ITEOp (symIte),+    LogicalOp (symNot, (.&&), (.||)),+    Solvable (con),+    SymEq ((.==)),+    SymOrd (symCompare, (.<), (.<=), (.>), (.>=)),+    Union,+    mrgIf,+    mrgMax,+    mrgMin,+    mrgSingle,+    symMax,+    symMin,+  )+import Grisette.Core.Data.Class.TestValues+  ( conBool,+    ssymBool,+  )+import Grisette.Internal.Core.Data.Class.AsKey (AsKey1 (AsKey1))+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+  AsKey (i .<= j) @?= con (i <= j)+  AsKey (i .< j) @?= con (i < j)+  AsKey (i .>= j) @?= con (i >= j)+  AsKey (i .> j) @?= con (i > j)+  AsKey1 (symCompare i j) @?= (mrgReturn $ compare i j :: AsKey1 Union Ordering)++symbolicProdOrdOkProp ::+  (HasCallStack, 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]))+    ]
test/Grisette/Core/Data/Class/SymRotateTests.hs view
@@ -7,10 +7,16 @@ import Data.Data (Proxy (Proxy), Typeable, typeRep) import Data.Int (Int16, Int32, Int64, Int8) import Data.Word (Word16, Word32, Word64, Word8)-import Grisette (IntN, LinkedRep, Solvable, SymIntN, SymWordN)-import Grisette.Core.Data.BV (WordN)-import Grisette.Core.Data.Class.Solvable (Solvable (con))-import Grisette.Core.Data.Class.SymRotate (SymRotate (symRotate))+import Grisette+  ( AsKey (AsKey),+    IntN,+    Solvable (con),+    SymIntN,+    SymRotate (symRotate, symRotateNegated),+    SymWordN,+    WordN,+  )+import Grisette.Internal.Core.Data.Class.AsKey (KeyEq) import Test.Framework (Test, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.HUnit (Assertion, (@?=))@@ -29,12 +35,23 @@           (fromIntegral s :: Integer) `mod` fromIntegral (finiteBitSize a)       ) +concreteRotateNegatedIsCorrect ::+  (SymRotate a, Show a, Integral a, FiniteBits a) =>+  a ->+  a ->+  Assertion+concreteRotateNegatedIsCorrect a s =+  symRotateNegated a s+    @?= rotate+      a+      ( fromIntegral $+          (-fromIntegral s :: Integer) `mod` fromIntegral (finiteBitSize a)+      )+ concreteUnsignedTypeSymRotateTests ::   forall proxy a.   ( Arbitrary a,     Show a,-    Num a,-    Eq a,     SymRotate a,     FiniteBits a,     Bounded a,@@ -52,8 +69,14 @@             forAll (chooseInt (0, finiteBitSize x)) $               \(s :: Int) ->                 ioProperty $ concreteRotateIsCorrect x (fromIntegral s),+          testProperty "symRotateNegated" $ \(x :: a) ->+            forAll (chooseInt (0, finiteBitSize x)) $+              \(s :: Int) ->+                ioProperty $ concreteRotateNegatedIsCorrect x (fromIntegral s),           testProperty "symRotate max" $ \(x :: a) ->-            ioProperty $ concreteRotateIsCorrect x maxBound+            ioProperty $ concreteRotateIsCorrect x maxBound,+          testProperty "symRotateNegated max" $ \(x :: a) ->+            ioProperty $ concreteRotateNegatedIsCorrect x maxBound         ]     ] @@ -61,8 +84,6 @@   forall proxy a.   ( Arbitrary a,     Show a,-    Num a,-    Eq a,     SymRotate a,     FiniteBits a,     Bounded a,@@ -80,10 +101,18 @@             forAll (chooseInt (-finiteBitSize x, finiteBitSize x)) $               \(s :: Int) ->                 ioProperty $ concreteRotateIsCorrect x (fromIntegral s),+          testProperty "symRotateNegated" $ \(x :: a) ->+            forAll (chooseInt (-finiteBitSize x, finiteBitSize x)) $+              \(s :: Int) ->+                ioProperty $ concreteRotateNegatedIsCorrect x (fromIntegral s),           testProperty "symRotate max" $ \(x :: a) ->             ioProperty $ concreteRotateIsCorrect x maxBound,+          testProperty "symRotateNegated max" $ \(x :: a) ->+            ioProperty $ concreteRotateNegatedIsCorrect x maxBound,           testProperty "symRotate min" $ \(x :: a) ->-            ioProperty $ concreteRotateIsCorrect x minBound+            ioProperty $ concreteRotateIsCorrect x minBound,+          testProperty "symRotateNegated min" $ \(x :: a) ->+            ioProperty $ concreteRotateNegatedIsCorrect x minBound         ]     ] @@ -92,16 +121,15 @@   ( Arbitrary c,     Show s,     Num s,-    Eq s,     SymRotate c,     SymRotate s,     FiniteBits c,-    FiniteBits s,     Bounded c,     Typeable s,     Integral c,-    LinkedRep c s,-    Solvable c s+    Solvable c s,+    Show c,+    KeyEq s   ) =>   proxy s ->   Test@@ -114,15 +142,15 @@             forAll (chooseInt (-finiteBitSize x, finiteBitSize x)) $               \(s :: Int) ->                 ioProperty $-                  symRotate (con x :: s) (fromIntegral s)+                  AsKey (symRotate (con x :: s) (fromIntegral s))                     @?= con (symRotate x (fromIntegral s)),           testProperty "symRotate max" $ \(x :: c) ->             ioProperty $-              symRotate (con x :: s) (con maxBound)+              AsKey (symRotate (con x :: s) (con maxBound))                 @?= con (symRotate x maxBound),           testProperty "symRotate min" $ \(x :: c) ->             ioProperty $ do-              symRotate (con x :: s) (con minBound)+              AsKey (symRotate (con x :: s) (con minBound))                 @?= con (symRotate x minBound)         ]     ]@@ -138,6 +166,7 @@       concreteUnsignedTypeSymRotateTests (Proxy :: Proxy Word),       concreteUnsignedTypeSymRotateTests (Proxy :: Proxy (WordN 1)),       concreteUnsignedTypeSymRotateTests (Proxy :: Proxy (WordN 2)),+      concreteUnsignedTypeSymRotateTests (Proxy :: Proxy (WordN 3)),       concreteUnsignedTypeSymRotateTests (Proxy :: Proxy (WordN 63)),       concreteUnsignedTypeSymRotateTests (Proxy :: Proxy (WordN 64)),       concreteUnsignedTypeSymRotateTests (Proxy :: Proxy (WordN 65)),@@ -149,18 +178,21 @@       concreteSignedTypeSymRotateTests (Proxy :: Proxy Int),       concreteSignedTypeSymRotateTests (Proxy :: Proxy (IntN 1)),       concreteSignedTypeSymRotateTests (Proxy :: Proxy (IntN 2)),+      concreteSignedTypeSymRotateTests (Proxy :: Proxy (IntN 3)),       concreteSignedTypeSymRotateTests (Proxy :: Proxy (IntN 63)),       concreteSignedTypeSymRotateTests (Proxy :: Proxy (IntN 64)),       concreteSignedTypeSymRotateTests (Proxy :: Proxy (IntN 65)),       concreteSignedTypeSymRotateTests (Proxy :: Proxy (IntN 128)),       symbolicTypeSymRotateTests (Proxy :: Proxy (SymWordN 1)),       symbolicTypeSymRotateTests (Proxy :: Proxy (SymWordN 2)),+      symbolicTypeSymRotateTests (Proxy :: Proxy (SymWordN 3)),       symbolicTypeSymRotateTests (Proxy :: Proxy (SymWordN 63)),       symbolicTypeSymRotateTests (Proxy :: Proxy (SymWordN 64)),       symbolicTypeSymRotateTests (Proxy :: Proxy (SymWordN 65)),       symbolicTypeSymRotateTests (Proxy :: Proxy (SymWordN 128)),       symbolicTypeSymRotateTests (Proxy :: Proxy (SymIntN 1)),       symbolicTypeSymRotateTests (Proxy :: Proxy (SymIntN 2)),+      symbolicTypeSymRotateTests (Proxy :: Proxy (SymIntN 3)),       symbolicTypeSymRotateTests (Proxy :: Proxy (SymIntN 63)),       symbolicTypeSymRotateTests (Proxy :: Proxy (SymIntN 64)),       symbolicTypeSymRotateTests (Proxy :: Proxy (SymIntN 65)),
test/Grisette/Core/Data/Class/SymShiftTests.hs view
@@ -7,10 +7,16 @@ import Data.Data (Proxy (Proxy), Typeable, typeRep) import Data.Int (Int16, Int32, Int64, Int8) import Data.Word (Word16, Word32, Word64, Word8)-import Grisette (IntN, LinkedRep, Solvable, SymIntN, SymWordN)-import Grisette.Core.Data.BV (WordN)-import Grisette.Core.Data.Class.Solvable (Solvable (con))-import Grisette.Core.Data.Class.SymShift (SymShift (symShift))+import Grisette+  ( AsKey (AsKey),+    IntN,+    Solvable (con),+    SymIntN,+    SymShift (symShift, symShiftNegated),+    SymWordN,+    WordN,+  )+import Grisette.Internal.Core.Data.Class.AsKey (KeyEq) import Test.Framework (Test, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.HUnit ((@?=))@@ -21,12 +27,10 @@   ( Arbitrary a,     Show a,     Num a,-    Eq a,     SymShift a,     FiniteBits a,     Bounded a,-    Typeable a,-    Integral a+    Typeable a   ) =>   proxy a ->   Test@@ -40,8 +44,15 @@               \(s :: Int) ->                 ioProperty $                   symShift x (fromIntegral s) @?= shift x s,+          testProperty "symShiftNegated" $ \(x :: a) ->+            forAll (chooseInt (0, finiteBitSize x)) $+              \(s :: Int) ->+                ioProperty $+                  symShiftNegated x (fromIntegral s) @?= shift x (-s),           testProperty "symShift max" $ \(x :: a) ->-            ioProperty $ symShift x maxBound @?= 0+            ioProperty $ symShift x maxBound @?= 0,+          testProperty "symShiftNegated max" $ \(x :: a) ->+            ioProperty $ symShiftNegated x maxBound @?= 0         ]     ] @@ -49,8 +60,6 @@   forall proxy a.   ( Arbitrary a,     Show a,-    Num a,-    Eq a,     SymShift a,     FiniteBits a,     Bounded a,@@ -69,21 +78,31 @@               \(s :: Int) -> ioProperty $ do                 symShift x (fromIntegral s)                   @?= shift x (fromIntegral (fromIntegral s :: a)),+          testProperty "symShiftNegated" $ \(x :: a) ->+            forAll (chooseInt (-finiteBitSize x, finiteBitSize x)) $+              \(s :: Int) -> ioProperty $ do+                symShiftNegated x (fromIntegral s)+                  @?= shift x (-fromIntegral (fromIntegral s :: a)),           testProperty "symShift max" $ \(x :: a) ->             ioProperty $ do               case finiteBitSize x of                 1 -> symShift x maxBound @?= x                 2 -> symShift x maxBound @?= shift x 1                 _ -> symShift x maxBound @?= 0,+          testProperty "symShiftNegated max" $ \(x :: a) ->+            ioProperty $ do+              case finiteBitSize x of+                1 -> symShiftNegated x maxBound @?= x+                2 -> symShiftNegated x maxBound @?= shift x (-1)+                _ -> symShiftNegated x maxBound @?= if x >= 0 then 0 else -1,           testProperty "symShift min" $ \(x :: a) ->             ioProperty $ do               case finiteBitSize x of-                1 ->-                  symShift x minBound @?= shift x (-1)-                2 ->-                  symShift x minBound @?= shift x (-2)-                _ ->-                  symShift x minBound @?= if x >= 0 then 0 else -1+                1 -> symShift x minBound @?= shift x (-1)+                2 -> symShift x minBound @?= shift x (-2)+                _ -> symShift x minBound @?= if x >= 0 then 0 else -1,+          testProperty "symShiftNegated min" $ \(x :: a) ->+            ioProperty $ symShiftNegated x minBound @?= 0         ]     ] @@ -92,16 +111,15 @@   ( Arbitrary c,     Show s,     Num s,-    Eq s,     SymShift c,     SymShift s,     FiniteBits c,-    FiniteBits s,     Bounded c,     Typeable s,     Integral c,-    LinkedRep c s,-    Solvable c s+    Solvable c s,+    Show c,+    KeyEq s   ) =>   proxy s ->   Test@@ -114,16 +132,30 @@             forAll (chooseInt (-finiteBitSize x, finiteBitSize x)) $               \(s :: Int) ->                 ioProperty $-                  symShift (con x :: s) (fromIntegral s)+                  AsKey (symShift (con x :: s) (fromIntegral s))                     @?= con (symShift x (fromIntegral s)),+          testProperty "concrete/concrete symShiftNegated" $ \(x :: c) ->+            forAll (chooseInt (-finiteBitSize x, finiteBitSize x)) $+              \(s :: Int) ->+                ioProperty $+                  AsKey (symShiftNegated (con x :: s) (fromIntegral s))+                    @?= con (symShiftNegated x (fromIntegral s)),           testProperty "symShift max" $ \(x :: c) ->             ioProperty $-              symShift (con x :: s) (con maxBound)+              AsKey (symShift (con x :: s) (con maxBound))                 @?= con (symShift x maxBound),+          testProperty "symShiftNegated max" $ \(x :: c) ->+            ioProperty $+              AsKey (symShiftNegated (con x :: s) (con maxBound))+                @?= con (symShiftNegated x maxBound),           testProperty "symShift min" $ \(x :: c) ->             ioProperty $ do-              symShift (con x :: s) (con minBound)-                @?= con (symShift x minBound)+              AsKey (symShift (con x :: s) (con minBound))+                @?= con (symShift x minBound),+          testProperty "symShiftNegated min" $ \(x :: c) ->+            ioProperty $ do+              AsKey (symShiftNegated (con x :: s) (con minBound))+                @?= con (symShiftNegated x minBound)         ]     ] @@ -138,6 +170,7 @@       concreteUnsignedTypeSymShiftTests (Proxy :: Proxy Word),       concreteUnsignedTypeSymShiftTests (Proxy :: Proxy (WordN 1)),       concreteUnsignedTypeSymShiftTests (Proxy :: Proxy (WordN 2)),+      concreteUnsignedTypeSymShiftTests (Proxy :: Proxy (WordN 3)),       concreteUnsignedTypeSymShiftTests (Proxy :: Proxy (WordN 63)),       concreteUnsignedTypeSymShiftTests (Proxy :: Proxy (WordN 64)),       concreteUnsignedTypeSymShiftTests (Proxy :: Proxy (WordN 65)),@@ -149,18 +182,21 @@       concreteSignedTypeSymShiftTests (Proxy :: Proxy Int),       concreteSignedTypeSymShiftTests (Proxy :: Proxy (IntN 1)),       concreteSignedTypeSymShiftTests (Proxy :: Proxy (IntN 2)),+      concreteSignedTypeSymShiftTests (Proxy :: Proxy (IntN 3)),       concreteSignedTypeSymShiftTests (Proxy :: Proxy (IntN 63)),       concreteSignedTypeSymShiftTests (Proxy :: Proxy (IntN 64)),       concreteSignedTypeSymShiftTests (Proxy :: Proxy (IntN 65)),       concreteSignedTypeSymShiftTests (Proxy :: Proxy (IntN 128)),       symbolicTypeSymShiftTests (Proxy :: Proxy (SymWordN 1)),       symbolicTypeSymShiftTests (Proxy :: Proxy (SymWordN 2)),+      symbolicTypeSymShiftTests (Proxy :: Proxy (SymWordN 3)),       symbolicTypeSymShiftTests (Proxy :: Proxy (SymWordN 63)),       symbolicTypeSymShiftTests (Proxy :: Proxy (SymWordN 64)),       symbolicTypeSymShiftTests (Proxy :: Proxy (SymWordN 65)),       symbolicTypeSymShiftTests (Proxy :: Proxy (SymWordN 128)),       symbolicTypeSymShiftTests (Proxy :: Proxy (SymIntN 1)),       symbolicTypeSymShiftTests (Proxy :: Proxy (SymIntN 2)),+      symbolicTypeSymShiftTests (Proxy :: Proxy (SymIntN 3)),       symbolicTypeSymShiftTests (Proxy :: Proxy (SymIntN 63)),       symbolicTypeSymShiftTests (Proxy :: Proxy (SymIntN 64)),       symbolicTypeSymShiftTests (Proxy :: Proxy (SymIntN 65)),
test/Grisette/Core/Data/Class/TestValues.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE DataKinds #-}+ module Grisette.Core.Data.Class.TestValues   ( conBool,     symTrue,@@ -9,13 +11,14 @@   ) where -import qualified Data.Text as T import Grisette-  ( Solvable (isym),-    TypedSymbol (IndexedSymbol, SimpleSymbol),+  ( Identifier,+    Solvable (con, isym, ssym),+    SymBool,+    Symbol (IndexedSymbol, SimpleSymbol),+    TypedAnySymbol,+    typedAnySymbol,   )-import Grisette.Core.Data.Class.Solvable (Solvable (con, ssym))-import Grisette.IR.SymPrim.Data.SymPrim (SymBool)  conBool :: Bool -> SymBool conBool = con@@ -26,14 +29,14 @@ symFalse :: SymBool symFalse = conBool False -ssymBool :: T.Text -> SymBool+ssymBool :: Identifier -> SymBool ssymBool = ssym -isymBool :: T.Text -> Int -> SymBool+isymBool :: Identifier -> Int -> SymBool isymBool = isym -ssymbolBool :: T.Text -> TypedSymbol Bool-ssymbolBool = SimpleSymbol+ssymbolBool :: Identifier -> TypedAnySymbol Bool+ssymbolBool = typedAnySymbol . SimpleSymbol -isymbolBool :: T.Text -> Int -> TypedSymbol Bool-isymbolBool = IndexedSymbol+isymbolBool :: Identifier -> Int -> TypedAnySymbol Bool+isymbolBool i idx = typedAnySymbol $ IndexedSymbol i idx
test/Grisette/Core/Data/Class/ToConTests.hs view
@@ -18,9 +18,13 @@ import Data.Int (Int16, Int32, Int64, Int8) import Data.Word (Word16, Word32, Word64, Word8) import GHC.Stack (HasCallStack)-import Grisette.Core.Data.Class.ITEOp (ITEOp (symIte))-import Grisette.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.&&), (.||)))-import Grisette.Core.Data.Class.SEq (SEq ((.==)))+import Grisette+  ( ITEOp (symIte),+    LogicalOp (symNot, (.&&), (.||)),+    SymBool,+    SymEq ((.==)),+    ToCon (toCon),+  ) import Grisette.Core.Data.Class.TestValues   ( conBool,     isymBool,@@ -28,16 +32,14 @@     symFalse,     symTrue,   )-import Grisette.Core.Data.Class.ToCon (ToCon (toCon))-import Grisette.IR.SymPrim.Data.SymPrim (SymBool)+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) -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@@ -76,7 +78,7 @@                         ssymBool "a" .== ssymBool "b",                         symIte (ssymBool "a") (ssymBool "b") (ssymBool "c")                       ]-                traverse_ (\v -> toCon v @?= Just v) sbools+                traverse_ (\v -> toCon v .@?= Just v) sbools             ],           testProperty "Bool" $ ioProperty . toConForConcreteOkProp @Bool,           testProperty "Integer" $ ioProperty . toConForConcreteOkProp @Integer,
test/Grisette/Core/Data/Class/ToSymTests.hs view
@@ -21,20 +21,22 @@ import Data.Int (Int16, Int32, Int64, Int8) import Data.Word (Word16, Word32, Word64, Word8) import GHC.Stack (HasCallStack)-import Grisette.Core.Data.Class.ITEOp (ITEOp (symIte))-import Grisette.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.&&), (.||)))-import Grisette.Core.Data.Class.SEq (SEq ((.==)))-import Grisette.Core.Data.Class.Solvable (Solvable (con, isym, ssym))-import Grisette.Core.Data.Class.ToSym (ToSym (toSym))-import Grisette.IR.SymPrim.Data.SymPrim (SymBool)+import Grisette+  ( ITEOp (symIte),+    LogicalOp (symNot, (.&&), (.||)),+    Solvable (con, isym, ssym),+    SymBool,+    SymEq ((.==)),+    ToSym (toSym),+  )+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) -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@@ -47,7 +49,7 @@             "SymBool"             [ testCase "From Bool" $ do                 let bools = [True, False]-                traverse_ (\v -> toSym v @?= (con v :: SymBool)) bools,+                traverse_ (\v -> toSym v .@?= (con v :: SymBool)) bools,               testCase "From SymBool" $ do                 let sbools :: [SymBool] =                       [ con True,@@ -59,7 +61,7 @@                         (ssym "a" :: SymBool) .== ssym "b",                         symIte (ssym "a") (ssym "b") (ssym "c")                       ]-                traverse_ (\v -> toSym v @?= v) sbools+                traverse_ (\v -> toSym v .@?= v) sbools             ],           testProperty "Bool" $ ioProperty . toSymForConcreteOkProp @Bool,           testProperty "Integer" $ ioProperty . toSymForConcreteOkProp @Integer,@@ -84,9 +86,9 @@                 ioProperty                   . toSymForConcreteOkProp @[Integer],               testCase "[SymBool]" $ do-                toSym ([] :: [Bool]) @?= ([] :: [SymBool])+                toSym ([] :: [Bool]) .@?= ([] :: [SymBool])                 toSym ([True, False] :: [Bool])-                  @?= ([con True, con False] :: [SymBool])+                  .@?= ([con True, con False] :: [SymBool])             ],           testGroup             "Maybe"@@ -94,9 +96,9 @@                 ioProperty                   . toSymForConcreteOkProp @(Maybe Integer),               testCase "Maybe SymBool" $ do-                toSym (Nothing :: Maybe Bool) @?= (Nothing :: Maybe SymBool)+                toSym (Nothing :: Maybe Bool) .@?= (Nothing :: Maybe SymBool)                 toSym (Just True :: Maybe Bool)-                  @?= (Just $ con True :: Maybe SymBool)+                  .@?= (Just $ con True :: Maybe SymBool)             ],           testGroup             "Either"@@ -104,9 +106,9 @@                 ioProperty . toSymForConcreteOkProp @(Either Integer Integer),               testCase "Eithe SymBool SymBool" $ do                 toSym (Left True :: Either Bool Bool)-                  @?= (Left $ con True :: Either SymBool SymBool)+                  .@?= (Left $ con True :: Either SymBool SymBool)                 toSym (Right True :: Either Bool Bool)-                  @?= (Right $ con True :: Either SymBool SymBool)+                  .@?= (Right $ con True :: Either SymBool SymBool)             ],           testGroup             "MaybeT"@@ -115,11 +117,11 @@                   toSymForConcreteOkProp $ MaybeT v,               testCase "MaybeT Maybe SymBool" $ do                 toSym (MaybeT Nothing :: MaybeT Maybe Bool)-                  @?= (MaybeT Nothing :: MaybeT Maybe SymBool)+                  .@?= (MaybeT Nothing :: MaybeT Maybe SymBool)                 toSym (MaybeT $ Just Nothing :: MaybeT Maybe Bool)-                  @?= (MaybeT $ Just Nothing :: MaybeT Maybe SymBool)+                  .@?= (MaybeT $ Just Nothing :: MaybeT Maybe SymBool)                 toSym (MaybeT $ Just $ Just True :: MaybeT Maybe Bool)-                  @?= (MaybeT $ Just $ Just $ con True :: MaybeT Maybe SymBool)+                  .@?= (MaybeT $ Just $ Just $ con True :: MaybeT Maybe SymBool)             ],           testGroup             "ExceptT"@@ -128,15 +130,15 @@                   toSymForConcreteOkProp $ ExceptT v,               testCase "ExceptT SymBool Maybe SymBool" $ do                 toSym (ExceptT Nothing :: ExceptT Bool Maybe Bool)-                  @?= (ExceptT Nothing :: ExceptT SymBool Maybe SymBool)+                  .@?= (ExceptT Nothing :: ExceptT SymBool Maybe SymBool)                 toSym (ExceptT $ Just $ Left True :: ExceptT Bool Maybe Bool)-                  @?= ( ExceptT $ Just $ Left $ con True ::-                          ExceptT SymBool Maybe SymBool-                      )+                  .@?= ( ExceptT $ Just $ Left $ con True ::+                           ExceptT SymBool Maybe SymBool+                       )                 toSym (ExceptT $ Just $ Right False :: ExceptT Bool Maybe Bool)-                  @?= ( ExceptT $ Just $ Right $ con False ::-                          ExceptT SymBool Maybe SymBool-                      )+                  .@?= ( ExceptT $ Just $ Right $ con False ::+                           ExceptT SymBool Maybe SymBool+                       )             ],           testGroup             "(,)"@@ -144,7 +146,7 @@                 ioProperty . toSymForConcreteOkProp @(Integer, Integer),               testCase "(SymBool, SymBool)" $                 toSym (True, False)-                  @?= (con True :: SymBool, con False :: SymBool)+                  .@?= (con True :: SymBool, con False :: SymBool)             ],           testGroup             "(,,)"@@ -154,10 +156,10 @@                     @(Integer, Integer, Integer),               testCase "(SymBool, SymBool, SymBool)" $                 toSym (True, False, True)-                  @?= ( con True :: SymBool,-                        con False :: SymBool,-                        con True :: SymBool-                      )+                  .@?= ( con True :: SymBool,+                         con False :: SymBool,+                         con True :: SymBool+                       )             ],           testGroup             "(,,,)"@@ -167,11 +169,11 @@                     @(Integer, Integer, Integer, Integer),               testCase "(SymBool, SymBool, SymBool, SymBool)" $                 toSym (True, False, True, False)-                  @?= ( con True :: SymBool,-                        con False :: SymBool,-                        con True :: SymBool,-                        con False :: SymBool-                      )+                  .@?= ( con True :: SymBool,+                         con False :: SymBool,+                         con True :: SymBool,+                         con False :: SymBool+                       )             ],           testGroup             "(,,,,)"@@ -181,12 +183,12 @@                     @(Integer, Integer, Integer, Integer, Integer),               testCase "(SymBool, SymBool, SymBool, SymBool, SymBool)" $                 toSym (True, False, True, False, True)-                  @?= ( con True :: SymBool,-                        con False :: SymBool,-                        con True :: SymBool,-                        con False :: SymBool,-                        con True :: SymBool-                      )+                  .@?= ( con True :: SymBool,+                         con False :: SymBool,+                         con True :: SymBool,+                         con False :: SymBool,+                         con True :: SymBool+                       )             ],           testGroup             "(,,,,,)"@@ -198,13 +200,13 @@               testCase                 "(SymBool, SymBool, SymBool, SymBool, SymBool, SymBool)"                 $ toSym (True, False, True, False, True, False)-                  @?= ( con True :: SymBool,-                        con False :: SymBool,-                        con True :: SymBool,-                        con False :: SymBool,-                        con True :: SymBool,-                        con False :: SymBool-                      )+                  .@?= ( con True :: SymBool,+                         con False :: SymBool,+                         con True :: SymBool,+                         con False :: SymBool,+                         con True :: SymBool,+                         con False :: SymBool+                       )             ],           testGroup             "(,,,,,,)"@@ -222,14 +224,14 @@                      ),               testCase "(SymBool, SymBool, SymBool, SymBool, SymBool, SymBool, SymBool)" $                 toSym (True, False, True, False, True, False, True)-                  @?= ( con True :: SymBool,-                        con False :: SymBool,-                        con True :: SymBool,-                        con False :: SymBool,-                        con True :: SymBool,-                        con False :: SymBool,-                        con True :: SymBool-                      )+                  .@?= ( con True :: SymBool,+                         con False :: SymBool,+                         con True :: SymBool,+                         con False :: SymBool,+                         con True :: SymBool,+                         con False :: SymBool,+                         con True :: SymBool+                       )             ],           testGroup             "(,,,,,,,)"@@ -249,15 +251,15 @@               testCase                 "(SymBool, SymBool, SymBool, SymBool, SymBool, SymBool, SymBool, SymBool)"                 $ toSym (True, False, True, False, True, False, True, False)-                  @?= ( con True :: SymBool,-                        con False :: SymBool,-                        con True :: SymBool,-                        con False :: SymBool,-                        con True :: SymBool,-                        con False :: SymBool,-                        con True :: SymBool,-                        con False :: SymBool-                      )+                  .@?= ( con True :: SymBool,+                         con False :: SymBool,+                         con True :: SymBool,+                         con False :: SymBool,+                         con True :: SymBool,+                         con False :: SymBool,+                         con True :: SymBool,+                         con False :: SymBool+                       )             ],           testGroup             "Sum"@@ -275,17 +277,17 @@                           (InR v),               testCase "Sum Maybe (Either SymBool) SymBool" $ do                 toSym (InL $ Just True :: Sum Maybe (Either Bool) Bool)-                  @?= ( InL $ Just $ con True ::-                          Sum Maybe (Either SymBool) SymBool-                      )+                  .@?= ( InL $ Just $ con True ::+                           Sum Maybe (Either SymBool) SymBool+                       )                 toSym (InR $ Left True :: Sum Maybe (Either Bool) Bool)-                  @?= ( InR $ Left $ con True ::-                          Sum Maybe (Either SymBool) SymBool-                      )+                  .@?= ( InR $ Left $ con True ::+                           Sum Maybe (Either SymBool) SymBool+                       )                 toSym (InR $ Right False :: Sum Maybe (Either Bool) Bool)-                  @?= ( InR $ Right $ con False ::-                          Sum Maybe (Either SymBool) SymBool-                      )+                  .@?= ( InR $ Right $ con False ::+                           Sum Maybe (Either SymBool) SymBool+                       )             ],           testProperty "functions" $             ioProperty@@ -296,7 +298,7 @@                       func ((fk, fv) : _) xv | fk == xv = fv                       func (_ : fs) xv = func fs xv                    in (toSym (func f x) :: Either SymBool SymBool)-                        @?= toSym (func f) x,+                        .@?= toSym (func f) x,           testGroup             "StateT"             [ testProperty "Lazy" $@@ -312,7 +314,7 @@                        in ( StateLazy.runStateT (toSym st) x ::                               Either SymBool (SymBool, Bool)                           )-                            @?= toSym (func f) x,+                            .@?= toSym (func f) x,               testProperty "Strict" $                 ioProperty                   . \( f :: [(Bool, Either Bool (Bool, Bool))],@@ -326,7 +328,7 @@                        in ( StateStrict.runStateT (toSym st) x ::                               Either SymBool (SymBool, Bool)                           )-                            @?= toSym (func f) x+                            .@?= toSym (func f) x             ],           testGroup             "WriterT"@@ -337,7 +339,7 @@                    in ( WriterLazy.runWriterT (toSym w) ::                           Either SymBool (SymBool, Integer)                       )-                        @?= toSym f,+                        .@?= toSym f,               testProperty "Strict" $                 ioProperty . \(f :: Either Bool (Bool, Integer)) ->                   let w :: WriterStrict.WriterT Integer (Either Bool) Bool =@@ -345,7 +347,7 @@                    in ( WriterStrict.runWriterT (toSym w) ::                           Either SymBool (SymBool, Integer)                       )-                        @?= toSym f+                        .@?= toSym f             ],           testProperty "ReaderT" $             ioProperty . \(f :: [(Bool, Either Bool Bool)], x :: Bool) ->@@ -354,7 +356,7 @@                   func (_ : fs) xv = func fs xv                   st :: ReaderT Bool (Either Bool) Bool = ReaderT (func f)                in (runReaderT (toSym st) x :: Either SymBool SymBool)-                    @?= toSym (func f) x,+                    .@?= toSym (func f) x,           testGroup             "Identity"             [ testProperty "Identity Integer" $@@ -362,7 +364,7 @@                   . toSymForConcreteOkProp @(Identity Integer),               testCase "Identity SymBool" $ do                 toSym (Identity True :: Identity Bool)-                  @?= (Identity $ con True :: Identity SymBool)+                  .@?= (Identity $ con True :: Identity SymBool)             ],           testGroup             "IdentityT"@@ -372,9 +374,9 @@                     (IdentityT x),               testCase "IdentityT Maybe SymBool" $ do                 toSym (IdentityT (Just True) :: IdentityT Maybe Bool)-                  @?= (IdentityT $ Just $ con True :: IdentityT Maybe SymBool)+                  .@?= (IdentityT $ Just $ con True :: IdentityT Maybe SymBool)                 toSym (IdentityT Nothing :: IdentityT Maybe Bool)-                  @?= (IdentityT Nothing :: IdentityT Maybe SymBool)+                  .@?= (IdentityT Nothing :: IdentityT Maybe SymBool)             ]         ]     ]
+ test/Grisette/Core/Data/Class/TryMergeTests.hs view
@@ -0,0 +1,171 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TupleSections #-}++module Grisette.Core.Data.Class.TryMergeTests (tryMergeTests) where++import Control.Monad.Cont (ContT (ContT, runContT))+import Control.Monad.Except (ExceptT (ExceptT))+import Control.Monad.Identity (IdentityT (IdentityT))+import qualified Control.Monad.RWS.Lazy as RWSTLazy+import qualified Control.Monad.RWS.Strict as RWSTStrict+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))+import qualified Control.Monad.Writer.Lazy as WriterLazy+import qualified Control.Monad.Writer.Strict as WriterStrict+import Grisette+  ( AsKey1 (AsKey1),+    EvalSym,+    ITEOp (symIte),+    Mergeable (rootStrategy),+    SymBranching (mrgIfPropagatedStrategy),+    SymEq,+    TryMerge,+    mrgSingle,+    tryMerge,+  )+import Grisette.Internal.Core.Control.Monad.Union (Union (Union))+import Grisette.Internal.Core.Data.UnionBase (UnionBase (UnionSingle))+import Grisette.Internal.SymPrim.SymInteger (SymInteger)+import Grisette.TestUtil.SymbolicAssertion ((.@?=))+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit (testCase)++data TryMergeInstanceTest where+  TryMergeInstanceTest ::+    forall u a.+    (TryMerge u, Mergeable a, Show (u a), Eq (u a), SymEq (u a), EvalSym (u a)) =>+    { testName :: String,+      testUnmerged :: u a,+      testMerged :: u a+    } ->+    TryMergeInstanceTest++unmergedUnion :: Union SymInteger+unmergedUnion =+  mrgIfPropagatedStrategy+    "a"+    (return "b")+    (return "c")++tryMergeTests :: Test+tryMergeTests =+  testGroup+    "TryMerge"+    [ testCase "mrgSingle" $ do+        let actual = mrgSingle 1 :: AsKey1 Union Integer+        actual .@?= AsKey1 (Union (Just rootStrategy) (UnionSingle 1)),+      testCase "mrgSingle" $ do+        let actual = mrgSingle 1 :: AsKey1 Union Integer+        actual .@?= AsKey1 (Union (Just rootStrategy) (UnionSingle 1)),+      testCase "tryMerge" $ do+        let actual = tryMerge $ return 1 :: AsKey1 Union Integer+        actual .@?= AsKey1 (Union (Just rootStrategy) (UnionSingle 1)),+      testGroup "Instances" $ do+        test <-+          [ TryMergeInstanceTest+              { testName = "MaybeT",+                testUnmerged = MaybeT $ Just <$> unmergedUnion,+                testMerged = MaybeT (mrgSingle $ Just $ symIte "a" "b" "c")+              },+            TryMergeInstanceTest+              { testName = "ExceptT",+                testUnmerged =+                  ExceptT $ Right <$> unmergedUnion ::+                    ExceptT SymInteger Union SymInteger,+                testMerged = ExceptT (mrgSingle $ Right $ symIte "a" "b" "c")+              },+            TryMergeInstanceTest+              { testName = "ReaderT",+                testUnmerged =+                  runReaderT (ReaderT $ \r -> (r +) <$> unmergedUnion) "x",+                testMerged = mrgSingle (symIte "a" ("x" + "b") ("x" + "c"))+              },+            TryMergeInstanceTest+              { testName = "Lazy StateT",+                testUnmerged =+                  StateLazy.runStateT+                    (StateLazy.StateT $ \s -> (,s) <$> unmergedUnion)+                    "x" ::+                    Union (SymInteger, SymInteger),+                testMerged = mrgSingle (symIte "a" "b" "c", "x")+              },+            TryMergeInstanceTest+              { testName = "Strict StateT",+                testUnmerged =+                  StateStrict.runStateT+                    (StateStrict.StateT $ \s -> (,s) <$> unmergedUnion)+                    "x" ::+                    Union (SymInteger, SymInteger),+                testMerged = mrgSingle (symIte "a" "b" "c", "x")+              },+            TryMergeInstanceTest+              { testName = "Lazy WriterT",+                testUnmerged =+                  WriterLazy.runWriterT+                    ( WriterLazy.WriterT $+                        (\x -> (x, x + 1)) <$> unmergedUnion+                    ) ::+                    Union (SymInteger, SymInteger),+                testMerged =+                  mrgSingle (symIte "a" "b" "c", symIte "a" ("b" + 1) ("c" + 1))+              },+            TryMergeInstanceTest+              { testName = "Strict WriterT",+                testUnmerged =+                  WriterStrict.runWriterT+                    ( WriterStrict.WriterT $+                        (\x -> (x, x + 1)) <$> unmergedUnion+                    ) ::+                    Union (SymInteger, SymInteger),+                testMerged =+                  mrgSingle (symIte "a" "b" "c", symIte "a" ("b" + 1) ("c" + 1))+              },+            TryMergeInstanceTest+              { testName = "Lazy RWST",+                testUnmerged =+                  RWSTLazy.runRWST+                    ( RWSTLazy.RWST $+                        \r s -> (,s,r) <$> unmergedUnion+                    )+                    "r"+                    "s" ::+                    Union (SymInteger, SymInteger, SymInteger),+                testMerged = mrgSingle (symIte "a" "b" "c", "s", "r")+              },+            TryMergeInstanceTest+              { testName = "Strict RWST",+                testUnmerged =+                  RWSTStrict.runRWST+                    ( RWSTStrict.RWST $+                        \r s -> (,s,r) <$> unmergedUnion+                    )+                    "r"+                    "s" ::+                    Union (SymInteger, SymInteger, SymInteger),+                testMerged = mrgSingle (symIte "a" "b" "c", "s", "r")+              },+            TryMergeInstanceTest+              { testName = "IdentityT",+                testUnmerged = IdentityT unmergedUnion,+                testMerged = IdentityT $ mrgSingle $ symIte "a" "b" "c"+              },+            TryMergeInstanceTest+              { testName = "ContT",+                testUnmerged =+                  runContT+                    (ContT $ \c -> unmergedUnion >>= c)+                    (\x -> mrgSingle $ x + 1),+                testMerged = mrgSingle $ symIte "a" ("b" + 1) ("c" + 1)+              }+          ]+        case test of+          TryMergeInstanceTest name unmerged merged ->+            [ testCase name $ do+                let actual = tryMerge unmerged+                actual .@?= merged+            ]+    ]
− test/Grisette/Core/Data/Class/UnionLikeTests.hs 
@@ -1,298 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Grisette.Core.Data.Class.UnionLikeTests (unionLikeTests) where--import Control.Monad.Except (ExceptT (ExceptT))-import Control.Monad.Identity (IdentityT (IdentityT, runIdentityT))-import Control.Monad.Reader (ReaderT (ReaderT, runReaderT))-import Control.Monad.Trans.Maybe (MaybeT (MaybeT))-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 Grisette.Core.Control.Monad.UnionM (UnionM)-import Grisette.Core.Data.Class.ITEOp (ITEOp (symIte))-import Grisette.Core.Data.Class.LogicalOp (LogicalOp (symNot))-import Grisette.Core.Data.Class.SimpleMergeable-  ( UnionLike (single, unionIf),-    merge,-    mrgIf,-    mrgSingle,-    simpleMerge,-  )-import Grisette.Core.Data.Class.Solvable (Solvable (ssym))-import Grisette.IR.SymPrim.Data.SymPrim (SymBool)-import Test.Framework (Test, testGroup)-import Test.Framework.Providers.HUnit (testCase)-import Test.HUnit ((@?=))--unionLikeTests :: Test-unionLikeTests =-  testGroup-    "UnionLike"-    [ testCase "simpleMerge" $-        simpleMerge-          ( unionIf-              (ssym "a")-              (single $ ssym "b")-              (single $ ssym "c") ::-              UnionM SymBool-          )-          @?= symIte (ssym "a") (ssym "b") (ssym "c"),-      testGroup-        "UnionLike"-        [ testGroup-            "MaybeT"-            [ testCase "merge" $ do-                merge-                  ( MaybeT-                      ( unionIf-                          (ssym "a")-                          (single $ Just $ ssym "b")-                          (single $ Just $ ssym "c") ::-                          UnionM (Maybe SymBool)-                      )-                  )-                  @?= MaybeT-                    (mrgSingle $ Just $ symIte (ssym "a") (ssym "b") (ssym "c")),-              testCase "mrgSingle" $ do-                (mrgSingle 1 :: MaybeT UnionM Integer)-                  @?= MaybeT (mrgSingle $ Just 1),-              testCase "mrgIf" $-                do-                  mrgIf (ssym "a") (mrgSingle $ ssym "b") (mrgSingle $ ssym "c")-                  @?= MaybeT-                    ( mrgSingle $-                        Just $-                          symIte (ssym "a") (ssym "b") (ssym "c") ::-                        UnionM (Maybe SymBool)-                    )-            ],-          testGroup-            "ExceptT"-            [ testCase "merge" $ do-                merge-                  ( ExceptT-                      ( unionIf-                          (ssym "a")-                          (single $ Left $ ssym "b")-                          (single $ Left $ ssym "c") ::-                          UnionM (Either SymBool SymBool)-                      )-                  )-                  @?= ExceptT-                    (mrgSingle $ Left $ symIte (ssym "a") (ssym "b") (ssym "c")),-              testCase "mrgSingle" $ do-                (mrgSingle 1 :: ExceptT SymBool UnionM Integer)-                  @?= ExceptT (mrgSingle $ Right 1),-              testCase "mrgIf" $-                do-                  mrgIf (ssym "a") (mrgSingle $ ssym "b") (mrgSingle $ ssym "c")-                  @?= ExceptT-                    ( mrgSingle $-                        Right $-                          symIte (ssym "a") (ssym "b") (ssym "c") ::-                        UnionM (Either SymBool SymBool)-                    )-            ],-          testGroup-            "StateT"-            [ testGroup-                "Lazy"-                [ testCase "merge" $ do-                    let s :: StateLazy.StateT SymBool UnionM SymBool =-                          merge $ StateLazy.StateT $ \(x :: SymBool) ->-                            unionIf-                              (ssym "a")-                              (single (x, symNot x))-                              (single (symNot x, x))-                    StateLazy.runStateT s (ssym "b")-                      @?= mrgSingle-                        ( symIte (ssym "a") (ssym "b") (symNot $ ssym "b"),-                          symIte (ssym "a") (symNot $ ssym "b") (ssym "b")-                        ),-                  testCase "mrgSingle" $ do-                    let s :: StateLazy.StateT SymBool UnionM SymBool =-                          mrgSingle (ssym "x")-                    StateLazy.runStateT s (ssym "b")-                      @?= mrgSingle (ssym "x", ssym "b"),-                  testCase "mrgIf" $ do-                    let s :: StateLazy.StateT SymBool UnionM SymBool =-                          mrgIf-                            (ssym "a")-                            ( StateLazy.StateT $ \(x :: SymBool) ->-                                single (x, symNot x)-                            )-                            ( StateLazy.StateT $ \(x :: SymBool) ->-                                single (symNot x, x)-                            )-                    StateLazy.runStateT s (ssym "b")-                      @?= mrgSingle-                        ( symIte (ssym "a") (ssym "b") (symNot $ ssym "b"),-                          symIte (ssym "a") (symNot $ ssym "b") (ssym "b")-                        )-                ],-              testGroup-                "Strict"-                [ testCase "merge" $ do-                    let s :: StateStrict.StateT SymBool UnionM SymBool =-                          merge $ StateStrict.StateT $ \(x :: SymBool) ->-                            unionIf-                              (ssym "a")-                              (single (x, symNot x))-                              (single (symNot x, x))-                    StateStrict.runStateT s (ssym "b")-                      @?= mrgSingle-                        ( symIte (ssym "a") (ssym "b") (symNot $ ssym "b"),-                          symIte (ssym "a") (symNot $ ssym "b") (ssym "b")-                        ),-                  testCase "mrgSingle" $ do-                    let s :: StateStrict.StateT SymBool UnionM SymBool =-                          mrgSingle (ssym "x")-                    StateStrict.runStateT s (ssym "b")-                      @?= mrgSingle (ssym "x", ssym "b"),-                  testCase "mrgIf" $ do-                    let s :: StateStrict.StateT SymBool UnionM SymBool =-                          mrgIf-                            (ssym "a")-                            ( StateStrict.StateT $ \(x :: SymBool) ->-                                single (x, symNot x)-                            )-                            ( StateStrict.StateT $ \(x :: SymBool) ->-                                single (symNot x, x)-                            )-                    StateStrict.runStateT s (ssym "b")-                      @?= mrgSingle-                        ( symIte (ssym "a") (ssym "b") (symNot $ ssym "b"),-                          symIte (ssym "a") (symNot $ ssym "b") (ssym "b")-                        )-                ]-            ],-          testGroup-            "WriterT"-            [ testGroup-                "Lazy"-                [ testCase "merge" $ do-                    let s :: WriterLazy.WriterT [SymBool] UnionM SymBool =-                          merge $-                            WriterLazy.WriterT $-                              unionIf-                                (ssym "a")-                                (single (ssym "b", [ssym "c"]))-                                (single (ssym "d", [ssym "e"]))-                    WriterLazy.runWriterT s-                      @?= mrgSingle-                        ( symIte (ssym "a") (ssym "b") (ssym "d"),-                          [symIte (ssym "a") (ssym "c") (ssym "e")]-                        ),-                  testCase "mrgSingle" $ do-                    let s :: WriterLazy.WriterT [SymBool] UnionM SymBool =-                          mrgSingle (ssym "x")-                    WriterLazy.runWriterT s @?= mrgSingle (ssym "x", []),-                  testCase "mrgIf" $ do-                    let s :: WriterLazy.WriterT [SymBool] UnionM SymBool =-                          mrgIf-                            (ssym "a")-                            (WriterLazy.WriterT $ single (ssym "b", [ssym "c"]))-                            (WriterLazy.WriterT $ single (ssym "d", [ssym "e"]))-                    WriterLazy.runWriterT s-                      @?= mrgSingle-                        ( symIte (ssym "a") (ssym "b") (ssym "d"),-                          [symIte (ssym "a") (ssym "c") (ssym "e")]-                        )-                ],-              testGroup-                "Strict"-                [ testCase "merge" $ do-                    let s :: WriterStrict.WriterT [SymBool] UnionM SymBool =-                          merge $-                            WriterStrict.WriterT $-                              unionIf-                                (ssym "a")-                                (single (ssym "b", [ssym "c"]))-                                (single (ssym "d", [ssym "e"]))-                    WriterStrict.runWriterT s-                      @?= mrgSingle-                        ( symIte (ssym "a") (ssym "b") (ssym "d"),-                          [symIte (ssym "a") (ssym "c") (ssym "e")]-                        ),-                  testCase "mrgSingle" $ do-                    let s :: WriterStrict.WriterT [SymBool] UnionM SymBool =-                          mrgSingle (ssym "x")-                    WriterStrict.runWriterT s @?= mrgSingle (ssym "x", []),-                  testCase "mrgIf" $ do-                    let s :: WriterStrict.WriterT [SymBool] UnionM SymBool =-                          mrgIf-                            (ssym "a")-                            ( WriterStrict.WriterT $-                                single (ssym "b", [ssym "c"])-                            )-                            ( WriterStrict.WriterT $-                                single (ssym "d", [ssym "e"])-                            )-                    WriterStrict.runWriterT s-                      @?= mrgSingle-                        ( symIte (ssym "a") (ssym "b") (ssym "d"),-                          [symIte (ssym "a") (ssym "c") (ssym "e")]-                        )-                ]-            ],-          testGroup-            "ReaderT"-            [ testCase "merge" $-                do-                  let s :: ReaderT SymBool UnionM SymBool =-                        merge $ ReaderT $ \(x :: SymBool) ->-                          unionIf (ssym "a") (single x) (single $ symNot x)-                  runReaderT s (ssym "b")-                    @?= mrgSingle-                      (symIte (ssym "a") (ssym "b") (symNot $ ssym "b")),-              testCase-                "mrgSingle"-                $ do-                  let s :: ReaderT SymBool UnionM SymBool = mrgSingle (ssym "x")-                  runReaderT s (ssym "b") @?= mrgSingle (ssym "x"),-              testCase-                "mrgIf"-                $ do-                  let s :: ReaderT SymBool UnionM SymBool =-                        mrgIf-                          (ssym "a")-                          (ReaderT $ \(x :: SymBool) -> single x)-                          (ReaderT $ \(x :: SymBool) -> single $ symNot x)-                  runReaderT s (ssym "b")-                    @?= mrgSingle-                      (symIte (ssym "a") (ssym "b") (symNot $ ssym "b"))-            ],-          testGroup-            "IdentityT"-            [ testCase "merge" $-                do-                  let s :: IdentityT UnionM SymBool =-                        merge $-                          IdentityT $-                            unionIf-                              (ssym "a")-                              (single $ ssym "b")-                              (single $ ssym "c")-                  runIdentityT s-                    @?= mrgSingle (symIte (ssym "a") (ssym "b") (ssym "c")),-              testCase-                "mrgSingle"-                $ do-                  let s :: IdentityT UnionM SymBool = mrgSingle (ssym "x")-                  runIdentityT s @?= mrgSingle (ssym "x"),-              testCase-                "mrgIf"-                $ do-                  let s :: IdentityT UnionM SymBool =-                        mrgIf-                          (ssym "a")-                          (IdentityT $ single (ssym "b"))-                          (IdentityT $ single (ssym "c"))-                  runIdentityT s-                    @?= mrgSingle (symIte (ssym "a") (ssym "b") (ssym "c"))-            ]-        ]-    ]
+ test/Grisette/Core/Data/Class/UnionViewTests.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Grisette.Core.Data.Class.UnionViewTests (unionViewTests) where++import Grisette+  ( ITEOp (symIte),+    LogicalOp ((.&&)),+    Solvable (con),+    SymBool,+    SymBranching (mrgIfPropagatedStrategy),+    Union,+    mrgIf,+    mrgSingle,+    onUnion,+    simpleMerge,+    (.#),+    pattern If,+    pattern Single,+  )+import Grisette.Internal.Core.Data.Class.AsKey (AsKey (AsKey), AsKey1)+import Grisette.Internal.Core.Data.Class.UnionView+  ( UnionView (overestimateUnionValues),+  )+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit ((@?=))++unionViewTests :: Test+unionViewTests =+  testGroup+    "UnionView"+    [ testCase "simpleMerge" $ do+        simpleMerge+          ( mrgIfPropagatedStrategy "a" (return "b") (return "c") ::+              AsKey1 Union (AsKey SymBool)+          )+          @?= symIte "a" "b" "c",+      testCase "(.#)" $ do+        let symAll = foldl (.&&) (con True)+        symAll+          .# ( mrgIfPropagatedStrategy+                 "cond"+                 (return ["a"])+                 (return ["b", "c"]) ::+                 AsKey1 Union [AsKey SymBool]+             )+          @?= symIte "cond" "a" ("b" .&& "c"),+      testCase "onUnion" $ do+        let symAll = foldl (.&&) (con True)+        let symAllU = onUnion symAll+        symAllU+          ( mrgIfPropagatedStrategy "cond" (return ["a"]) (return ["b", "c"]) ::+              AsKey1 Union [AsKey SymBool]+          )+          @?= symIte "cond" "a" ("b" .&& "c"),+      testGroup+        "Single and If pattern"+        [ testCase "Unmerged" $+            case mrgIfPropagatedStrategy "a" (return "b") (return "c") ::+                   AsKey1 Union (AsKey SymBool) of+              Single _ -> fail "Expected If"+              If c l r -> do+                AsKey c @?= "a"+                l @?= return "b"+                r @?= return "c",+          testCase "Merged" $+            case mrgIf "a" (return "b") (return "c") :: AsKey1 Union (AsKey SymBool) of+              If {} -> fail "Expected Single"+              Single v -> v @?= symIte "a" "b" "c",+          testCase "Construct single" $+            (Single "a" :: AsKey1 Union (AsKey SymBool)) @?= mrgSingle "a",+          testCase "Construct If" $ do+            let actual = If "a" (return "b") (return "c") :: AsKey1 Union (AsKey SymBool)+            let expected = mrgIf "a" (return "b") (return "c")+            actual @?= expected+        ],+      testCase "overestimateUnionValues" $ do+        overestimateUnionValues (return 1 :: AsKey1 Union Int) @?= [1]+        overestimateUnionValues (mrgIf "a" (return 1) (return 2) :: AsKey1 Union Int)+          @?= [1, 2 :: Int]+        overestimateUnionValues+          (mrgIf "a" (return 1) (mrgIf "x" (return 3) (return 2)) :: AsKey1 Union Int)+          @?= [1, 2, 3 :: Int]+    ]
+ test/Grisette/Core/Data/UnionBaseTests.hs view
@@ -0,0 +1,1044 @@+{-# 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+  ( AsKey (AsKey),+    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+              AsKey+                ( ifWithLeftMost+                    False+                    "a"+                    (UnionSingle (1 :: Integer))+                    (UnionSingle 2)+                )+                @?= AsKey (UnionIf 1 False "a" (UnionSingle 1) (UnionSingle 2)),+          testCase "ifWithLeftMost should maintain left most info on Ifs" $ do+            AsKey+              ( ifWithLeftMost+                  True+                  "a"+                  ( UnionIf+                      1+                      True+                      "b"+                      (UnionSingle (1 :: Integer))+                      (UnionSingle 2)+                  )+                  (UnionIf 3 True "c" (UnionSingle 3) (UnionSingle 4))+              )+              @?= AsKey+                ( 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+                AsKey+                  ( ifWithStrategy+                      rootStrategy+                      (con True)+                      (UnionSingle (1 :: Integer))+                      (UnionSingle 2)+                  )+                  @?= AsKey (UnionSingle 1),+              testCase "false" $ do+                AsKey+                  ( ifWithStrategy+                      rootStrategy+                      (con False)+                      (UnionSingle (1 :: Integer))+                      (UnionSingle 2)+                  )+                  @?= AsKey (UnionSingle 2)+            ],+          let a =+                ifWithStrategy+                  rootStrategy+                  "a"+                  (UnionSingle (1 :: Integer))+                  (UnionSingle 2)+           in testGroup+                "ifWithStrategy with condition equal to sub conditions"+                [ testCase "ifTrue" $ do+                    AsKey+                      (ifWithStrategy rootStrategy "a" a (UnionSingle 3))+                      @?= AsKey (UnionIf 1 True "a" (UnionSingle 1) (UnionSingle 3)),+                  testCase "ifFalse" $ do+                    AsKey+                      (ifWithStrategy rootStrategy "a" (UnionSingle 0) a)+                      @?= AsKey (UnionIf 0 True "a" (UnionSingle 0) (UnionSingle 2))+                ],+          testCase "ifWithStrategy with simple mergeables" $ do+            AsKey+              ( ifWithStrategy+                  rootStrategy+                  "a"+                  (UnionSingle ("b" :: AsKey SymInteger))+                  (UnionSingle "c")+              )+              @?= AsKey (UnionSingle (symIte "a" "b" "c")),+          testGroup+            "ifWithStrategy with ordered mergeables"+            [ testGroup+                "ifWithStrategy on Single/Single"+                [ testGroup+                    "idxt < idxf"+                    [ testCase "Integer" $+                        AsKey+                          ( ifWithStrategy+                              rootStrategy+                              "a"+                              (UnionSingle (1 :: Integer))+                              (UnionSingle 2)+                          )+                          @?= AsKey+                            ( UnionIf+                                1+                                True+                                "a"+                                (UnionSingle 1)+                                (UnionSingle 2)+                            ),+                      testCase "Maybe Integer" $+                        AsKey+                          ( ifWithStrategy+                              rootStrategy+                              "a"+                              (UnionSingle Nothing)+                              (UnionSingle (Just (2 :: Integer)))+                          )+                          @?= AsKey+                            ( UnionIf+                                Nothing+                                True+                                "a"+                                (UnionSingle Nothing)+                                (UnionSingle (Just 2))+                            )+                    ],+                  testGroup+                    "idxt == idxf"+                    [ testGroup+                        "idxt == idxf as terminal"+                        [ testCase "Integer" $+                            AsKey+                              ( ifWithStrategy+                                  rootStrategy+                                  "a"+                                  (UnionSingle (1 :: Integer))+                                  (UnionSingle 1)+                              )+                              @?= AsKey (UnionSingle 1),+                          testCase "Maybe Integer" $+                            AsKey+                              ( ifWithStrategy+                                  rootStrategy+                                  "a"+                                  (UnionSingle (Just ("b" :: AsKey SymInteger)))+                                  (UnionSingle (Just "c"))+                              )+                              @?= AsKey (UnionSingle (Just (symIte "a" "b" "c")))+                        ],+                      testGroup+                        "idxt == idxf but not terminal"+                        [ testCase "Maybe Integer" $+                            AsKey+                              ( ifWithStrategy+                                  rootStrategy+                                  "a"+                                  (UnionSingle (Just (1 :: Integer)))+                                  (UnionSingle (Just (2 :: Integer)))+                              )+                              @?= AsKey+                                ( UnionIf+                                    (Just 1)+                                    True+                                    "a"+                                    (UnionSingle $ Just 1)+                                    (UnionSingle (Just 2))+                                ),+                          testCase "Maybe (Maybe Integer)" $+                            AsKey+                              ( ifWithStrategy+                                  rootStrategy+                                  "a"+                                  (UnionSingle $ Just $ Just ("b" :: AsKey SymInteger))+                                  (UnionSingle $ Just $ Just "c")+                              )+                              @?= AsKey (UnionSingle (Just (Just (symIte "a" "b" "c"))))+                        ]+                    ],+                  testGroup+                    "idxt > idxf"+                    [ testCase "Integer" $+                        AsKey+                          ( ifWithStrategy+                              rootStrategy+                              "a"+                              (UnionSingle (2 :: Integer))+                              (UnionSingle 1)+                          )+                          @?= AsKey+                            ( UnionIf+                                1+                                True+                                (symNot "a")+                                (UnionSingle 1)+                                (UnionSingle 2)+                            ),+                      testCase "Maybe Integer" $+                        AsKey+                          ( ifWithStrategy+                              rootStrategy+                              "a"+                              (UnionSingle (Just (2 :: Integer)))+                              (UnionSingle Nothing)+                          )+                          @?= AsKey+                            ( 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)))+                        AsKey+                          ( ifWithStrategy+                              rootStrategy+                              "b"+                              (UnionSingle Nothing)+                              x+                          )+                          @?= AsKey+                            ( 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" $+                                AsKey+                                  ( ifWithStrategy+                                      rootStrategy+                                      "b"+                                      (UnionSingle $ Just 0)+                                      x+                                  )+                                  @?= AsKey+                                    ( UnionIf+                                        (Just 0)+                                        True+                                        "b"+                                        (UnionSingle $ Just 0)+                                        ( UnionIf+                                            (Just 1)+                                            True+                                            "a"+                                            (UnionSingle $ Just 1)+                                            (UnionSingle (Just 3))+                                        )+                                    ),+                              testCase "sub-idxt == sub-idxft" $+                                AsKey+                                  ( ifWithStrategy+                                      rootStrategy+                                      "b"+                                      (UnionSingle $ Just 1)+                                      x+                                  )+                                  @?= AsKey+                                    ( UnionIf+                                        (Just 1)+                                        True+                                        ("b" .|| "a")+                                        (UnionSingle $ Just 1)+                                        (UnionSingle (Just 3))+                                    ),+                              testCase "subidxft < sub-idxt < sub-idxff" $+                                AsKey+                                  ( ifWithStrategy+                                      rootStrategy+                                      "b"+                                      (UnionSingle $ Just 2)+                                      x+                                  )+                                  @?= AsKey+                                    ( 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" $+                                AsKey+                                  ( ifWithStrategy+                                      rootStrategy+                                      "b"+                                      (UnionSingle $ Just 3)+                                      x+                                  )+                                  @?= AsKey+                                    ( UnionIf+                                        (Just 1)+                                        True+                                        ((symNot "b") .&& "a")+                                        (UnionSingle $ Just 1)+                                        (UnionSingle (Just 3))+                                    ),+                              testCase "sub-idxff < sub-idxt" $+                                AsKey+                                  ( ifWithStrategy+                                      rootStrategy+                                      "b"+                                      (UnionSingle $ Just 4)+                                      x+                                  )+                                  @?= AsKey+                                    ( 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)))+                        AsKey+                          ( ifWithStrategy+                              rootStrategy+                              "b"+                              (UnionSingle $ Right (1 :: Integer))+                              x+                          )+                          @?= AsKey+                            ( 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))+                    AsKey+                      ( ifWithStrategy+                          rootStrategy+                          "b"+                          (UnionSingle 0)+                          x+                      )+                      @?= AsKey+                        ( 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))+                    AsKey+                      ( ifWithStrategy+                          rootStrategy+                          "b"+                          (UnionSingle $ Left 0)+                          x+                      )+                      @?= AsKey+                        ( 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))+                    AsKey+                      ( ifWithStrategy+                          rootStrategy+                          "b"+                          (UnionSingle $ Right 0)+                          x+                      )+                      @?= AsKey+                        ( 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)))+                        AsKey+                          ( ifWithStrategy+                              rootStrategy+                              "b"+                              x+                              (UnionSingle $ Right (2 :: Integer))+                          )+                          @?= AsKey+                            ( 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" $+                                AsKey+                                  ( ifWithStrategy+                                      rootStrategy+                                      "b"+                                      x+                                      (UnionSingle $ Just 0)+                                  )+                                  @?= AsKey+                                    ( 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" $+                                AsKey+                                  ( ifWithStrategy+                                      rootStrategy+                                      "b"+                                      x+                                      (UnionSingle $ Just 1)+                                  )+                                  @?= AsKey+                                    ( UnionIf+                                        (Just 1)+                                        True+                                        ((symNot "b") .|| "a")+                                        (UnionSingle $ Just 1)+                                        (UnionSingle (Just 3))+                                    ),+                              testCase "sub-idxtt < sub-idxf < sub-idxtf" $+                                AsKey+                                  ( ifWithStrategy+                                      rootStrategy+                                      "b"+                                      x+                                      (UnionSingle $ Just 2)+                                  )+                                  @?= AsKey+                                    ( 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" $+                                AsKey+                                  ( ifWithStrategy+                                      rootStrategy+                                      "b"+                                      x+                                      (UnionSingle $ Just 3)+                                  )+                                  @?= AsKey+                                    ( UnionIf+                                        (Just 1)+                                        True+                                        ("b" .&& "a")+                                        (UnionSingle $ Just 1)+                                        (UnionSingle (Just 3))+                                    ),+                              testCase "sub-idxtf < sub-idxf" $+                                AsKey+                                  ( ifWithStrategy+                                      rootStrategy+                                      "b"+                                      x+                                      (UnionSingle $ Just 4)+                                  )+                                  @?= AsKey+                                    ( 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)))+                        AsKey+                          ( ifWithStrategy+                              rootStrategy+                              "b"+                              x+                              (UnionSingle $ Left (1 :: Integer))+                          )+                          @?= AsKey+                            ( 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))+                    AsKey+                      ( ifWithStrategy+                          rootStrategy+                          "b"+                          x+                          (UnionSingle $ Right 0)+                      )+                      @?= AsKey+                        ( 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))+                    AsKey+                      ( ifWithStrategy+                          rootStrategy+                          "b"+                          x+                          (UnionSingle $ Left 0)+                      )+                      @?= AsKey+                        ( 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))+                    AsKey+                      ( ifWithStrategy+                          rootStrategy+                          "b"+                          x+                          (UnionSingle 0)+                      )+                      @?= AsKey+                        ( 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))+                    AsKey+                      ( ifWithStrategy+                          rootStrategy+                          "c"+                          x+                          y+                      )+                      @?= AsKey+                        ( 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))+                    AsKey+                      ( ifWithStrategy+                          rootStrategy+                          "c"+                          y+                          x+                      )+                      @?= AsKey+                        ( 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))+                    AsKey+                      ( ifWithStrategy+                          rootStrategy+                          "c"+                          x+                          y+                      )+                      @?= AsKey+                        ( 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))+                    AsKey+                      ( ifWithStrategy+                          rootStrategy+                          "c"+                          x+                          y+                      )+                      @?= AsKey+                        ( 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))+                    AsKey+                      ( ifWithStrategy+                          rootStrategy+                          "c"+                          x+                          y+                      )+                      @?= AsKey+                        ( 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)+                AsKey+                  ( ifWithStrategy+                      rootStrategy+                      "c"+                      x+                      y+                  )+                  @?= AsKey+                    ( 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+            AsKey (fullReconstruct rootStrategy z)+              @?= AsKey+                ( 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)+                    )+                )+        ]+    ]
+ test/Grisette/Core/TH/DerivationData.hs view
@@ -0,0 +1,467 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -ddump-splices -ddump-to-file -ddump-file-prefix=derivation #-}++module Grisette.Core.TH.DerivationData+  ( T (..),+    concreteT,+    symbolicT,+    IdenticalFields (..),+    Basic (..),+    GGG (..),+    VVV (..),+    Extra (..),+    Ambiguous (..),+    replaceVVVShown,+    gggToVVV,+    Serializable (..),+  )+where++import Control.DeepSeq (NFData, NFData1, NFData2)+import Control.Monad.Identity (Identity (Identity))+import Data.Binary (Binary)+import Data.Bytes.Serial (Serial)+import Data.Functor.Classes+  ( Eq1 (liftEq),+    Eq2,+    Ord1,+    Ord2,+    Show1,+    Show2,+  )+import Data.Hashable (Hashable)+import Data.Hashable.Lifted (Hashable1, Hashable2)+import Data.Maybe (fromJust)+import Data.Serialize (Serialize)+import qualified Data.Text as T+import Data.Typeable (Proxy, Typeable)+import GHC.Generics (Generic)+import Grisette+  ( AllSyms,+    AllSyms1,+    AllSyms2,+    AsKey,+    BasicSymPrim,+    Default (Default),+    DeriveConfig (unconstrainedPositions),+    EvalSym,+    EvalSym1,+    EvalSym2,+    ExtractSym,+    ExtractSym1,+    ExtractSym2,+    Mergeable,+    Mergeable1,+    Mergeable2,+    PPrint,+    PPrint1,+    PPrint2,+    SimpleMergeable,+    Solvable (con),+    SubstSym,+    SubstSym1,+    SubstSym2,+    SymBool,+    SymEq,+    SymEq1,+    SymEq2,+    SymInteger,+    SymOrd,+    SymOrd1,+    SymOrd2,+    ToCon (toCon),+    ToSym (toSym),+    Union,+    allClasses0,+    allClasses012,+    derive,+    deriveWith,+    (.&&),+    (.||),+  )+import Grisette.Core.TH.PartialEvalMode (PartialEvalMode)+import Grisette.Internal.TH.Derivation.Common+  ( DeriveConfig+      ( bitSizePositions,+        evalModeConfig,+        fpBitSizePositions,+        needExtraMergeableUnderEvalMode+      ),+    EvalModeConfig (EvalModeConstraints),+  )+import Grisette.Unified+  ( EvalModeBV,+    EvalModeBase,+    EvalModeTag (C, S),+    GetBool,+    GetData,+    GetFP,+    GetWordN,+    UnifiedSimpleMergeable,+  )+import Test.QuickCheck (Arbitrary, oneof, sized)+import Test.QuickCheck.Arbitrary (Arbitrary (arbitrary))++newtype Skipped a b c = Skipped b++deriveWith+  (mempty {unconstrainedPositions = [0, 2]})+  [''Skipped]+  allClasses012++data Empty a b c++derive [''Empty] allClasses012++data EmptyWithMode (mode :: EvalModeTag) a b c++derive [''EmptyWithMode] allClasses012++data T mode n a+  = T (GetBool mode) [GetWordN mode n] [a] (GetData mode (T mode n a))+  | TNil++#if MIN_VERSION_base(4,16,0)+deriveWith+  ( mempty+      { evalModeConfig =+          [(0, EvalModeConstraints [''EvalModeBV, ''EvalModeBase])],+        bitSizePositions = [1],+        needExtraMergeableUnderEvalMode = True+      }+  )+  [''T]+  allClasses0++concreteT :: T 'C 10 Integer+concreteT =+  toSym (T True [10] [10 :: Integer] (Identity TNil) :: T 'C 10 Integer)++symbolicT :: T 'S 10 SymInteger+symbolicT = fromJust $ toCon (toSym concreteT :: T 'S 10 SymInteger)+#else+concreteT :: T 'C 10 Integer+concreteT = undefined++symbolicT :: T 'S 10 SymInteger+symbolicT = undefined+#endif++newtype X mode = X [GetBool mode]++deriveWith+  ( mempty+      { evalModeConfig = [(0, EvalModeConstraints [''EvalModeBase])]+      }+  )+  [''X]+  allClasses0++data IdenticalFields (mode :: EvalModeTag) a b = IdenticalFields+  { a :: a,+    b :: a,+    c :: Maybe Int,+    d :: Maybe Int+  }++deriveWith+  ( mempty+      { needExtraMergeableUnderEvalMode = True+      }+  )+  [''IdenticalFields]+  allClasses012++data Basic = Basic0 | Basic1 Int | Basic2 String [Int]++derive [''Basic] allClasses0++data Extra mode n eb sb a where+  Extra ::+    GetBool mode ->+    [GetWordN mode n] ->+    [GetData mode [Extra mode n eb sb a]] ->+    GetFP mode eb sb ->+    GetFP mode eb sb ->+    a ->+    a ->+    Extra mode n eb sb a++#if MIN_VERSION_base(4,16,0)+deriveWith+  ( mempty+      { evalModeConfig = [(0, EvalModeConstraints [''PartialEvalMode])],+        bitSizePositions = [1],+        fpBitSizePositions = [(2, 3)],+        needExtraMergeableUnderEvalMode = True+      }+  )+  [''Extra]+  allClasses0+#endif++data Expr f a where+  I :: SymInteger -> Expr f SymInteger+  B :: SymBool -> Expr f SymBool+  Add :: Union (Expr f SymInteger) -> Union (Expr f SymInteger) -> Expr f SymInteger+  Mul :: Union (Expr f SymInteger) -> Union (Expr f SymInteger) -> Expr f SymInteger+  Eq :: (BasicSymPrim a) => Union (Expr f a) -> Union (Expr f a) -> Expr f SymBool+  Eq3 ::+    (BasicSymPrim a) =>+    Union (Expr f a) ->+    Union (Expr f a) ->+    Union (Expr f b) ->+    Union (Expr f b) ->+    Expr f b+  WExpr ::+    (BasicSymPrim a, BasicSymPrim b, BasicSymPrim c) =>+    a ->+    b ->+    c ->+    d ->+    Expr f d+  XExpr :: f a -> Expr f a+  YExpr :: (BasicSymPrim a) => f a -> Expr f (f a)+  ZExpr ::+    ( AllSyms1 f,+      Mergeable1 f,+      Eq1 f,+      EvalSym1 f,+      ExtractSym1 f,+      SubstSym1 f,+      NFData1 f,+      PPrint1 f,+      Show1 f,+      Typeable f,+      Hashable1 f,+      BasicSymPrim a,+      SymEq1 f,+      SymOrd1 f+    ) =>+    f a ->+    Expr g b++derive+  [''Expr]+  [ ''Mergeable,+    ''Mergeable1,+    ''EvalSym,+    ''EvalSym1,+    ''ExtractSym,+    ''ExtractSym1,+    ''SubstSym,+    ''SubstSym1,+    ''NFData,+    ''NFData1,+    ''Show,+    ''Show1,+    ''PPrint,+    ''PPrint1,+    ''AllSyms,+    ''AllSyms1,+    ''Eq,+    ''SymEq,+    ''SymOrd+  ]++instance (Eq1 f) => Eq1 (Expr f) where+  liftEq = undefined++data P a b = P a | Q Int++derive+  [''P]+  [ ''Mergeable,+    ''Mergeable1,+    ''Mergeable2,+    ''EvalSym,+    ''EvalSym1,+    ''EvalSym2,+    ''ExtractSym,+    ''ExtractSym1,+    ''ExtractSym2,+    ''SubstSym,+    ''SubstSym1,+    ''SubstSym2,+    ''NFData,+    ''NFData1,+    ''NFData2,+    ''Hashable,+    ''Hashable1,+    ''Hashable2,+    ''Show,+    ''Show1,+    ''Show2,+    ''PPrint,+    ''PPrint1,+    ''PPrint2,+    ''AllSyms,+    ''AllSyms1,+    ''AllSyms2,+    ''Eq,+    ''Eq1,+    ''Eq2,+    ''SymEq,+    ''SymEq1,+    ''SymEq2,+    ''Ord,+    ''Ord1,+    ''Ord2,+    ''SymOrd,+    ''SymOrd1,+    ''SymOrd2+  ]++data GGG a b where+  GGG2 :: a -> b -> GGG a b+  GGG1 :: a -> GGG a b+  GGG0 :: GGG a b+  GGGRec :: a -> b -> GGG a b+  (:|) :: a -> b -> GGG a b+  GGGLst :: [a] -> [b] -> GGG a b++infixr 5 :|++derive+  [''GGG]+  [ ''Show,+    ''Show1,+    ''Show2,+    ''PPrint,+    ''PPrint1,+    ''PPrint2,+    ''Eq,+    ''Eq1,+    ''Eq2,+    ''Ord,+    ''Ord1,+    ''Ord2,+    ''SymEq,+    ''SymEq1,+    ''SymEq2,+    ''SymOrd,+    ''SymOrd1,+    ''SymOrd2+  ]++instance (Arbitrary a, Arbitrary b) => Arbitrary (GGG a b) where+  arbitrary =+    oneof+      [ GGG2 <$> arbitrary <*> arbitrary,+        GGG1 <$> arbitrary,+        return GGG0,+        GGGRec <$> arbitrary <*> arbitrary,+        (:|) <$> arbitrary <*> arbitrary,+        GGGLst <$> arbitrary <*> arbitrary+      ]++gggToVVV :: GGG a b -> VVV a b+gggToVVV (GGG2 a b) = VVV2 a b+gggToVVV (GGG1 a) = VVV1 a+gggToVVV GGG0 = VVV0+gggToVVV (GGGRec a b) = VVVRec a b+gggToVVV (a :| b) = a :. b+gggToVVV (GGGLst a b) = VVVLst a b++data VVV a b where+  VVV2 :: a -> b -> VVV a b+  VVV1 :: a -> VVV a b+  VVV0 :: VVV a b+  VVVRec :: a -> b -> VVV a b+  (:.) :: a -> b -> VVV a b+  VVVLst :: [a] -> [b] -> VVV a b+  deriving (Generic, Eq, Ord)+  deriving (PPrint, SymEq, SymOrd) via (Default (VVV a b))++infixr 5 :.++instance (Arbitrary a, Arbitrary b) => Arbitrary (VVV a b) where+  arbitrary =+    oneof+      [ VVV2 <$> arbitrary <*> arbitrary,+        VVV1 <$> arbitrary,+        return VVV0,+        VVVRec <$> arbitrary <*> arbitrary,+        (:.) <$> arbitrary <*> arbitrary+      ]++replaceVVVShown :: T.Text -> T.Text+replaceVVVShown =+  T.replace ":." ":|" . T.replace "VVV" "GGG" . T.replace "vvv" "ggg"++deriving instance (Show a, Show b) => Show (VVV a b)++data Ambiguous x where+  Ambiguous :: forall x a. (BasicSymPrim a) => Proxy a -> Ambiguous x++instance Eq (Ambiguous x) where+  (==) = undefined++derive+  [''Ambiguous]+  [ ''AllSyms,+    ''Mergeable,+    ''ExtractSym,+    ''NFData,+    ''PPrint,+    ''Show,+    ''Hashable+  ]++data SimpleMergeableType mode n x+  = SimpleMergeableType+      (GetBool mode)+      (GetWordN mode n)+      x+      (GetData mode (SimpleMergeableType mode n x))++#if MIN_VERSION_base(4,16,0)+deriveWith+  ( mempty+      { evalModeConfig =+          [(0, EvalModeConstraints [''EvalModeBV, ''EvalModeBase])],+        bitSizePositions = [1],+        needExtraMergeableUnderEvalMode = True+      }+  )+  [''SimpleMergeableType]+  ([''SimpleMergeable, ''UnifiedSimpleMergeable] ++ allClasses0)+#endif++data Serializable a+  = Se1 a+  | Se2 (AsKey SymBool)+  deriving (Show, Eq)++instance (Arbitrary a) => Arbitrary (Serializable a) where+  arbitrary = oneof [Se1 <$> arbitrary, Se2 <$> sized bool]+    where+      bool n | n <= 0 = do+        b <- arbitrary+        oneof [return (con b), return "a", return "b"]+      bool n = do+        l <- bool (n `div` 2)+        r <- bool (n `div` 2)+        oneof [return (l .|| r), return (l .&& r), return l]++derive [''Serializable] [''Serial, ''Serialize, ''Binary]
+ test/Grisette/Core/TH/DerivationTest.hs view
@@ -0,0 +1,171 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Unused LANGUAGE pragma" #-}++-- {-# OPTIONS_GHC -ddump-simpl -dsuppress-module-prefixes -dsuppress-uniques #-}+-- {-# OPTIONS_GHC -ddump-timings #-}++module Grisette.Core.TH.DerivationTest (derivationTest) where++import Data.Bytes.Get (runGetS)+import Data.Bytes.Put (runPutS)+import Data.Bytes.Serial (Serial (deserialize, serialize))+import Data.Functor.Classes (showsPrec1, showsPrec2)+import qualified Data.Text as T+import GHC.TypeLits (KnownNat, type (<=))+import Grisette+  ( AsKey (AsKey),+    AsKey1 (AsKey1),+    FP32,+    Mergeable,+    PPrint (pformat, pformatPrec),+    Solvable (con),+    SymEq ((.==)),+    SymOrd (symCompare),+    ValidFP,+    WordN32,+    docToTextWithWidth,+    mrgSingle,+    pformatPrec1,+    pformatPrec2,+    symCompare1,+    symCompare2,+    symEq1,+    symEq2,+  )+import Grisette.Core.TH.DerivationData+  ( Extra (Extra),+    GGG,+    Serializable,+    gggToVVV,+    replaceVVVShown,+  )+import Grisette.Core.TH.PartialEvalMode (PartialEvalMode)+import Grisette.TestUtil.SymbolicAssertion ((.@?=))+import Grisette.Unified+  ( BaseMonad,+    EvalModeTag (C),+    GetBool,+    GetData,+    extractData,+  )+import qualified Grisette.Unified as GU+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.QuickCheck.Property ((.&.), (===))++#if MIN_VERSION_base(4,16,0)+ftst ::+  forall mode n eb sb a.+  ( PartialEvalMode mode,+    KnownNat n,+    1 <= n,+    ValidFP eb sb,+    Mergeable a+  ) =>+  GetBool mode ->+  GetData mode (Extra mode n eb sb a) ->+  GetData mode (Extra mode n eb sb a) ->+  BaseMonad mode (Extra mode n eb sb a)+ftst c t f =+  GU.mrgIf @mode+    c+    (extractData t)+    (extractData f)++derivationExtraTest :: [Test]+derivationExtraTest =+  [ testCase "ftst" $ do+      let x = Extra True [1 :: WordN32] [] (0 :: FP32) 0 0 (0 :: Int)+      let y = Extra False [1 :: WordN32] [] (0 :: FP32) 0 0 (0 :: Int)+      let a = ftst @'C True (return x) (return y)+      a .@?= return x+  ]+#else+derivationExtraTest :: [Test]+derivationExtraTest = []+#endif++derivationTest :: Test+derivationTest =+  testGroup "Derivation" $+    [ testProperty "GADT Show instance for regular types" $+        \(g :: GGG (GGG Int String) [Int]) ->+          let v = gggToVVV g+           in replaceVVVShown (T.pack (show g))+                === replaceVVVShown (T.pack (show v)),+      testProperty "GADT Show and Show1 are consistent" $+        \(g :: GGG (GGG Char String) [Int]) ->+          T.pack (show g)+            === T.pack (showsPrec1 0 g "")+            .&. T.pack (showsPrec 11 g "")+            === T.pack (showsPrec1 11 g ""),+      testProperty "GADT Show and Show2 are consistent" $+        \(g :: GGG (GGG Char String) [Int]) ->+          T.pack (show g)+            === T.pack (showsPrec2 0 g "")+            .&. T.pack (showsPrec 11 g "")+            === T.pack (showsPrec2 11 g ""),+      testProperty "GADT PPrint instance for regular types" $+        \(g :: GGG (GGG Int String) [Int]) ->+          let v = gggToVVV g+           in replaceVVVShown (docToTextWithWidth 1000 (pformat g))+                === replaceVVVShown (docToTextWithWidth 1000 (pformat v))+                .&. replaceVVVShown (docToTextWithWidth 0 (pformat g))+                === replaceVVVShown (docToTextWithWidth 0 (pformat v)),+      testProperty "GADT PPrint and PPrint1 are consistent" $+        \(g :: GGG (GGG Char String) [Int]) ->+          docToTextWithWidth 1000 (pformatPrec 0 g)+            === docToTextWithWidth 1000 (pformatPrec1 0 g)+            .&. docToTextWithWidth 1000 (pformatPrec 11 g)+            === docToTextWithWidth 1000 (pformatPrec1 11 g)+            .&. docToTextWithWidth 0 (pformatPrec 0 g)+            === docToTextWithWidth 0 (pformatPrec1 0 g)+            .&. docToTextWithWidth 0 (pformatPrec 11 g)+            === docToTextWithWidth 0 (pformatPrec1 11 g),+      testProperty "GADT PPrint and PPrint2 are consistent" $+        \(g :: GGG (GGG Char String) [Int]) ->+          docToTextWithWidth 1000 (pformatPrec 0 g)+            === docToTextWithWidth 1000 (pformatPrec2 0 g)+            .&. docToTextWithWidth 1000 (pformatPrec 11 g)+            === docToTextWithWidth 1000 (pformatPrec2 11 g)+            .&. docToTextWithWidth 0 (pformatPrec 0 g)+            === docToTextWithWidth 0 (pformatPrec2 0 g)+            .&. docToTextWithWidth 0 (pformatPrec 11 g)+            === docToTextWithWidth 0 (pformatPrec2 11 g),+      testProperty "GADT SymEq and Eq are consistent" $+        \(g1 :: GGG (GGG Int String) [Int]) g2 ->+          let v1 = gggToVVV g1+              v2 = gggToVVV g2+           in AsKey (con (g1 == g2)) === AsKey (v1 .== v2),+      testProperty "GADT SymEq1 and SymEq are consistent" $+        \(g1 :: GGG (GGG Int String) [Int]) g2 ->+          AsKey (symEq1 g1 g2) === AsKey (g1 .== g2),+      testProperty "GADT SymEq2 and SymEq are consistent" $+        \(g1 :: GGG (GGG Int String) [Int]) g2 ->+          AsKey (symEq2 g1 g2) === AsKey (g1 .== g2),+      testProperty "GADT SymOrd and Ord are consistent" $+        \(g1 :: GGG (GGG Int String) [Int]) g2 ->+          let v1 = gggToVVV g1+              v2 = gggToVVV g2+           in mrgSingle (g1 `compare` g2) === AsKey1 (v1 `symCompare` v2),+      testProperty "GADT SymOrd1 and SymOrd are consistent" $+        \(g1 :: GGG (GGG Int String) [Int]) g2 ->+          AsKey1 (symCompare1 g1 g2) === AsKey1 (g1 `symCompare` g2),+      testProperty "GADT SymOrd2 and SymOrd are consistent" $+        \(g1 :: GGG (GGG Int String) [Int]) g2 ->+          AsKey1 (symCompare2 g1 g2) === AsKey1 (g1 `symCompare` g2),+      testProperty "Serialize" $ do+        \(s :: Serializable Int) ->+          let bs = runPutS (serialize s)+              s' = runGetS deserialize bs+           in Right s === s'+    ]+      ++ derivationExtraTest
+ test/Grisette/Core/TH/PartialEvalMode.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE TemplateHaskell #-}++module Grisette.Core.TH.PartialEvalMode+  ( PartialEvalMode,+    MonadPartialEvalMode,+  )+where++import Grisette.Unified+  ( TheoryToUnify (UBool, UFP, UWordN),+    genEvalMode,+  )++genEvalMode "PartialEvalMode" [UBool, UWordN, UFP]
− test/Grisette/IR/SymPrim/Data/Prim/BVTests.hs 
@@ -1,122 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}--module Grisette.IR.SymPrim.Data.Prim.BVTests (bvTests) where--import Data.Proxy (Proxy (Proxy))-import Grisette.Core.Data.BV (IntN, WordN)-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors-  ( bvconcatTerm,-    bvextendTerm,-    bvselectTerm,-    conTerm,-    ssymTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term (Term)-import Grisette.IR.SymPrim.Data.Prim.PartialEval.BV-  ( pevalBVConcatTerm,-    pevalBVExtendTerm,-    pevalBVSelectTerm,-  )-import Test.Framework (Test, testGroup)-import Test.Framework.Providers.HUnit (testCase)-import Test.HUnit ((@=?))--bvTests :: Test-bvTests =-  testGroup-    "BV"-    [ testGroup-        "pevalBVSelectTerm"-        [ testCase "On concrete" $ do-            pevalBVSelectTerm-              (Proxy @0)-              (Proxy @1)-              (conTerm 6 :: Term (WordN 4))-              @=? conTerm 0-            pevalBVSelectTerm-              (Proxy @1)-              (Proxy @1)-              (conTerm 6 :: Term (WordN 4))-              @=? conTerm 1-            pevalBVSelectTerm-              (Proxy @2)-              (Proxy @1)-              (conTerm 6 :: Term (WordN 4))-              @=? conTerm 1-            pevalBVSelectTerm-              (Proxy @3)-              (Proxy @1)-              (conTerm 6 :: Term (WordN 4))-              @=? conTerm 0-            pevalBVSelectTerm-              (Proxy @0)-              (Proxy @2)-              (conTerm 6 :: Term (WordN 4))-              @=? conTerm 2-            pevalBVSelectTerm-              (Proxy @1)-              (Proxy @2)-              (conTerm 6 :: Term (WordN 4))-              @=? conTerm 3-            pevalBVSelectTerm-              (Proxy @2)-              (Proxy @2)-              (conTerm 6 :: Term (WordN 4))-              @=? conTerm 1-            pevalBVSelectTerm-              (Proxy @0)-              (Proxy @3)-              (conTerm 6 :: Term (WordN 4))-              @=? conTerm 6-            pevalBVSelectTerm-              (Proxy @1)-              (Proxy @3)-              (conTerm 6 :: Term (WordN 4))-              @=? conTerm 3-            pevalBVSelectTerm-              (Proxy @0)-              (Proxy @4)-              (conTerm 6 :: Term (WordN 4))-              @=? conTerm 6,-          testCase "On symbolic" $ do-            pevalBVSelectTerm-              (Proxy @2)-              (Proxy @1)-              (ssymTerm "a" :: Term (WordN 4))-              @=? bvselectTerm (Proxy @2) (Proxy @1) (ssymTerm "a" :: Term (WordN 4))-        ],-      testGroup-        "Extension"-        [ testCase "On concrete" $ do-            pevalBVExtendTerm True (Proxy @6) (conTerm 15 :: Term (WordN 4))-              @=? (conTerm 63 :: Term (WordN 6))-            pevalBVExtendTerm False (Proxy @6) (conTerm 15 :: Term (WordN 4))-              @=? (conTerm 15 :: Term (WordN 6))-            pevalBVExtendTerm True (Proxy @6) (conTerm 15 :: Term (IntN 4))-              @=? (conTerm 63 :: Term (IntN 6))-            pevalBVExtendTerm False (Proxy @6) (conTerm 15 :: Term (IntN 4))-              @=? (conTerm 15 :: Term (IntN 6)),-          testCase "On symbolic" $ do-            pevalBVExtendTerm True (Proxy @6) (ssymTerm "a" :: Term (WordN 4))-              @=? bvextendTerm True (Proxy @6) (ssymTerm "a" :: Term (WordN 4))-            pevalBVExtendTerm False (Proxy @6) (ssymTerm "a" :: Term (WordN 4))-              @=? bvextendTerm False (Proxy @6) (ssymTerm "a" :: Term (WordN 4))-        ],-      testGroup-        "Concat"-        [ testCase "On concrete" $ do-            pevalBVConcatTerm (conTerm 3 :: Term (WordN 4)) (conTerm 5 :: Term (WordN 3))-              @=? conTerm 29-            pevalBVConcatTerm (conTerm 3 :: Term (IntN 4)) (conTerm 5 :: Term (IntN 3))-              @=? conTerm 29,-          testCase "On symbolic" $ do-            pevalBVConcatTerm (ssymTerm "a" :: Term (WordN 4)) (ssymTerm "b" :: Term (WordN 3))-              @=? bvconcatTerm-                (ssymTerm "a" :: Term (WordN 4))-                (ssymTerm "b" :: Term (WordN 3))-        ]-    ]
− test/Grisette/IR/SymPrim/Data/Prim/BitsTests.hs 
@@ -1,312 +0,0 @@-{-# LANGUAGE BinaryLiterals #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}--module Grisette.IR.SymPrim.Data.Prim.BitsTests (bitsTests) where--import Data.Bits (Bits (rotateL, rotateR), FiniteBits)-import Grisette.Core.Data.BV (IntN, WordN)-import Grisette.Core.Data.Class.SymRotate (SymRotate)-import Grisette.IR.SymPrim (SupportedPrim)-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors-  ( andBitsTerm,-    complementBitsTerm,-    conTerm,-    orBitsTerm,-    rotateLeftTerm,-    rotateRightTerm,-    shiftLeftTerm,-    shiftRightTerm,-    ssymTerm,-    xorBitsTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term (Term)-import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bits-  ( pevalAndBitsTerm,-    pevalComplementBitsTerm,-    pevalOrBitsTerm,-    pevalRotateLeftTerm,-    pevalRotateRightTerm,-    pevalShiftLeftTerm,-    pevalShiftRightTerm,-    pevalXorBitsTerm,-  )-import Test.Framework (Test, testGroup)-import Test.Framework.Providers.HUnit (testCase)-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.HUnit ((@=?))-import Test.QuickCheck (Property, discard, ioProperty)--bitsTests :: Test-bitsTests =-  testGroup-    "Bits"-    [ testGroup-        "AndBits"-        [ testCase "On both concrete" $ do-            pevalAndBitsTerm-              (conTerm 3 :: Term (WordN 4))-              (conTerm 5)-              @=? conTerm 1,-          testCase "On zeroBits" $ do-            pevalAndBitsTerm-              (conTerm 0 :: Term (WordN 4))-              (ssymTerm "a")-              @=? conTerm 0-            pevalAndBitsTerm-              (ssymTerm "a")-              (conTerm 0 :: Term (WordN 4))-              @=? conTerm 0,-          testCase "On all one bits" $ do-            pevalAndBitsTerm-              (conTerm 15 :: Term (WordN 4))-              (ssymTerm "a")-              @=? ssymTerm "a"-            pevalAndBitsTerm-              (ssymTerm "a")-              (conTerm 15 :: Term (WordN 4))-              @=? ssymTerm "a",-          testCase "On symbolic" $ do-            pevalAndBitsTerm-              (ssymTerm "a" :: Term (WordN 4))-              (ssymTerm "b")-              @=? andBitsTerm-                (ssymTerm "a" :: Term (WordN 4))-                (ssymTerm "b" :: Term (WordN 4))-        ],-      testGroup-        "OrBits"-        [ testCase "On both concrete" $ do-            pevalOrBitsTerm-              (conTerm 3 :: Term (WordN 4))-              (conTerm 5)-              @=? conTerm 7,-          testCase "On zeroBits" $ do-            pevalOrBitsTerm-              (conTerm 0 :: Term (WordN 4))-              (ssymTerm "a")-              @=? ssymTerm "a"-            pevalOrBitsTerm-              (ssymTerm "a")-              (conTerm 0 :: Term (WordN 4))-              @=? ssymTerm "a",-          testCase "On all one bits" $ do-            pevalOrBitsTerm-              (conTerm 15 :: Term (WordN 4))-              (ssymTerm "a")-              @=? conTerm 15-            pevalOrBitsTerm-              (ssymTerm "a")-              (conTerm 15 :: Term (WordN 4))-              @=? conTerm 15,-          testCase "On symbolic" $ do-            pevalOrBitsTerm-              (ssymTerm "a" :: Term (WordN 4))-              (ssymTerm "b")-              @=? orBitsTerm-                (ssymTerm "a" :: Term (WordN 4))-                (ssymTerm "b" :: Term (WordN 4))-        ],-      testGroup-        "XorBits"-        [ testCase "On both concrete" $ do-            pevalXorBitsTerm-              (conTerm 3 :: Term (WordN 4))-              (conTerm 5)-              @=? conTerm 6,-          testCase "On zeroBits" $ do-            pevalXorBitsTerm-              (conTerm 0 :: Term (WordN 4))-              (ssymTerm "a")-              @=? ssymTerm "a"-            pevalXorBitsTerm-              (ssymTerm "a")-              (conTerm 0 :: Term (WordN 4))-              @=? ssymTerm "a",-          testCase "On all one bits" $ do-            pevalXorBitsTerm-              (conTerm 15 :: Term (WordN 4))-              (ssymTerm "a")-              @=? pevalComplementBitsTerm (ssymTerm "a")-            pevalXorBitsTerm-              (ssymTerm "a")-              (conTerm 15 :: Term (WordN 4))-              @=? pevalComplementBitsTerm (ssymTerm "a"),-          testCase "On single complement" $ do-            pevalXorBitsTerm-              (pevalComplementBitsTerm $ ssymTerm "a" :: Term (WordN 4))-              (ssymTerm "b")-              @=? pevalComplementBitsTerm (pevalXorBitsTerm (ssymTerm "a") (ssymTerm "b"))-            pevalXorBitsTerm-              (ssymTerm "a" :: Term (WordN 4))-              (pevalComplementBitsTerm $ ssymTerm "b")-              @=? pevalComplementBitsTerm (pevalXorBitsTerm (ssymTerm "a") (ssymTerm "b")),-          testCase "On both complement" $ do-            pevalXorBitsTerm-              (pevalComplementBitsTerm $ ssymTerm "a" :: Term (WordN 4))-              (pevalComplementBitsTerm $ ssymTerm "b")-              @=? pevalXorBitsTerm (ssymTerm "a") (ssymTerm "b"),-          testCase "On symbolic" $ do-            pevalXorBitsTerm-              (ssymTerm "a" :: Term (WordN 4))-              (ssymTerm "b")-              @=? xorBitsTerm-                (ssymTerm "a" :: Term (WordN 4))-                (ssymTerm "b" :: Term (WordN 4))-        ],-      testGroup-        "ComplementBits"-        [ testCase "On concrete" $ do-            pevalComplementBitsTerm (conTerm 5 :: Term (WordN 4)) @=? conTerm 10,-          testCase "On complement" $ do-            pevalComplementBitsTerm (pevalComplementBitsTerm (ssymTerm "a") :: Term (WordN 4)) @=? ssymTerm "a",-          testCase "On symbolic" $ do-            pevalComplementBitsTerm (ssymTerm "a" :: Term (WordN 4))-              @=? complementBitsTerm (ssymTerm "a" :: Term (WordN 4))-        ],-      testGroup-        "ShiftLeft"-        [ testCase "On concrete" $ do-            pevalShiftLeftTerm (conTerm 15 :: Term (WordN 4)) (conTerm 2) @=? conTerm 12-            pevalShiftLeftTerm (conTerm 15 :: Term (IntN 4)) (conTerm 2) @=? conTerm 12,-          testCase "shift 0" $ do-            pevalShiftLeftTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 0) @=? ssymTerm "a"-            pevalShiftLeftTerm (ssymTerm "a" :: Term (IntN 4)) (conTerm 0) @=? ssymTerm "a",-          testCase "shift greater or equal to left bitsize" $ do-            pevalShiftLeftTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 4) @=? conTerm 0-            pevalShiftLeftTerm (ssymTerm "a" :: Term (IntN 4)) (conTerm 4) @=? conTerm 0-            pevalShiftLeftTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 5) @=? conTerm 0-            pevalShiftLeftTerm (ssymTerm "a" :: Term (IntN 4)) (conTerm 5) @=? conTerm 0,-          testCase "shift negative amount is undefined on for IntN" $ do-            pevalShiftLeftTerm (conTerm 15 :: Term (IntN 4)) (conTerm $ -1)-              @=? shiftLeftTerm (conTerm 15) (conTerm $ -1)-            pevalShiftLeftTerm (conTerm 15 :: Term (IntN 4)) (conTerm $ -8)-              @=? shiftLeftTerm (conTerm 15) (conTerm $ -8),-          testCase "shift symbolic" $ do-            pevalShiftLeftTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 2)-              @=? shiftLeftTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 2),-          testCase "Regression: shift by very large number" $ do-            pevalShiftLeftTerm (conTerm 15 :: Term (IntN 128)) (conTerm maxBound) @=? conTerm 0-            pevalShiftLeftTerm (conTerm 15 :: Term (WordN 128)) (conTerm maxBound) @=? conTerm 0-        ],-      testGroup-        "ShiftRight"-        [ testCase "On concrete, should perform arithmetic shifting on IntN" $ do-            pevalShiftRightTerm (conTerm 7 :: Term (IntN 4)) (conTerm 2) @=? conTerm 1-            pevalShiftRightTerm (conTerm 15 :: Term (IntN 4)) (conTerm 2) @=? conTerm 15,-          testCase "On concrete, should perform logical shifting on WordN" $ do-            pevalShiftRightTerm (conTerm 7 :: Term (WordN 4)) (conTerm 2) @=? conTerm 1-            pevalShiftRightTerm (conTerm 15 :: Term (WordN 4)) (conTerm 2) @=? conTerm 3,-          testCase "shift 0" $ do-            pevalShiftRightTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 0) @=? ssymTerm "a"-            pevalShiftRightTerm (ssymTerm "a" :: Term (IntN 4)) (conTerm 0) @=? ssymTerm "a",-          testCase "shift greater or equal to left bitsize on WordN" $ do-            pevalShiftRightTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 4) @=? conTerm 0-            pevalShiftRightTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 5) @=? conTerm 0,-          testCase "shift greater or equal to left bitsize on IntN will not be reduced" $ do-            pevalShiftRightTerm (ssymTerm "a" :: Term (IntN 4)) (conTerm 5)-              @=? shiftRightTerm (ssymTerm "a") (conTerm 5)-            pevalShiftRightTerm (ssymTerm "a" :: Term (IntN 4)) (conTerm 4)-              @=? shiftRightTerm (ssymTerm "a") (conTerm 4),-          testCase "shift negative amount is undefined on for IntN" $ do-            pevalShiftRightTerm (conTerm 15 :: Term (IntN 4)) (conTerm $ -1)-              @=? shiftRightTerm (conTerm 15) (conTerm $ -1)-            pevalShiftRightTerm (conTerm 15 :: Term (IntN 4)) (conTerm $ -8)-              @=? shiftRightTerm (conTerm 15) (conTerm $ -8),-          testCase "shift symbolic" $ do-            pevalShiftRightTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 2)-              @=? shiftRightTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 2),-          testCase "Regression: shift by very large number" $ do-            pevalShiftRightTerm (conTerm 15 :: Term (IntN 128)) (conTerm maxBound) @=? conTerm 0-            pevalShiftRightTerm (conTerm 15 :: Term (WordN 128)) (conTerm maxBound) @=? conTerm 0-        ],-      testGroup-        "RotateLeft"-        [ testCase "On concrete" $ do-            pevalRotateLeftTerm (conTerm 0b10100101 :: Term (WordN 8)) (conTerm 2) @=? conTerm 0b10010110-            pevalRotateLeftTerm (conTerm 0b10100101 :: Term (IntN 8)) (conTerm 2) @=? conTerm 0b10010110,-          testCase "rotate 0" $ do-            pevalRotateLeftTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 0) @=? ssymTerm "a"-            pevalRotateLeftTerm (ssymTerm "a" :: Term (IntN 4)) (conTerm 0) @=? ssymTerm "a",-          testCase "rotate bitsize" $ do-            pevalRotateLeftTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 4)-              @=? ssymTerm "a"-            pevalRotateLeftTerm (ssymTerm "a" :: Term (IntN 4)) (conTerm 4)-              @=? ssymTerm "a",-          testCase "rotate greater than left bitsize" $ do-            pevalRotateLeftTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 5)-              @=? rotateLeftTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 1)-            pevalRotateLeftTerm (ssymTerm "a" :: Term (IntN 4)) (conTerm 5)-              @=? rotateLeftTerm (ssymTerm "a" :: Term (IntN 4)) (conTerm 1),-          testCase "rotate negative amount is undefined on for IntN" $ do-            pevalRotateLeftTerm (conTerm 15 :: Term (IntN 4)) (conTerm $ -1)-              @=? rotateLeftTerm (conTerm 15) (conTerm $ -1)-            pevalRotateLeftTerm (conTerm 15 :: Term (IntN 4)) (conTerm $ -8)-              @=? rotateLeftTerm (conTerm 15) (conTerm $ -8),-          testCase "rotate symbolic" $ do-            pevalRotateLeftTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 2)-              @=? rotateLeftTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 2),-          testCase "Regression: rotate by very large number" $ do-            pevalRotateLeftTerm (conTerm 15 :: Term (IntN 128)) (conTerm maxBound) @=? conTerm (rotateR 15 1)-            pevalRotateLeftTerm (conTerm 15 :: Term (WordN 128)) (conTerm maxBound) @=? conTerm (rotateR 15 1)-        ],-      testGroup-        "RotateRight"-        [ testProperty "On concrete WordN 1" $-            concreteSmallRotateRightCorrect @(WordN 1),-          testProperty "On concrete WordN 2" $-            concreteSmallRotateRightCorrect @(WordN 2),-          testProperty "On concrete WordN 3" $-            concreteSmallRotateRightCorrect @(WordN 3),-          testProperty "On concrete WordN 4" $-            concreteSmallRotateRightCorrect @(WordN 4),-          testProperty "On concrete WordN 8" $-            concreteSmallRotateRightCorrect @(WordN 8),-          testProperty "On concrete IntN 1" $-            concreteSmallRotateRightCorrect @(IntN 1),-          testProperty "On concrete IntN 2" $-            concreteSmallRotateRightCorrect @(IntN 2),-          testProperty "On concrete IntN 3" $-            concreteSmallRotateRightCorrect @(IntN 3),-          testProperty "On concrete IntN 4" $-            concreteSmallRotateRightCorrect @(IntN 4),-          testProperty "On concrete IntN 8" $-            concreteSmallRotateRightCorrect @(IntN 8),-          testCase "rotate 0" $ do-            pevalRotateRightTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 0) @=? ssymTerm "a"-            pevalRotateRightTerm (ssymTerm "a" :: Term (IntN 4)) (conTerm 0) @=? ssymTerm "a",-          testCase "rotate bitsize" $ do-            pevalRotateRightTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 4)-              @=? ssymTerm "a"-            pevalRotateRightTerm (ssymTerm "a" :: Term (IntN 4)) (conTerm 4)-              @=? ssymTerm "a",-          testCase "rotate greater than left bitsize" $ do-            pevalRotateRightTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 5)-              @=? rotateRightTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 1)-            pevalRotateRightTerm (ssymTerm "a" :: Term (IntN 4)) (conTerm 5)-              @=? rotateRightTerm (ssymTerm "a" :: Term (IntN 4)) (conTerm 1),-          testCase "rotate negative amount is undefined on for IntN" $ do-            pevalRotateRightTerm (conTerm 15 :: Term (IntN 4)) (conTerm $ -1)-              @=? rotateRightTerm (conTerm 15) (conTerm $ -1)-            pevalRotateRightTerm (conTerm 15 :: Term (IntN 4)) (conTerm $ -8)-              @=? rotateRightTerm (conTerm 15) (conTerm $ -8),-          testCase "rotate symbolic" $ do-            pevalRotateRightTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 2)-              @=? rotateRightTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 2),-          testCase "Regression: rotate by very large number" $ do-            pevalRotateRightTerm (conTerm 15 :: Term (IntN 128)) (conTerm maxBound) @=? conTerm (rotateL 15 1)-            pevalRotateRightTerm (conTerm 15 :: Term (WordN 128)) (conTerm maxBound) @=? conTerm (rotateL 15 1)-        ]-    ]--concreteSmallRotateRightCorrect ::-  (SupportedPrim a, Integral a, FiniteBits a, SymRotate a) =>-  a ->-  a ->-  Property-concreteSmallRotateRightCorrect _ b | b < 0 = discard-concreteSmallRotateRightCorrect a b = ioProperty $ do-  pevalRotateRightTerm (conTerm a) (conTerm b)-    @=? conTerm (rotateR a (fromIntegral b))
− test/Grisette/IR/SymPrim/Data/Prim/BoolTests.hs 
@@ -1,738 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Grisette.IR.SymPrim.Data.Prim.BoolTests (boolTests) where--import Grisette.Core.Data.BV (IntN, WordN)-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors-  ( andTerm,-    conTerm,-    eqvTerm,-    notTerm,-    orTerm,-    ssymTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term (Term)-import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool-  ( pevalAndTerm,-    pevalEqvTerm,-    pevalITETerm,-    pevalImplyTerm,-    pevalNotEqvTerm,-    pevalNotTerm,-    pevalOrTerm,-    pevalXorTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.PartialEval.Num-  ( pevalAddNumTerm,-  )-import Test.Framework (Test, testGroup)-import Test.Framework.Providers.HUnit (testCase)-import Test.HUnit ((@=?))--boolTests :: Test-boolTests =-  testGroup-    "Bool"-    [ testGroup-        "Not"-        [ testCase "On concrete" $ do-            pevalNotTerm (conTerm True) @=? conTerm False-            pevalNotTerm (conTerm True) @=? conTerm False,-          testCase "On general symbolic" $ do-            pevalNotTerm (ssymTerm "a") @=? notTerm (ssymTerm "a" :: Term Bool),-          testCase "On Not" $ do-            pevalNotTerm (pevalNotTerm (ssymTerm "a")) @=? ssymTerm "a",-          testCase "On Or Not" $ do-            pevalNotTerm (pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b"))-              @=? pevalAndTerm (ssymTerm "a") (pevalNotTerm (ssymTerm "b"))-            pevalNotTerm (pevalOrTerm (ssymTerm "a") (pevalNotTerm (ssymTerm "b")))-              @=? pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b"),-          testCase "On And Not" $ do-            pevalNotTerm (pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b"))-              @=? pevalOrTerm (ssymTerm "a") (pevalNotTerm (ssymTerm "b"))-            pevalNotTerm (pevalAndTerm (ssymTerm "a") (pevalNotTerm (ssymTerm "b")))-              @=? pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")-        ],-      testGroup-        "Eqv & NEqv"-        [ testCase "Eqv on both concrete" $ do-            pevalEqvTerm (conTerm True) (conTerm True) @=? conTerm True-            pevalEqvTerm (conTerm True) (conTerm False) @=? conTerm False-            pevalEqvTerm (conTerm False) (conTerm True) @=? conTerm False-            pevalEqvTerm (conTerm False) (conTerm False) @=? conTerm True-            pevalEqvTerm (conTerm (1 :: Integer)) (conTerm 1) @=? conTerm True-            pevalEqvTerm (conTerm (1 :: Integer)) (conTerm 2) @=? conTerm False-            pevalEqvTerm (conTerm (1 :: IntN 4)) (conTerm 1) @=? conTerm True-            pevalEqvTerm (conTerm (1 :: IntN 4)) (conTerm 2) @=? conTerm False-            pevalEqvTerm (conTerm (1 :: WordN 4)) (conTerm 1) @=? conTerm True-            pevalEqvTerm (conTerm (1 :: WordN 4)) (conTerm 2) @=? conTerm False,-          testCase "Eqv on single concrete always put concrete ones in the right" $ do-            pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)-              @=? eqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1 :: Term Integer)-            pevalEqvTerm (conTerm 1) (ssymTerm "a" :: Term Integer)-              @=? eqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1 :: Term Integer),-          testCase "Eqv on general symbolic" $ do-            pevalEqvTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b")-              @=? eqvTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b" :: Term Integer),-          testCase "Eqv on Bool with single concrete" $ do-            pevalEqvTerm (conTerm True) (ssymTerm "a") @=? ssymTerm "a"-            pevalEqvTerm (ssymTerm "a") (conTerm True) @=? ssymTerm "a"-            pevalEqvTerm (conTerm False) (ssymTerm "a") @=? pevalNotTerm (ssymTerm "a")-            pevalEqvTerm (ssymTerm "a") (conTerm False) @=? pevalNotTerm (ssymTerm "a"),-          testCase "NEqv on general symbolic" $ do-            pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b")-              @=? pevalNotTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b")),-          testCase "Eqv(Not(x), x) / Eqv(x, Not(x))" $ do-            pevalEqvTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "a") @=? conTerm False-            pevalEqvTerm (ssymTerm "a") (pevalNotTerm (ssymTerm "a")) @=? conTerm False,-          testCase "Eqv(n1+x, n2)" $ do-            pevalEqvTerm (pevalAddNumTerm (conTerm 1 :: Term Integer) (ssymTerm "a")) (conTerm 3)-              @=? pevalEqvTerm (ssymTerm "a") (conTerm 2 :: Term Integer)-            pevalEqvTerm (pevalAddNumTerm (conTerm 1 :: Term (IntN 4)) (ssymTerm "a")) (conTerm 3)-              @=? pevalEqvTerm (ssymTerm "a") (conTerm 2 :: Term (IntN 4))-            pevalEqvTerm (pevalAddNumTerm (conTerm 1 :: Term (WordN 4)) (ssymTerm "a")) (conTerm 3)-              @=? pevalEqvTerm (ssymTerm "a") (conTerm 2 :: Term (WordN 4)),-          testCase "Eqv(n1, n2+x)" $ do-            pevalEqvTerm (conTerm 3) (pevalAddNumTerm (conTerm 1 :: Term Integer) (ssymTerm "a"))-              @=? pevalEqvTerm (ssymTerm "a") (conTerm 2 :: Term Integer)-            pevalEqvTerm (conTerm 3) (pevalAddNumTerm (conTerm 1 :: Term (IntN 4)) (ssymTerm "a"))-              @=? pevalEqvTerm (ssymTerm "a") (conTerm 2 :: Term (IntN 4))-            pevalEqvTerm (conTerm 3) (pevalAddNumTerm (conTerm 1 :: Term (WordN 4)) (ssymTerm "a"))-              @=? pevalEqvTerm (ssymTerm "a") (conTerm 2 :: Term (WordN 4)),-          testCase "Eqv(l, ITE(c, l, f)) / Eqv(l, ITE(c, t, l) / Eqv(ITE(c, r, f), r) / Eqv(ITE(c, t, r), r)" $ do-            pevalEqvTerm (ssymTerm "a" :: Term Integer) (pevalITETerm (ssymTerm "b") (ssymTerm "a") (ssymTerm "c"))-              @=? pevalOrTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "a") (ssymTerm "c" :: Term Integer))-            pevalEqvTerm (ssymTerm "a" :: Term Integer) (pevalITETerm (ssymTerm "b") (ssymTerm "c") (ssymTerm "a"))-              @=? pevalOrTerm (pevalNotTerm $ ssymTerm "b") (pevalEqvTerm (ssymTerm "a") (ssymTerm "c" :: Term Integer))-            pevalEqvTerm (pevalITETerm (ssymTerm "b") (ssymTerm "a") (ssymTerm "c")) (ssymTerm "a" :: Term Integer)-              @=? pevalOrTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "c") (ssymTerm "a" :: Term Integer))-            pevalEqvTerm (pevalITETerm (ssymTerm "b") (ssymTerm "c") (ssymTerm "a")) (ssymTerm "a" :: Term Integer)-              @=? pevalOrTerm (pevalNotTerm $ ssymTerm "b") (pevalEqvTerm (ssymTerm "c") (ssymTerm "a" :: Term Integer))-        ],-      testGroup-        "Or"-        [ testCase "On both concrete" $ do-            pevalOrTerm (conTerm True) (conTerm True) @=? conTerm True-            pevalOrTerm (conTerm True) (conTerm False) @=? conTerm True-            pevalOrTerm (conTerm False) (conTerm True) @=? conTerm True-            pevalOrTerm (conTerm False) (conTerm False) @=? conTerm False,-          testCase "On general symbolic" $ do-            pevalOrTerm (ssymTerm "a") (ssymTerm "b")-              @=? orTerm (ssymTerm "a" :: Term Bool) (ssymTerm "b" :: Term Bool),-          testCase "Or(x, y) -> True" $ do-            pevalOrTerm (conTerm True) (ssymTerm "b") @=? conTerm True-            pevalOrTerm (ssymTerm "a") (conTerm True) @=? conTerm True-            pevalOrTerm-              (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))-              (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))-              @=? conTerm True-            pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "a") @=? conTerm True-            pevalOrTerm (ssymTerm "a") (pevalNotTerm (ssymTerm "a")) @=? conTerm True,-          testCase "Or(x, y) -> x" $ do-            pevalOrTerm (ssymTerm "a") (conTerm False) @=? ssymTerm "a"-            pevalOrTerm-              (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))-              (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))-              @=? pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)-            pevalOrTerm (ssymTerm "a") (ssymTerm "a") @=? ssymTerm "a",-          testCase "Or(x, y) -> y" $ do-            pevalOrTerm (conTerm False) (ssymTerm "a") @=? ssymTerm "a"-            pevalOrTerm-              (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))-              (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))-              @=? pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1),-          testCase "Or(x, Or(y1, y2)) -> True" $ do-            pevalOrTerm (pevalNotTerm (ssymTerm "a")) (pevalOrTerm (ssymTerm "a") (ssymTerm "b")) @=? conTerm True-            pevalOrTerm (ssymTerm "a") (pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")) @=? conTerm True-            pevalOrTerm-              (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))-              (pevalOrTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b"))-              @=? conTerm True--            pevalOrTerm (pevalNotTerm (ssymTerm "a")) (pevalOrTerm (ssymTerm "b") (ssymTerm "a")) @=? conTerm True-            pevalOrTerm (ssymTerm "a") (pevalOrTerm (ssymTerm "b") (pevalNotTerm (ssymTerm "a"))) @=? conTerm True-            pevalOrTerm-              (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))-              (pevalOrTerm (ssymTerm "b") (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)))-              @=? conTerm True,-          testCase "Or(x, Or(y1, y2)) -> Or(x, y2)" $ do-            pevalOrTerm-              (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))-              (pevalOrTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b"))-              @=? pevalOrTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"),-          testCase "Or(x, Or(y1, y2)) -> Or(x, y1)" $ do-            pevalOrTerm-              (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))-              (pevalOrTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)))-              @=? pevalOrTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"),-          testCase "Or(x, y@Or(y1, y2)) -> y" $ do-            pevalOrTerm (ssymTerm "a") (pevalOrTerm (ssymTerm "a") (ssymTerm "b"))-              @=? pevalOrTerm (ssymTerm "a") (ssymTerm "b")-            pevalOrTerm-              (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))-              (pevalOrTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"))-              @=? pevalOrTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b")-            pevalOrTerm (ssymTerm "a") (pevalOrTerm (ssymTerm "b") (ssymTerm "a"))-              @=? pevalOrTerm (ssymTerm "b") (ssymTerm "a")-            pevalOrTerm-              (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))-              (pevalOrTerm (ssymTerm "b") (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)))-              @=? pevalOrTerm (ssymTerm "b") (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)),-          testCase "Or(Or(x1, x2), y) -> True" $ do-            pevalOrTerm (pevalOrTerm (ssymTerm "a") (ssymTerm "b")) (pevalNotTerm (ssymTerm "a")) @=? conTerm True-            pevalOrTerm (pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")) (ssymTerm "a") @=? conTerm True-            pevalOrTerm-              (pevalOrTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b"))-              (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))-              @=? conTerm True--            pevalOrTerm (pevalOrTerm (ssymTerm "b") (ssymTerm "a")) (pevalNotTerm (ssymTerm "a")) @=? conTerm True-            pevalOrTerm (pevalOrTerm (ssymTerm "b") (pevalNotTerm (ssymTerm "a"))) (ssymTerm "a") @=? conTerm True-            pevalOrTerm-              (pevalOrTerm (ssymTerm "b") (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)))-              (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))-              @=? conTerm True,-          testCase "Or(x@Or(x1, x2), y) -> x" $ do-            pevalOrTerm (pevalOrTerm (ssymTerm "a") (ssymTerm "b")) (ssymTerm "a")-              @=? pevalOrTerm (ssymTerm "a") (ssymTerm "b")-            pevalOrTerm-              (pevalOrTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"))-              (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))-              @=? pevalOrTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b")-            pevalOrTerm (pevalOrTerm (ssymTerm "b") (ssymTerm "a")) (ssymTerm "a")-              @=? pevalOrTerm (ssymTerm "b") (ssymTerm "a")-            pevalOrTerm-              (pevalOrTerm (ssymTerm "b") (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)))-              (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))-              @=? pevalOrTerm (ssymTerm "b") (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)),-          testCase "Or(Or(x1, x2), y) -> Or(x2, y)" $ do-            pevalOrTerm-              (pevalOrTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b"))-              (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))-              @=? pevalOrTerm (ssymTerm "b") (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)),-          testCase "Or(Or(x1, x2), y) -> Or(x1, y)" $ do-            pevalOrTerm-              (pevalOrTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)))-              (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))-              @=? pevalOrTerm (ssymTerm "b") (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)),-          testCase "Or(x, And(y1, y2)) -> x" $ do-            pevalOrTerm-              (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))-              (pevalAndTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b"))-              @=? pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)-            pevalOrTerm-              (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))-              (pevalAndTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)))-              @=? pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1),-          testCase "Or(x, And(y1, y2)) -> Or(x, y2)" $ do-            pevalOrTerm (ssymTerm "a") (pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b"))-              @=? pevalOrTerm (ssymTerm "a") (ssymTerm "b")-            pevalOrTerm (pevalNotTerm (ssymTerm "a")) (pevalAndTerm (ssymTerm "a") (ssymTerm "b"))-              @=? pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")-            pevalOrTerm-              (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))-              (pevalAndTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b"))-              @=? pevalOrTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"),-          testCase "Or(And(x1, x2), y) -> y" $ do-            pevalOrTerm-              (pevalAndTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b"))-              (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))-              @=? pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)-            pevalOrTerm-              (pevalAndTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)))-              (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))-              @=? pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1),-          testCase "Or(x, And(y1, y2)) -> Or(x, y1)" $ do-            pevalOrTerm (ssymTerm "a") (pevalAndTerm (ssymTerm "b") (pevalNotTerm (ssymTerm "a")))-              @=? pevalOrTerm (ssymTerm "a") (ssymTerm "b")-            pevalOrTerm (pevalNotTerm (ssymTerm "a")) (pevalAndTerm (ssymTerm "b") (ssymTerm "a"))-              @=? pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")-            pevalOrTerm-              (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))-              (pevalAndTerm (ssymTerm "b") (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)))-              @=? pevalOrTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"),-          testCase "Or(Not(x), Not(y)) -> Not(And(x, y))" $ do-            pevalOrTerm (pevalNotTerm (ssymTerm "a")) (pevalNotTerm (ssymTerm "b"))-              @=? pevalNotTerm (pevalAndTerm (ssymTerm "a") (ssymTerm "b"))-        ],-      testGroup-        "And"-        [ testCase "Oith both concrete" $ do-            pevalAndTerm (conTerm True) (conTerm True) @=? conTerm True-            pevalAndTerm (conTerm True) (conTerm False) @=? conTerm False-            pevalAndTerm (conTerm False) (conTerm True) @=? conTerm False-            pevalAndTerm (conTerm False) (conTerm False) @=? conTerm False,-          testCase "On general symbolic" $ do-            pevalAndTerm (ssymTerm "a") (ssymTerm "b")-              @=? andTerm (ssymTerm "a" :: Term Bool) (ssymTerm "b" :: Term Bool),-          testCase "And(x, y) -> False" $ do-            pevalAndTerm (conTerm False) (ssymTerm "b") @=? conTerm False-            pevalAndTerm (ssymTerm "a") (conTerm False) @=? conTerm False-            pevalAndTerm-              (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))-              (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))-              @=? conTerm False-            pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "a") @=? conTerm False-            pevalAndTerm (ssymTerm "a") (pevalNotTerm (ssymTerm "a")) @=? conTerm False,-          testCase "And(x, y) -> x" $ do-            pevalAndTerm (ssymTerm "a") (conTerm True) @=? ssymTerm "a"-            pevalAndTerm-              (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))-              (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))-              @=? pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)-            pevalAndTerm (ssymTerm "a") (ssymTerm "a") @=? ssymTerm "a",-          testCase "And(x, y) -> y" $ do-            pevalAndTerm (conTerm True) (ssymTerm "a") @=? ssymTerm "a"-            pevalAndTerm-              (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))-              (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))-              @=? pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1),-          testCase "And(x, And(y1, y2)) -> False" $ do-            pevalAndTerm (pevalNotTerm (ssymTerm "a")) (pevalAndTerm (ssymTerm "a") (ssymTerm "b")) @=? conTerm False-            pevalAndTerm (ssymTerm "a") (pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")) @=? conTerm False-            pevalAndTerm-              (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))-              (pevalAndTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b"))-              @=? conTerm False--            pevalAndTerm (pevalNotTerm (ssymTerm "a")) (pevalAndTerm (ssymTerm "b") (ssymTerm "a")) @=? conTerm False-            pevalAndTerm (ssymTerm "a") (pevalAndTerm (ssymTerm "b") (pevalNotTerm (ssymTerm "a"))) @=? conTerm False-            pevalAndTerm-              (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))-              (pevalAndTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)))-              @=? conTerm False,-          testCase "And(x, And(y1, y2)) -> And(x, y2)" $ do-            pevalAndTerm-              (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))-              (pevalAndTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b"))-              @=? pevalAndTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"),-          testCase "And(x, And(y1, y2)) -> And(x, y1)" $ do-            pevalAndTerm-              (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))-              (pevalAndTerm (ssymTerm "b") (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)))-              @=? pevalAndTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"),-          testCase "And(x, y@And(y1, y2)) -> y" $ do-            pevalAndTerm (ssymTerm "a") (pevalAndTerm (ssymTerm "a") (ssymTerm "b"))-              @=? pevalAndTerm (ssymTerm "a") (ssymTerm "b")-            pevalAndTerm-              (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))-              (pevalAndTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"))-              @=? pevalAndTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b")-            pevalAndTerm (ssymTerm "a") (pevalAndTerm (ssymTerm "b") (ssymTerm "a"))-              @=? pevalAndTerm (ssymTerm "b") (ssymTerm "a")-            pevalAndTerm-              (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))-              (pevalAndTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)))-              @=? pevalAndTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)),-          testCase "And(And(x1, x2), y) -> False" $ do-            pevalAndTerm (pevalAndTerm (ssymTerm "a") (ssymTerm "b")) (pevalNotTerm (ssymTerm "a")) @=? conTerm False-            pevalAndTerm (pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")) (ssymTerm "a") @=? conTerm False-            pevalAndTerm-              (pevalAndTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b"))-              (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))-              @=? conTerm False--            pevalAndTerm (pevalAndTerm (ssymTerm "b") (ssymTerm "a")) (pevalNotTerm (ssymTerm "a")) @=? conTerm False-            pevalAndTerm (pevalAndTerm (ssymTerm "b") (pevalNotTerm (ssymTerm "a"))) (ssymTerm "a") @=? conTerm False-            pevalAndTerm-              (pevalAndTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)))-              (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))-              @=? conTerm False,-          testCase "And(x@And(x1, x2), y) -> x" $ do-            pevalAndTerm (pevalAndTerm (ssymTerm "a") (ssymTerm "b")) (ssymTerm "a")-              @=? pevalAndTerm (ssymTerm "a") (ssymTerm "b")-            pevalAndTerm-              (pevalAndTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"))-              (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))-              @=? pevalAndTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b")-            pevalAndTerm (pevalAndTerm (ssymTerm "b") (ssymTerm "a")) (ssymTerm "a")-              @=? pevalAndTerm (ssymTerm "b") (ssymTerm "a")-            pevalAndTerm-              (pevalAndTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)))-              (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))-              @=? pevalAndTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)),-          testCase "And(And(x1, x2), y) -> And(x2, y)" $ do-            pevalAndTerm-              (pevalAndTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b"))-              (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))-              @=? pevalAndTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)),-          testCase "And(And(x1, x2), y) -> And(x1, y)" $ do-            pevalAndTerm-              (pevalAndTerm (ssymTerm "b") (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)))-              (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))-              @=? pevalAndTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)),-          testCase "And(x, Or(y1, y2)) -> x" $ do-            pevalAndTerm-              (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))-              (pevalOrTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b"))-              @=? pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)-            pevalAndTerm-              (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))-              (pevalOrTerm (ssymTerm "b") (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)))-              @=? pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1),-          testCase "And(x, Or(y1, y2)) -> And(x, y2)" $ do-            pevalAndTerm (ssymTerm "a") (pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b"))-              @=? pevalAndTerm (ssymTerm "a") (ssymTerm "b")-            pevalAndTerm (pevalNotTerm (ssymTerm "a")) (pevalOrTerm (ssymTerm "a") (ssymTerm "b"))-              @=? pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")-            pevalAndTerm-              (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))-              (pevalOrTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b"))-              @=? pevalAndTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"),-          testCase "And(Or(x1, x2), y) -> y" $ do-            pevalAndTerm-              (pevalOrTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b"))-              (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))-              @=? pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)-            pevalAndTerm-              (pevalOrTerm (ssymTerm "b") (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)))-              (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))-              @=? pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1),-          testCase "And(x, Or(y1, y2)) -> And(x, y1)" $ do-            pevalAndTerm (ssymTerm "a") (pevalOrTerm (ssymTerm "b") (pevalNotTerm (ssymTerm "a")))-              @=? pevalAndTerm (ssymTerm "a") (ssymTerm "b")-            pevalAndTerm (pevalNotTerm (ssymTerm "a")) (pevalOrTerm (ssymTerm "b") (ssymTerm "a"))-              @=? pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")-            pevalAndTerm-              (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))-              (pevalOrTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)))-              @=? pevalAndTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"),-          testCase "And(Not(x), Not(y)) -> Not(Or(x, y))" $ do-            pevalAndTerm (pevalNotTerm (ssymTerm "a")) (pevalNotTerm (ssymTerm "b"))-              @=? pevalNotTerm (pevalOrTerm (ssymTerm "a") (ssymTerm "b"))-        ],-      testGroup-        "ITE"-        [ testCase "On concrete condition" $ do-            pevalITETerm (conTerm True) (ssymTerm "a" :: Term Integer) (ssymTerm "b")-              @=? ssymTerm "a"-            pevalITETerm (conTerm False) (ssymTerm "a" :: Term Integer) (ssymTerm "b")-              @=? ssymTerm "b",-          testCase "On same branches" $ do-            pevalITETerm (ssymTerm "c") (ssymTerm "a" :: Term Integer) (ssymTerm "a")-              @=? ssymTerm "a",-          testCase "On both not" $ do-            pevalITETerm (ssymTerm "c") (pevalNotTerm $ ssymTerm "a") (pevalNotTerm $ ssymTerm "b")-              @=? pevalNotTerm (pevalITETerm (ssymTerm "c") (ssymTerm "a") (ssymTerm "b")),-          testCase "On not in condition" $ do-            pevalITETerm (pevalNotTerm $ ssymTerm "c") (ssymTerm "a" :: Term Integer) (ssymTerm "b")-              @=? pevalITETerm (ssymTerm "c") (ssymTerm "b") (ssymTerm "a"),-          testCase "On all arguments as ITE with same conditions" $ do-            pevalITETerm-              (pevalITETerm (ssymTerm "a") (ssymTerm "b") (ssymTerm "c"))-              (pevalITETerm (ssymTerm "a") (ssymTerm "d" :: Term Integer) (ssymTerm "e"))-              (pevalITETerm (ssymTerm "a") (ssymTerm "f" :: Term Integer) (ssymTerm "g"))-              @=? pevalITETerm-                (ssymTerm "a")-                (pevalITETerm (ssymTerm "b") (ssymTerm "d") (ssymTerm "f"))-                (pevalITETerm (ssymTerm "c") (ssymTerm "e") (ssymTerm "g")),-          testCase "On with true branch as ITE" $ do-            pevalITETerm-              (ssymTerm "a")-              (pevalITETerm (ssymTerm "a") (ssymTerm "b" :: Term Integer) (ssymTerm "c"))-              (ssymTerm "d")-              @=? pevalITETerm (ssymTerm "a") (ssymTerm "b") (ssymTerm "d")-            pevalITETerm-              (ssymTerm "a")-              (pevalITETerm (ssymTerm "b") (ssymTerm "c" :: Term Integer) (ssymTerm "d"))-              (ssymTerm "c")-              @=? pevalITETerm-                (pevalOrTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b"))-                (ssymTerm "c")-                (ssymTerm "d")-            pevalITETerm-              (ssymTerm "a")-              (pevalITETerm (ssymTerm "b") (ssymTerm "c" :: Term Integer) (ssymTerm "d"))-              (ssymTerm "d")-              @=? pevalITETerm-                (pevalAndTerm (ssymTerm "a") (ssymTerm "b"))-                (ssymTerm "c")-                (ssymTerm "d"),-          testCase "On false branch as ITE" $ do-            pevalITETerm-              (ssymTerm "a")-              (ssymTerm "b")-              (pevalITETerm (ssymTerm "a") (ssymTerm "c" :: Term Integer) (ssymTerm "d"))-              @=? pevalITETerm (ssymTerm "a") (ssymTerm "b") (ssymTerm "d")-            pevalITETerm-              (ssymTerm "a")-              (ssymTerm "b")-              (pevalITETerm (ssymTerm "c") (ssymTerm "b" :: Term Integer) (ssymTerm "d"))-              @=? pevalITETerm-                (pevalOrTerm (ssymTerm "a") (ssymTerm "c"))-                (ssymTerm "b")-                (ssymTerm "d")-            pevalITETerm-              (ssymTerm "a")-              (ssymTerm "b")-              (pevalITETerm (ssymTerm "c") (ssymTerm "d" :: Term Integer) (ssymTerm "b"))-              @=? pevalITETerm-                (pevalOrTerm (ssymTerm "a") (pevalNotTerm $ ssymTerm "c"))-                (ssymTerm "b")-                (ssymTerm "d"),-          testCase "On both And" $ do-            pevalITETerm-              (ssymTerm "a")-              (pevalAndTerm (ssymTerm "b") (ssymTerm "c"))-              (pevalAndTerm (ssymTerm "b") (ssymTerm "d"))-              @=? pevalAndTerm (ssymTerm "b") (pevalITETerm (ssymTerm "a") (ssymTerm "c") (ssymTerm "d"))-            pevalITETerm-              (ssymTerm "a")-              (pevalAndTerm (ssymTerm "c") (ssymTerm "b"))-              (pevalAndTerm (ssymTerm "b") (ssymTerm "d"))-              @=? pevalAndTerm (ssymTerm "b") (pevalITETerm (ssymTerm "a") (ssymTerm "c") (ssymTerm "d"))-            pevalITETerm-              (ssymTerm "a")-              (pevalAndTerm (ssymTerm "b") (ssymTerm "c"))-              (pevalAndTerm (ssymTerm "d") (ssymTerm "b"))-              @=? pevalAndTerm (ssymTerm "b") (pevalITETerm (ssymTerm "a") (ssymTerm "c") (ssymTerm "d"))-            pevalITETerm-              (ssymTerm "a")-              (pevalAndTerm (ssymTerm "c") (ssymTerm "b"))-              (pevalAndTerm (ssymTerm "d") (ssymTerm "b"))-              @=? pevalAndTerm (ssymTerm "b") (pevalITETerm (ssymTerm "a") (ssymTerm "c") (ssymTerm "d")),-          testCase "On left And" $ do-            pevalITETerm-              (ssymTerm "a")-              (pevalAndTerm (ssymTerm "b") (ssymTerm "c"))-              (ssymTerm "b")-              @=? pevalAndTerm (ssymTerm "b") (pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "c"))-            pevalITETerm-              (ssymTerm "a")-              (pevalAndTerm (ssymTerm "b") (ssymTerm "c"))-              (ssymTerm "c")-              @=? pevalAndTerm (ssymTerm "c") (pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b"))-            pevalITETerm-              (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))-              (pevalAndTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b"))-              (ssymTerm "c")-              @=? pevalAndTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "c")-            pevalITETerm-              (ssymTerm "a")-              (pevalAndTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b"))-              (ssymTerm "c")-              @=? pevalAndTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "c")-            pevalITETerm-              (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))-              (pevalAndTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)))-              (ssymTerm "c")-              @=? pevalAndTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "c")-            pevalITETerm-              (ssymTerm "a")-              (pevalAndTerm (ssymTerm "b") (pevalNotTerm $ ssymTerm "a"))-              (ssymTerm "c")-              @=? pevalAndTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "c")-            pevalITETerm-              (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))-              (pevalAndTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b"))-              (ssymTerm "c")-              @=? pevalITETerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b") (ssymTerm "c")-            pevalITETerm-              (ssymTerm "a")-              (pevalAndTerm (ssymTerm "a") (ssymTerm "b"))-              (ssymTerm "c")-              @=? pevalITETerm (ssymTerm "a") (ssymTerm "b") (ssymTerm "c")-            pevalITETerm-              (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))-              (pevalAndTerm (ssymTerm "b") (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)))-              (ssymTerm "c")-              @=? pevalITETerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b") (ssymTerm "c")-            pevalITETerm-              (ssymTerm "a")-              (pevalAndTerm (ssymTerm "b") (ssymTerm "a"))-              (ssymTerm "c")-              @=? pevalITETerm (ssymTerm "a") (ssymTerm "b") (ssymTerm "c"),-          testCase "On right And" $ do-            pevalITETerm-              (ssymTerm "a")-              (ssymTerm "b")-              (pevalAndTerm (ssymTerm "b") (ssymTerm "c"))-              @=? pevalAndTerm (ssymTerm "b") (pevalOrTerm (ssymTerm "a") (ssymTerm "c"))-            pevalITETerm-              (ssymTerm "a")-              (ssymTerm "c")-              (pevalAndTerm (ssymTerm "b") (ssymTerm "c"))-              @=? pevalAndTerm (ssymTerm "c") (pevalOrTerm (ssymTerm "a") (ssymTerm "b")),-          testCase "On both Or" $ do-            pevalITETerm-              (ssymTerm "a")-              (pevalOrTerm (ssymTerm "b") (ssymTerm "c"))-              (pevalOrTerm (ssymTerm "b") (ssymTerm "d"))-              @=? pevalOrTerm (ssymTerm "b") (pevalITETerm (ssymTerm "a") (ssymTerm "c") (ssymTerm "d"))-            pevalITETerm-              (ssymTerm "a")-              (pevalOrTerm (ssymTerm "c") (ssymTerm "b"))-              (pevalOrTerm (ssymTerm "b") (ssymTerm "d"))-              @=? pevalOrTerm (ssymTerm "b") (pevalITETerm (ssymTerm "a") (ssymTerm "c") (ssymTerm "d"))-            pevalITETerm-              (ssymTerm "a")-              (pevalOrTerm (ssymTerm "b") (ssymTerm "c"))-              (pevalOrTerm (ssymTerm "d") (ssymTerm "b"))-              @=? pevalOrTerm (ssymTerm "b") (pevalITETerm (ssymTerm "a") (ssymTerm "c") (ssymTerm "d"))-            pevalITETerm-              (ssymTerm "a")-              (pevalOrTerm (ssymTerm "c") (ssymTerm "b"))-              (pevalOrTerm (ssymTerm "d") (ssymTerm "b"))-              @=? pevalOrTerm (ssymTerm "b") (pevalITETerm (ssymTerm "a") (ssymTerm "c") (ssymTerm "d")),-          testCase "On left Or" $ do-            pevalITETerm-              (ssymTerm "a")-              (pevalOrTerm (ssymTerm "b") (ssymTerm "c"))-              (ssymTerm "b")-              @=? pevalOrTerm (ssymTerm "b") (pevalAndTerm (ssymTerm "a") (ssymTerm "c"))-            pevalITETerm-              (ssymTerm "a")-              (pevalOrTerm (ssymTerm "b") (ssymTerm "c"))-              (ssymTerm "c")-              @=? pevalOrTerm (ssymTerm "c") (pevalAndTerm (ssymTerm "a") (ssymTerm "b"))-            pevalITETerm-              (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))-              (pevalOrTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b"))-              (ssymTerm "c")-              @=? pevalITETerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b") (ssymTerm "c")-            pevalITETerm-              (ssymTerm "a")-              (pevalOrTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b"))-              (ssymTerm "c")-              @=? pevalITETerm (ssymTerm "a") (ssymTerm "b") (ssymTerm "c")-            pevalITETerm-              (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))-              (pevalOrTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)))-              (ssymTerm "c")-              @=? pevalITETerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b") (ssymTerm "c")-            pevalITETerm-              (ssymTerm "a")-              (pevalOrTerm (ssymTerm "b") (pevalNotTerm $ ssymTerm "a"))-              (ssymTerm "c")-              @=? pevalITETerm (ssymTerm "a") (ssymTerm "b") (ssymTerm "c")-            pevalITETerm-              (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))-              (pevalOrTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b"))-              (ssymTerm "c")-              @=? pevalOrTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "c")-            pevalITETerm-              (ssymTerm "a")-              (pevalOrTerm (ssymTerm "a") (ssymTerm "b"))-              (ssymTerm "c")-              @=? pevalOrTerm (ssymTerm "a") (ssymTerm "c")-            pevalITETerm-              (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))-              (pevalOrTerm (ssymTerm "b") (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)))-              (ssymTerm "c")-              @=? pevalOrTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "c")-            pevalITETerm-              (ssymTerm "a")-              (pevalOrTerm (ssymTerm "b") (ssymTerm "a"))-              (ssymTerm "c")-              @=? pevalOrTerm (ssymTerm "a") (ssymTerm "c"),-          testCase "On right Or" $ do-            pevalITETerm-              (ssymTerm "a")-              (ssymTerm "b")-              (pevalOrTerm (ssymTerm "b") (ssymTerm "c"))-              @=? pevalOrTerm (ssymTerm "b") (pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "c"))-            pevalITETerm-              (ssymTerm "a")-              (ssymTerm "c")-              (pevalOrTerm (ssymTerm "b") (ssymTerm "c"))-              @=? pevalOrTerm (ssymTerm "c") (pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")),-          testCase "On const boolean in branches" $ do-            pevalITETerm-              (ssymTerm "a")-              (conTerm True)-              (ssymTerm "b")-              @=? pevalOrTerm (ssymTerm "a") (ssymTerm "b")-            pevalITETerm-              (ssymTerm "a")-              (conTerm False)-              (ssymTerm "b")-              @=? pevalAndTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b")-            pevalITETerm-              (ssymTerm "a")-              (ssymTerm "b")-              (conTerm True)-              @=? pevalOrTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b")-            pevalITETerm-              (ssymTerm "a")-              (ssymTerm "b")-              (conTerm False)-              @=? pevalAndTerm (ssymTerm "a") (ssymTerm "b"),-          testCase "On condition equal to some branch" $ do-            pevalITETerm-              (ssymTerm "a")-              (ssymTerm "a")-              (ssymTerm "b")-              @=? pevalOrTerm (ssymTerm "a") (ssymTerm "b")-            pevalITETerm-              (ssymTerm "a")-              (ssymTerm "b")-              (ssymTerm "a")-              @=? pevalAndTerm (ssymTerm "a") (ssymTerm "b"),-          testCase "On left Not" $ do-            pevalITETerm (ssymTerm "a") (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")-              @=? pevalAndTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b"),-          testCase "On right Not" $ do-            pevalITETerm (ssymTerm "a") (ssymTerm "b") (pevalNotTerm (ssymTerm "a"))-              @=? pevalOrTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b"),-          testCase "On left Not And" $ do-            pevalITETerm-              (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))-              (pevalNotTerm (pevalAndTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")))-              (ssymTerm "c")-              @=? pevalOrTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "c")-            pevalITETerm-              (ssymTerm "a")-              (pevalNotTerm (pevalAndTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b")))-              (ssymTerm "c")-              @=? pevalOrTerm (ssymTerm "a") (ssymTerm "c")-            pevalITETerm-              (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))-              (pevalNotTerm (pevalAndTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))))-              (ssymTerm "c")-              @=? pevalOrTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "c")-            pevalITETerm-              (ssymTerm "a")-              (pevalNotTerm (pevalAndTerm (ssymTerm "b") (pevalNotTerm $ ssymTerm "a")))-              (ssymTerm "c")-              @=? pevalOrTerm (ssymTerm "a") (ssymTerm "c")-            pevalITETerm-              (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))-              (pevalNotTerm (pevalAndTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")))-              (ssymTerm "c")-              @=? pevalITETerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (pevalNotTerm $ ssymTerm "b") (ssymTerm "c")-            pevalITETerm-              (ssymTerm "a")-              (pevalNotTerm (pevalAndTerm (ssymTerm "a") (ssymTerm "b")))-              (ssymTerm "c")-              @=? pevalITETerm (ssymTerm "a") (pevalNotTerm $ ssymTerm "b") (ssymTerm "c")-            pevalITETerm-              (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))-              (pevalNotTerm (pevalAndTerm (ssymTerm "b") (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))))-              (ssymTerm "c")-              @=? pevalITETerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (pevalNotTerm $ ssymTerm "b") (ssymTerm "c")-            pevalITETerm-              (ssymTerm "a")-              (pevalNotTerm (pevalAndTerm (ssymTerm "b") (ssymTerm "a")))-              (ssymTerm "c")-              @=? pevalITETerm (ssymTerm "a") (pevalNotTerm $ ssymTerm "b") (ssymTerm "c")-        ],-      testGroup-        "Imply"-        [ testCase "pevalImplyTerm" $ do-            ssymTerm "a"-              `pevalImplyTerm` ssymTerm "b"-              @=? pevalOrTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b")-        ],-      testGroup-        "Xor"-        [ testCase "pevalXorTerm" $ do-            ssymTerm "a"-              `pevalXorTerm` ssymTerm "b"-              @=? pevalOrTerm-                (pevalAndTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b"))-                (pevalAndTerm (ssymTerm "a") (pevalNotTerm $ ssymTerm "b"))-        ]-    ]
− test/Grisette/IR/SymPrim/Data/Prim/IntegralTests.hs 
@@ -1,191 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}--module Grisette.IR.SymPrim.Data.Prim.IntegralTests (integralTests) where--import Control.DeepSeq (NFData (rnf), force)-import Control.Exception (ArithException, catch, evaluate)-import Data.Proxy (Proxy (Proxy))-import Grisette.Core.Data.BV (IntN (IntN), WordN (WordN))-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors-  ( conTerm,-    divBoundedIntegralTerm,-    divIntegralTerm,-    modIntegralTerm,-    quotBoundedIntegralTerm,-    quotIntegralTerm,-    remIntegralTerm,-    ssymTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term-  ( SupportedPrim,-    Term,-  )-import Grisette.IR.SymPrim.Data.Prim.PartialEval.Integral-  ( pevalDivBoundedIntegralTerm,-    pevalDivIntegralTerm,-    pevalModIntegralTerm,-    pevalQuotBoundedIntegralTerm,-    pevalQuotIntegralTerm,-    pevalRemIntegralTerm,-  )-import Test.Framework (Test, TestName, testGroup)-import Test.Framework.Providers.HUnit (testCase)-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.HUnit ((@=?))-import Test.QuickCheck (Arbitrary, ioProperty)--newtype AEWrapper = AEWrapper ArithException deriving (Eq)--instance Show AEWrapper where-  show (AEWrapper x) = show x--instance NFData AEWrapper where-  rnf (AEWrapper x) = x `seq` ()--sameDivPeval ::-  forall t.-  (Num t, Eq t, SupportedPrim t, Integral t) =>-  t ->-  t ->-  (Term t -> Term t -> Term t) ->-  (t -> t -> t) ->-  (Term t -> Term t -> Term t) ->-  IO ()-sameDivPeval i j pf cf consf = do-  cx <- evaluate (force $ Right $ cf i j) `catch` \(_ :: ArithException) -> return $ Left AEWrapper-  case cx of-    Left _ -> pf (conTerm i) (conTerm j) @=? consf (conTerm i) (conTerm j)-    Right t -> pf (conTerm i) (conTerm j) @=? conTerm t--divisionPevalBoundedTests ::-  forall p t.-  (Num t, Eq t, Bounded t, SupportedPrim t, Integral t) =>-  p t ->-  TestName ->-  (Term t -> Term t -> Term t) ->-  (t -> t -> t) ->-  (Term t -> Term t -> Term t) ->-  Test-divisionPevalBoundedTests _ name pf cf consf =-  testGroup-    name-    [ testCase "On concrete min divide by -1" $-        sameDivPeval minBound (-1) pf cf consf-    ]--divisionPevalTests ::-  forall p t0 t.-  (Num t, Eq t, Arbitrary t0, Show t0, SupportedPrim t, Integral t) =>-  p t ->-  TestName ->-  (t0 -> t) ->-  (Term t -> Term t -> Term t) ->-  (t -> t -> t) ->-  (Term t -> Term t -> Term t) ->-  Test-divisionPevalTests _ name transform pf cf consf =-  testGroup-    name-    [ testProperty "On concrete prop" $-        ioProperty . \(i0 :: t0, j0 :: t0) -> do-          let i = transform i0-          let j = transform j0-          sameDivPeval i j pf cf consf,-      testProperty "On concrete divide by 0" $-        ioProperty . \(i0 :: t0) -> do-          let i = transform i0-          sameDivPeval i 0 pf cf consf,-      testCase "divide by 1" $ do-        pf (ssymTerm "a" :: Term t) (conTerm 1) @=? ssymTerm "a",-      testCase "On symbolic" $ do-        pf (ssymTerm "a" :: Term t) (ssymTerm "b")-          @=? consf (ssymTerm "a" :: Term t) (ssymTerm "b" :: Term t)-    ]--divisionPevalBoundedTestGroup ::-  TestName ->-  (forall t. (SupportedPrim t, Bounded t, Integral t) => Term t -> Term t -> Term t) ->-  (forall t. (Bounded t, Integral t) => t -> t -> t) ->-  (forall t. (SupportedPrim t, Bounded t, Integral t) => Term t -> Term t -> Term t) ->-  Test-divisionPevalBoundedTestGroup name pf cf consf =-  testGroup-    name-    [ divisionPevalTests (Proxy @(IntN 4)) "IntN" IntN pf cf consf,-      divisionPevalBoundedTests (Proxy @(IntN 4)) "IntN Bounded" pf cf consf-    ]--divisionPevalUnboundedTestGroup ::-  TestName ->-  (forall t. (SupportedPrim t, Integral t) => Term t -> Term t -> Term t) ->-  (forall t. (Integral t) => t -> t -> t) ->-  (forall t. (SupportedPrim t, Integral t) => Term t -> Term t -> Term t) ->-  Test-divisionPevalUnboundedTestGroup name pf cf consf =-  testGroup-    name-    [ divisionPevalTests (Proxy @Integer) "Integer" id pf cf consf,-      divisionPevalTests (Proxy @(WordN 4)) "WordN" WordN pf cf consf,-      divisionPevalBoundedTests (Proxy @(WordN 4)) "WordN Bounded" pf cf consf-    ]--moduloPevalTests ::-  forall p t0 t.-  (Num t, Eq t, Arbitrary t0, Show t0, SupportedPrim t, Integral t) =>-  p t ->-  TestName ->-  (t0 -> t) ->-  (Term t -> Term t -> Term t) ->-  (t -> t -> t) ->-  (Term t -> Term t -> Term t) ->-  Test-moduloPevalTests _ name transform pf cf consf =-  testGroup-    name-    [ testProperty "On concrete" $-        ioProperty . \(i0 :: t0, j0 :: t0) -> do-          let i = transform i0-          let j = transform j0-          sameDivPeval i j pf cf consf,-      testProperty "On concrete divide by 0" $-        ioProperty . \(i0 :: t0) -> do-          let i = transform i0-          sameDivPeval i 0 pf cf consf,-      testCase "mod by 1" $ do-        pf (ssymTerm "a" :: Term t) (conTerm 1) @=? conTerm 0,-      testCase "mod by -1" $ do-        pf (ssymTerm "a" :: Term t) (conTerm $ -1) @=? conTerm 0,-      testCase "On symbolic" $ do-        pf (ssymTerm "a" :: Term t) (ssymTerm "b")-          @=? consf (ssymTerm "a" :: Term t) (ssymTerm "b" :: Term t)-    ]--moduloPevalTestGroup ::-  TestName ->-  (forall t. (SupportedPrim t, Integral t) => Term t -> Term t -> Term t) ->-  (forall t. (Integral t) => t -> t -> t) ->-  (forall t. (SupportedPrim t, Integral t) => Term t -> Term t -> Term t) ->-  Test-moduloPevalTestGroup name pf cf consf =-  testGroup-    name-    [ moduloPevalTests (Proxy @Integer) "Integer" id pf cf consf,-      moduloPevalTests (Proxy @(IntN 4)) "IntN" IntN pf cf consf,-      moduloPevalTests (Proxy @(WordN 4)) "WordN" WordN pf cf consf-    ]--integralTests :: Test-integralTests =-  testGroup-    "Integral"-    [ divisionPevalUnboundedTestGroup "Div unbounded" pevalDivIntegralTerm div divIntegralTerm,-      divisionPevalUnboundedTestGroup "Quot unbounded" pevalQuotIntegralTerm quot quotIntegralTerm,-      divisionPevalBoundedTestGroup "Div bounded" pevalDivBoundedIntegralTerm div divBoundedIntegralTerm,-      divisionPevalBoundedTestGroup "Quot bounded" pevalQuotBoundedIntegralTerm quot quotBoundedIntegralTerm,-      moduloPevalTestGroup "Mod" pevalModIntegralTerm mod modIntegralTerm,-      moduloPevalTestGroup "Rem" pevalRemIntegralTerm rem remIntegralTerm-    ]
− test/Grisette/IR/SymPrim/Data/Prim/ModelTests.hs 
@@ -1,282 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Grisette.IR.SymPrim.Data.Prim.ModelTests (modelTests) where--import qualified Data.HashMap.Strict as M-import qualified Data.HashSet as S-import Grisette.Core.Data.BV (IntN, WordN)-import Grisette.Core.Data.Class.ModelOps-  ( ModelOps-      ( emptyModel,-        exact,-        exceptFor,-        extendTo,-        insertValue,-        restrictTo,-        valueOf-      ),-    ModelRep (buildModel),-  )-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors-  ( conTerm,-    ssymTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term-  ( Term,-    TypedSymbol (SimpleSymbol),-    someTypedSymbol,-  )-import Grisette.IR.SymPrim.Data.Prim.Model-  ( Model (Model),-    ModelValuePair ((::=)),-    SymbolSet (SymbolSet),-    equation,-    evaluateTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.ModelValue (toModelValue)-import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool-  ( pevalEqvTerm,-    pevalITETerm,-  )-import Grisette.IR.SymPrim.Data.Prim.PartialEval.Num-  ( pevalAddNumTerm,-    pevalUMinusNumTerm,-  )-import Test.Framework (Test, testGroup)-import Test.Framework.Providers.HUnit (testCase)-import Test.HUnit ((@=?))--modelTests :: Test-modelTests =-  let asymbol :: TypedSymbol Integer = SimpleSymbol "a"-      bsymbol :: TypedSymbol Bool = SimpleSymbol "b"-      csymbol :: TypedSymbol Integer = SimpleSymbol "c"-      dsymbol :: TypedSymbol Bool = SimpleSymbol "d"-      esymbol :: TypedSymbol (WordN 4) = SimpleSymbol "e"-      fsymbol :: TypedSymbol (IntN 4) = SimpleSymbol "f"-      gsymbol :: TypedSymbol (WordN 16) = SimpleSymbol "g"-      hsymbol :: TypedSymbol (IntN 16) = SimpleSymbol "h"-      m1 = emptyModel-      m2 = insertValue asymbol 1 m1-      m3 = insertValue bsymbol True m2-   in testGroup-        "Model"-        [ testCase "empty model is really empty" $ do-            emptyModel @=? Model M.empty,-          testCase "inserting to model" $ do-            m3-              @=? Model-                ( M.fromList-                    [ (someTypedSymbol asymbol, toModelValue (1 :: Integer)),-                      (someTypedSymbol bsymbol, toModelValue True)-                    ]-                ),-          testCase "equation" $ do-            equation asymbol m3 @=? Just (pevalEqvTerm (ssymTerm "a") (conTerm 1 :: Term Integer))-            equation bsymbol m3 @=? Just (pevalEqvTerm (ssymTerm "b") (conTerm True))-            equation csymbol m3 @=? Nothing,-          testCase "valueOf" $ do-            valueOf asymbol m3 @=? Just (1 :: Integer)-            valueOf bsymbol m3 @=? Just True-            valueOf csymbol m3 @=? (Nothing :: Maybe Integer),-          testCase "exceptFor" $ do-            exceptFor (SymbolSet $ S.fromList [someTypedSymbol asymbol]) m3-              @=? Model-                ( M.fromList-                    [ (someTypedSymbol bsymbol, toModelValue True)-                    ]-                ),-          testCase "restrictTo" $ do-            restrictTo (SymbolSet $ S.fromList [someTypedSymbol asymbol]) m3-              @=? Model-                ( M.fromList-                    [ (someTypedSymbol asymbol, toModelValue (1 :: Integer))-                    ]-                ),-          testCase "extendTo" $ do-            extendTo-              ( SymbolSet $-                  S.fromList-                    [ someTypedSymbol csymbol,-                      someTypedSymbol dsymbol,-                      someTypedSymbol esymbol,-                      someTypedSymbol fsymbol-                    ]-              )-              m3-              @=? Model-                ( M.fromList-                    [ (someTypedSymbol asymbol, toModelValue (1 :: Integer)),-                      (someTypedSymbol bsymbol, toModelValue True),-                      (someTypedSymbol csymbol, toModelValue (0 :: Integer)),-                      (someTypedSymbol dsymbol, toModelValue False),-                      (someTypedSymbol esymbol, toModelValue (0 :: WordN 4)),-                      (someTypedSymbol fsymbol, toModelValue (0 :: IntN 4))-                    ]-                ),-          testCase "exact" $ do-            exact-              ( SymbolSet $-                  S.fromList-                    [ someTypedSymbol asymbol,-                      someTypedSymbol csymbol-                    ]-              )-              m3-              @=? Model-                ( M.fromList-                    [ (someTypedSymbol asymbol, toModelValue (1 :: Integer)),-                      (someTypedSymbol csymbol, toModelValue (0 :: Integer))-                    ]-                ),-          testCase "evaluateTerm" $ do-            evaluateTerm False m3 (conTerm (1 :: Integer)) @=? conTerm 1-            evaluateTerm True m3 (conTerm (1 :: Integer)) @=? conTerm 1-            evaluateTerm False m3 (ssymTerm "a" :: Term Integer) @=? conTerm 1-            evaluateTerm True m3 (ssymTerm "a" :: Term Integer) @=? conTerm 1-            evaluateTerm False m3 (ssymTerm "x" :: Term Integer) @=? ssymTerm "x"-            evaluateTerm True m3 (ssymTerm "x" :: Term Integer) @=? conTerm 0-            evaluateTerm False m3 (ssymTerm "y" :: Term Bool) @=? ssymTerm "y"-            evaluateTerm True m3 (ssymTerm "y" :: Term Bool) @=? conTerm False-            evaluateTerm False m3 (ssymTerm "z" :: Term (WordN 4)) @=? ssymTerm "z"-            evaluateTerm True m3 (ssymTerm "z" :: Term (WordN 4)) @=? conTerm 0-            evaluateTerm False m3 (pevalUMinusNumTerm $ ssymTerm "a" :: Term Integer) @=? conTerm (-1)-            evaluateTerm True m3 (pevalUMinusNumTerm $ ssymTerm "a" :: Term Integer) @=? conTerm (-1)-            evaluateTerm False m3 (pevalUMinusNumTerm $ ssymTerm "x" :: Term Integer) @=? pevalUMinusNumTerm (ssymTerm "x")-            evaluateTerm True m3 (pevalUMinusNumTerm $ ssymTerm "x" :: Term Integer) @=? conTerm 0-            evaluateTerm False m3 (pevalAddNumTerm (ssymTerm "a") (ssymTerm "a") :: Term Integer) @=? conTerm 2-            evaluateTerm True m3 (pevalAddNumTerm (ssymTerm "a") (ssymTerm "a") :: Term Integer) @=? conTerm 2-            evaluateTerm False m3 (pevalAddNumTerm (ssymTerm "x") (ssymTerm "a") :: Term Integer) @=? pevalAddNumTerm (conTerm 1) (ssymTerm "x")-            evaluateTerm True m3 (pevalAddNumTerm (ssymTerm "x") (ssymTerm "a") :: Term Integer) @=? conTerm 1-            evaluateTerm False m3 (pevalAddNumTerm (ssymTerm "x") (ssymTerm "y") :: Term Integer) @=? pevalAddNumTerm (ssymTerm "x") (ssymTerm "y")-            evaluateTerm True m3 (pevalAddNumTerm (ssymTerm "x") (ssymTerm "y") :: Term Integer) @=? conTerm 0-            evaluateTerm False m3 (pevalITETerm (ssymTerm "b") (pevalAddNumTerm (ssymTerm "a") (ssymTerm "a")) (ssymTerm "a") :: Term Integer)-              @=? conTerm 2-            evaluateTerm True m3 (pevalITETerm (ssymTerm "b") (pevalAddNumTerm (ssymTerm "a") (ssymTerm "a")) (ssymTerm "a") :: Term Integer)-              @=? conTerm 2-            evaluateTerm False m3 (pevalITETerm (ssymTerm "x") (pevalAddNumTerm (ssymTerm "a") (ssymTerm "a")) (ssymTerm "a") :: Term Integer)-              @=? pevalITETerm (ssymTerm "x") (conTerm 2) (conTerm 1)-            evaluateTerm True m3 (pevalITETerm (ssymTerm "x") (pevalAddNumTerm (ssymTerm "a") (ssymTerm "a")) (ssymTerm "a") :: Term Integer)-              @=? conTerm 1-            evaluateTerm False m3 (pevalITETerm (ssymTerm "b") (ssymTerm "x") (pevalAddNumTerm (conTerm 1) (ssymTerm "y")) :: Term Integer)-              @=? ssymTerm "x"-            evaluateTerm True m3 (pevalITETerm (ssymTerm "b") (ssymTerm "x") (pevalAddNumTerm (conTerm 1) (ssymTerm "y")) :: Term Integer)-              @=? conTerm 0-            evaluateTerm False m3 (pevalITETerm (ssymTerm "z") (ssymTerm "x") (pevalAddNumTerm (conTerm 1) (ssymTerm "y")) :: Term Integer)-              @=? pevalITETerm (ssymTerm "z") (ssymTerm "x") (pevalAddNumTerm (conTerm 1) (ssymTerm "y"))-            evaluateTerm True m3 (pevalITETerm (ssymTerm "z") (ssymTerm "x") (pevalAddNumTerm (conTerm 1) (ssymTerm "y")) :: Term Integer)-              @=? conTerm 1,-          testCase "construction from ModelValuePair" $ do-            buildModel (asymbol ::= 1) @=? Model (M.singleton (someTypedSymbol asymbol) (toModelValue (1 :: Integer)))-            buildModel (asymbol ::= 1, bsymbol ::= True)-              @=? Model-                ( M.fromList-                    [ (someTypedSymbol asymbol, toModelValue (1 :: Integer)),-                      (someTypedSymbol bsymbol, toModelValue True)-                    ]-                )-            buildModel-              ( asymbol ::= 1,-                bsymbol ::= True,-                csymbol ::= 2-              )-              @=? Model-                ( M.fromList-                    [ (someTypedSymbol asymbol, toModelValue (1 :: Integer)),-                      (someTypedSymbol bsymbol, toModelValue True),-                      (someTypedSymbol csymbol, toModelValue (2 :: Integer))-                    ]-                )-            buildModel-              ( asymbol ::= 1,-                bsymbol ::= True,-                csymbol ::= 2,-                dsymbol ::= False-              )-              @=? Model-                ( M.fromList-                    [ (someTypedSymbol asymbol, toModelValue (1 :: Integer)),-                      (someTypedSymbol bsymbol, toModelValue True),-                      (someTypedSymbol csymbol, toModelValue (2 :: Integer)),-                      (someTypedSymbol dsymbol, toModelValue False)-                    ]-                )-            buildModel-              ( asymbol ::= 1,-                bsymbol ::= True,-                csymbol ::= 2,-                dsymbol ::= False,-                esymbol ::= 3-              )-              @=? Model-                ( M.fromList-                    [ (someTypedSymbol asymbol, toModelValue (1 :: Integer)),-                      (someTypedSymbol bsymbol, toModelValue True),-                      (someTypedSymbol csymbol, toModelValue (2 :: Integer)),-                      (someTypedSymbol dsymbol, toModelValue False),-                      (someTypedSymbol esymbol, toModelValue (3 :: WordN 4))-                    ]-                )-            buildModel-              ( asymbol ::= 1,-                bsymbol ::= True,-                csymbol ::= 2,-                dsymbol ::= False,-                esymbol ::= 3,-                fsymbol ::= 4-              )-              @=? Model-                ( M.fromList-                    [ (someTypedSymbol asymbol, toModelValue (1 :: Integer)),-                      (someTypedSymbol bsymbol, toModelValue True),-                      (someTypedSymbol csymbol, toModelValue (2 :: Integer)),-                      (someTypedSymbol dsymbol, toModelValue False),-                      (someTypedSymbol esymbol, toModelValue (3 :: WordN 4)),-                      (someTypedSymbol fsymbol, toModelValue (4 :: IntN 4))-                    ]-                )-            buildModel-              ( asymbol ::= 1,-                bsymbol ::= True,-                csymbol ::= 2,-                dsymbol ::= False,-                esymbol ::= 3,-                fsymbol ::= 4,-                gsymbol ::= 5-              )-              @=? Model-                ( M.fromList-                    [ (someTypedSymbol asymbol, toModelValue (1 :: Integer)),-                      (someTypedSymbol bsymbol, toModelValue True),-                      (someTypedSymbol csymbol, toModelValue (2 :: Integer)),-                      (someTypedSymbol dsymbol, toModelValue False),-                      (someTypedSymbol esymbol, toModelValue (3 :: WordN 4)),-                      (someTypedSymbol fsymbol, toModelValue (4 :: IntN 4)),-                      (someTypedSymbol gsymbol, toModelValue (5 :: WordN 16))-                    ]-                )-            buildModel-              ( asymbol ::= 1,-                bsymbol ::= True,-                csymbol ::= 2,-                dsymbol ::= False,-                esymbol ::= 3,-                fsymbol ::= 4,-                gsymbol ::= 5,-                hsymbol ::= 6-              )-              @=? Model-                ( M.fromList-                    [ (someTypedSymbol asymbol, toModelValue (1 :: Integer)),-                      (someTypedSymbol bsymbol, toModelValue True),-                      (someTypedSymbol csymbol, toModelValue (2 :: Integer)),-                      (someTypedSymbol dsymbol, toModelValue False),-                      (someTypedSymbol esymbol, toModelValue (3 :: WordN 4)),-                      (someTypedSymbol fsymbol, toModelValue (4 :: IntN 4)),-                      (someTypedSymbol gsymbol, toModelValue (5 :: WordN 16)),-                      (someTypedSymbol hsymbol, toModelValue (6 :: IntN 16))-                    ]-                )-        ]
− test/Grisette/IR/SymPrim/Data/Prim/NumTests.hs 
@@ -1,408 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Grisette.IR.SymPrim.Data.Prim.NumTests (numTests) where--import Grisette.Core.Data.BV (IntN, WordN)-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors-  ( absNumTerm,-    addNumTerm,-    conTerm,-    leNumTerm,-    ltNumTerm,-    signumNumTerm,-    ssymTerm,-    timesNumTerm,-    uminusNumTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term (Term)-import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool-  ( pevalITETerm,-  )-import Grisette.IR.SymPrim.Data.Prim.PartialEval.Num-  ( pevalAbsNumTerm,-    pevalAddNumTerm,-    pevalGeNumTerm,-    pevalGtNumTerm,-    pevalLeNumTerm,-    pevalLtNumTerm,-    pevalMinusNumTerm,-    pevalSignumNumTerm,-    pevalTimesNumTerm,-    pevalUMinusNumTerm,-  )-import Test.Framework (Test, testGroup)-import Test.Framework.Providers.HUnit (testCase)-import Test.HUnit ((@=?))--numTests :: Test-numTests =-  testGroup-    "Num"-    [ testGroup-        "Add"-        [ testCase "On concrete" $ do-            pevalAddNumTerm (conTerm 1 :: Term Integer) (conTerm 2) @=? conTerm 3-            pevalAddNumTerm (conTerm 1 :: Term (WordN 3)) (conTerm 2) @=? conTerm 3-            pevalAddNumTerm (conTerm 1 :: Term (IntN 3)) (conTerm 2) @=? conTerm 3,-          testCase "On left 0" $ do-            pevalAddNumTerm (conTerm 0 :: Term Integer) (ssymTerm "a") @=? ssymTerm "a",-          testCase "On right 0" $ do-            pevalAddNumTerm (ssymTerm "a") (conTerm 0 :: Term Integer) @=? ssymTerm "a",-          testCase "On left concrete" $ do-            pevalAddNumTerm (conTerm 1 :: Term Integer) (ssymTerm "a")-              @=? addNumTerm (conTerm 1 :: Term Integer) (ssymTerm "a" :: Term Integer),-          testCase "On right concrete" $ do-            pevalAddNumTerm (ssymTerm "a") (conTerm 1 :: Term Integer)-              @=? addNumTerm (conTerm 1 :: Term Integer) (ssymTerm "a" :: Term Integer),-          testCase "On no concrete" $ do-            pevalAddNumTerm (ssymTerm "a") (ssymTerm "b" :: Term Integer)-              @=? addNumTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b" :: Term Integer),-          testCase "On left concrete and right add concrete value" $ do-            pevalAddNumTerm (conTerm 1 :: Term Integer) (pevalAddNumTerm (conTerm 2 :: Term Integer) (ssymTerm "a"))-              @=? pevalAddNumTerm (conTerm 3 :: Term Integer) (ssymTerm "a"),-          testCase "On right concrete and left add concrete value" $ do-            pevalAddNumTerm (pevalAddNumTerm (conTerm 2 :: Term Integer) (ssymTerm "a")) (conTerm 1 :: Term Integer)-              @=? pevalAddNumTerm (conTerm 3 :: Term Integer) (ssymTerm "a"),-          testCase "On left add concrete" $ do-            pevalAddNumTerm (pevalAddNumTerm (conTerm 2 :: Term Integer) (ssymTerm "a")) (ssymTerm "b")-              @=? pevalAddNumTerm (conTerm 2 :: Term Integer) (pevalAddNumTerm (ssymTerm "a") (ssymTerm "b")),-          testCase "On right add concrete" $ do-            pevalAddNumTerm (ssymTerm "b") (pevalAddNumTerm (conTerm 2 :: Term Integer) (ssymTerm "a"))-              @=? pevalAddNumTerm (conTerm 2 :: Term Integer) (pevalAddNumTerm (ssymTerm "b") (ssymTerm "a")),-          testCase "On both uminus" $ do-            pevalAddNumTerm (pevalUMinusNumTerm $ ssymTerm "a" :: Term Integer) (pevalUMinusNumTerm $ ssymTerm "b")-              @=? pevalUMinusNumTerm (pevalAddNumTerm (ssymTerm "a") (ssymTerm "b")),-          testCase "On both times the same concrete" $ do-            pevalAddNumTerm-              (pevalTimesNumTerm (conTerm 3) (ssymTerm "a") :: Term Integer)-              (pevalTimesNumTerm (conTerm 3) (ssymTerm "b"))-              @=? pevalTimesNumTerm (conTerm 3) (pevalAddNumTerm (ssymTerm "a") (ssymTerm "b")),-          testCase "On both times the same symbolic" $ do-            pevalAddNumTerm-              (pevalTimesNumTerm (conTerm 3) (ssymTerm "a") :: Term Integer)-              (pevalTimesNumTerm (conTerm 3) (ssymTerm "a"))-              @=? pevalTimesNumTerm (conTerm 6) (ssymTerm "a")-            pevalAddNumTerm-              (pevalTimesNumTerm (conTerm 3) (ssymTerm "a") :: Term Integer)-              (pevalTimesNumTerm (conTerm 4) (ssymTerm "a"))-              @=? pevalTimesNumTerm (conTerm 7) (ssymTerm "a"),-          testCase "Unfold 1" $ do-            pevalAddNumTerm-              (conTerm 3)-              (pevalITETerm (ssymTerm "a") (conTerm 1 :: Term Integer) (ssymTerm "a"))-              @=? pevalITETerm (ssymTerm "a") (conTerm 4) (pevalAddNumTerm (conTerm 3) (ssymTerm "a"))-            pevalAddNumTerm-              (pevalITETerm (ssymTerm "a") (conTerm 1 :: Term Integer) (ssymTerm "a"))-              (conTerm 3)-              @=? pevalITETerm (ssymTerm "a") (conTerm 4) (pevalAddNumTerm (ssymTerm "a") (conTerm 3))-        ],-      testGroup-        "minus"-        [ testCase "minus num should be delegated to add and uminus" $ do-            pevalMinusNumTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b")-              @=? pevalAddNumTerm (ssymTerm "a") (pevalUMinusNumTerm $ ssymTerm "b")-        ],-      testGroup-        "UMinus"-        [ testCase "On concrete" $ do-            pevalUMinusNumTerm (conTerm 1 :: Term Integer) @=? conTerm (-1)-            pevalUMinusNumTerm (conTerm 1 :: Term (WordN 3)) @=? conTerm (-1),-          testCase "On UMinus" $ do-            pevalUMinusNumTerm (pevalUMinusNumTerm (ssymTerm "a" :: Term Integer)) @=? ssymTerm "a",-          testCase "On Add concrete" $ do-            pevalUMinusNumTerm (pevalAddNumTerm (conTerm 1) (ssymTerm "a" :: Term Integer))-              @=? pevalAddNumTerm (conTerm $ -1) (pevalUMinusNumTerm $ ssymTerm "a"),-          testCase "On Add uminus" $ do-            pevalUMinusNumTerm (pevalAddNumTerm (pevalUMinusNumTerm $ ssymTerm "a") (ssymTerm "b" :: Term Integer))-              @=? pevalAddNumTerm (ssymTerm "a") (pevalUMinusNumTerm $ ssymTerm "b")-            pevalUMinusNumTerm (pevalAddNumTerm (ssymTerm "a") (pevalUMinusNumTerm $ ssymTerm "b" :: Term Integer))-              @=? pevalAddNumTerm (pevalUMinusNumTerm $ ssymTerm "a") (ssymTerm "b"),-          testCase "On Times concrete" $ do-            pevalUMinusNumTerm (pevalTimesNumTerm (conTerm 3) (ssymTerm "a" :: Term Integer))-              @=? pevalTimesNumTerm (conTerm $ -3) (ssymTerm "a"),-          testCase "On symbolic" $ do-            pevalUMinusNumTerm (ssymTerm "a" :: Term Integer)-              @=? uminusNumTerm (ssymTerm "a")-        ],-      testGroup-        "Times"-        [ testCase "On both concrete" $ do-            pevalTimesNumTerm (conTerm 3 :: Term Integer) (conTerm 5)-              @=? conTerm 15,-          testCase "On left 0" $ do-            pevalTimesNumTerm (conTerm 0 :: Term Integer) (ssymTerm "a")-              @=? conTerm 0,-          testCase "On right 0" $ do-            pevalTimesNumTerm (ssymTerm "a") (conTerm 0 :: Term Integer)-              @=? conTerm 0,-          testCase "On left 1" $ do-            pevalTimesNumTerm (conTerm 1 :: Term Integer) (ssymTerm "a")-              @=? ssymTerm "a",-          testCase "On right 1" $ do-            pevalTimesNumTerm (ssymTerm "a") (conTerm 1 :: Term Integer)-              @=? ssymTerm "a",-          testCase "On left -1" $ do-            pevalTimesNumTerm (conTerm $ -1 :: Term Integer) (ssymTerm "a")-              @=? pevalUMinusNumTerm (ssymTerm "a"),-          testCase "On right -1" $ do-            pevalTimesNumTerm (ssymTerm "a") (conTerm $ -1 :: Term Integer)-              @=? pevalUMinusNumTerm (ssymTerm "a"),-          testCase "On left concrete and right times concrete symbolics" $ do-            pevalTimesNumTerm (conTerm 3) (pevalTimesNumTerm (conTerm 5 :: Term Integer) (ssymTerm "a"))-              @=? pevalTimesNumTerm (conTerm 15) (ssymTerm "a"),-          testCase "On right concrete and left times concrete symbolics" $ do-            pevalTimesNumTerm (pevalTimesNumTerm (conTerm 5 :: Term Integer) (ssymTerm "a")) (conTerm 3)-              @=? pevalTimesNumTerm (conTerm 15) (ssymTerm "a"),-          testCase "On left concrete and right add concrete symbolics" $ do-            pevalTimesNumTerm (conTerm 3) (pevalAddNumTerm (conTerm 5 :: Term Integer) (ssymTerm "a"))-              @=? pevalAddNumTerm (conTerm 15) (pevalTimesNumTerm (conTerm 3) (ssymTerm "a")),-          testCase "On right concrete and left add concrete symbolics" $ do-            pevalTimesNumTerm (pevalAddNumTerm (conTerm 5 :: Term Integer) (ssymTerm "a")) (conTerm 3)-              @=? pevalAddNumTerm (conTerm 15) (pevalTimesNumTerm (conTerm 3) (ssymTerm "a")),-          testCase "On left concrete and right uminus" $ do-            pevalTimesNumTerm (conTerm 3 :: Term Integer) (pevalUMinusNumTerm (ssymTerm "a"))-              @=? pevalTimesNumTerm (conTerm $ -3) (ssymTerm "a"),-          testCase "On left times concrete symbolics" $ do-            pevalTimesNumTerm (pevalTimesNumTerm (conTerm 3 :: Term Integer) (ssymTerm "a")) (ssymTerm "b")-              @=? pevalTimesNumTerm (conTerm 3) (pevalTimesNumTerm (ssymTerm "a") (ssymTerm "b")),-          testCase "On right times concrete symbolics" $ do-            pevalTimesNumTerm (ssymTerm "b") (pevalTimesNumTerm (conTerm 3 :: Term Integer) (ssymTerm "a"))-              @=? pevalTimesNumTerm (conTerm 3) (pevalTimesNumTerm (ssymTerm "b") (ssymTerm "a")),-          testCase "On left uminus" $ do-            pevalTimesNumTerm (pevalUMinusNumTerm $ ssymTerm "a") (ssymTerm "b" :: Term Integer)-              @=? pevalUMinusNumTerm (pevalTimesNumTerm (ssymTerm "a") (ssymTerm "b")),-          testCase "On right uminus" $ do-            pevalTimesNumTerm (ssymTerm "a") (pevalUMinusNumTerm $ ssymTerm "b" :: Term Integer)-              @=? pevalUMinusNumTerm (pevalTimesNumTerm (ssymTerm "a") (ssymTerm "b")),-          testCase "On right concrete and left uminus" $ do-            pevalTimesNumTerm (pevalUMinusNumTerm (ssymTerm "a")) (conTerm 3 :: Term Integer)-              @=? pevalTimesNumTerm (conTerm $ -3) (ssymTerm "a"),-          testCase "On left concrete" $ do-            pevalTimesNumTerm (conTerm 3 :: Term Integer) (ssymTerm "a")-              @=? timesNumTerm-                (conTerm 3 :: Term Integer)-                (ssymTerm "a" :: Term Integer),-          testCase "On right concrete" $ do-            pevalTimesNumTerm (ssymTerm "a") (conTerm 3 :: Term Integer)-              @=? timesNumTerm-                (conTerm 3 :: Term Integer)-                (ssymTerm "a" :: Term Integer),-          testCase "On no concrete" $ do-            pevalTimesNumTerm (ssymTerm "a") (ssymTerm "b" :: Term Integer)-              @=? timesNumTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b" :: Term Integer),-          testCase "Unfold 1" $ do-            pevalTimesNumTerm-              (conTerm 3)-              (pevalITETerm (ssymTerm "a") (conTerm 5 :: Term Integer) (ssymTerm "a"))-              @=? pevalITETerm (ssymTerm "a") (conTerm 15) (pevalTimesNumTerm (conTerm 3) (ssymTerm "a"))-            pevalTimesNumTerm-              (pevalITETerm (ssymTerm "a") (conTerm 5 :: Term Integer) (ssymTerm "a"))-              (conTerm 3)-              @=? pevalITETerm (ssymTerm "a") (conTerm 15) (pevalTimesNumTerm (ssymTerm "a") (conTerm 3))-        ],-      testGroup-        "Abs"-        [ testCase "On concrete" $ do-            pevalAbsNumTerm (conTerm 10 :: Term Integer) @=? conTerm 10-            pevalAbsNumTerm (conTerm $ -10 :: Term Integer) @=? conTerm 10,-          testCase "On UMinus Integer" $ do-            pevalAbsNumTerm (pevalUMinusNumTerm $ ssymTerm "a" :: Term Integer) @=? pevalAbsNumTerm (ssymTerm "a"),-          testCase "On UMinus BV" $ do-            pevalAbsNumTerm (pevalUMinusNumTerm $ ssymTerm "a" :: Term (IntN 5)) @=? pevalAbsNumTerm (ssymTerm "a")-            pevalAbsNumTerm (pevalUMinusNumTerm $ ssymTerm "a" :: Term (WordN 5)) @=? uminusNumTerm (ssymTerm "a"),-          testCase "On Abs Integer" $ do-            pevalAbsNumTerm (pevalAbsNumTerm $ ssymTerm "a" :: Term Integer) @=? pevalAbsNumTerm (ssymTerm "a"),-          testCase "On Abs BV" $ do-            pevalAbsNumTerm (pevalAbsNumTerm $ ssymTerm "a" :: Term (IntN 5)) @=? pevalAbsNumTerm (ssymTerm "a")-            pevalAbsNumTerm (pevalAbsNumTerm $ ssymTerm "a" :: Term (WordN 5)) @=? ssymTerm "a",-          testCase "On Times Integer" $ do-            pevalAbsNumTerm (pevalTimesNumTerm (ssymTerm "a") (ssymTerm "b") :: Term Integer)-              @=? pevalTimesNumTerm (pevalAbsNumTerm (ssymTerm "a")) (pevalAbsNumTerm (ssymTerm "b")),-          testCase "On Times BV" $ do-            pevalAbsNumTerm (pevalTimesNumTerm (ssymTerm "a") (ssymTerm "b") :: Term (IntN 5))-              @=? absNumTerm (pevalTimesNumTerm (ssymTerm "a") (ssymTerm "b") :: Term (IntN 5))-            pevalAbsNumTerm (pevalTimesNumTerm (ssymTerm "a") (ssymTerm "b") :: Term (WordN 5))-              @=? pevalTimesNumTerm (ssymTerm "a") (ssymTerm "b"),-          testCase "On symbolic Integer" $ do-            pevalAbsNumTerm (ssymTerm "a" :: Term Integer)-              @=? absNumTerm (ssymTerm "a"),-          testCase "On symbolic BV" $ do-            pevalAbsNumTerm (ssymTerm "a" :: Term (IntN 5)) @=? absNumTerm (ssymTerm "a")-            pevalAbsNumTerm (ssymTerm "a" :: Term (WordN 5)) @=? ssymTerm "a"-        ],-      testGroup-        "Signum"-        [ testCase "On concrete" $ do-            pevalSignumNumTerm (conTerm 10 :: Term Integer) @=? conTerm 1-            pevalSignumNumTerm (conTerm 0 :: Term Integer) @=? conTerm 0-            pevalSignumNumTerm (conTerm $ -10 :: Term Integer) @=? conTerm (-1),-          testCase "On UMinus Integer" $ do-            pevalSignumNumTerm (pevalUMinusNumTerm $ ssymTerm "a" :: Term Integer)-              @=? pevalUMinusNumTerm (pevalSignumNumTerm $ ssymTerm "a"),-          testCase "On UMinus BV" $ do-            pevalSignumNumTerm (pevalUMinusNumTerm $ ssymTerm "a" :: Term (IntN 5))-              @=? signumNumTerm (pevalUMinusNumTerm $ ssymTerm "a" :: Term (IntN 5))-            pevalSignumNumTerm (pevalUMinusNumTerm $ ssymTerm "a" :: Term (WordN 5))-              @=? signumNumTerm (pevalUMinusNumTerm $ ssymTerm "a" :: Term (WordN 5)),-          testCase "On Times Integer" $ do-            pevalSignumNumTerm (pevalTimesNumTerm (ssymTerm "a") (ssymTerm "b") :: Term Integer)-              @=? pevalTimesNumTerm (pevalSignumNumTerm $ ssymTerm "a") (pevalSignumNumTerm $ ssymTerm "b"),-          testCase "On Times BV" $ do-            pevalSignumNumTerm (pevalTimesNumTerm (ssymTerm "a") (ssymTerm "b") :: Term (IntN 5))-              @=? signumNumTerm (pevalTimesNumTerm (ssymTerm "a") (ssymTerm "b") :: Term (IntN 5))-            pevalSignumNumTerm (pevalTimesNumTerm (ssymTerm "a") (ssymTerm "b") :: Term (WordN 5))-              @=? signumNumTerm (pevalTimesNumTerm (ssymTerm "a") (ssymTerm "b") :: Term (WordN 5)),-          testCase "On symbolics" $ do-            pevalSignumNumTerm (ssymTerm "a" :: Term Integer)-              @=? signumNumTerm (ssymTerm "a")-        ],-      let concSignedBV :: Integer -> Term (IntN 5) = conTerm . fromInteger-          concUnsignedBV :: Integer -> Term (WordN 5) = conTerm . fromInteger-       in testGroup-            "Lt"-            [ testCase "On both concrete" $ do-                pevalLtNumTerm (conTerm 1 :: Term Integer) (conTerm 2) @=? conTerm True-                pevalLtNumTerm (conTerm 2 :: Term Integer) (conTerm 2) @=? conTerm False-                pevalLtNumTerm (conTerm 3 :: Term Integer) (conTerm 2) @=? conTerm False-                pevalLtNumTerm (conTerm 1 :: Term (IntN 2)) (conTerm 0) @=? conTerm False-                pevalLtNumTerm (conTerm 2 :: Term (IntN 2)) (conTerm 0) @=? conTerm True-                pevalLtNumTerm (conTerm 3 :: Term (IntN 2)) (conTerm 0) @=? conTerm True-                pevalLtNumTerm (conTerm 1 :: Term (WordN 2)) (conTerm 2) @=? conTerm True-                pevalLtNumTerm (conTerm 2 :: Term (WordN 2)) (conTerm 2) @=? conTerm False-                pevalLtNumTerm (conTerm 3 :: Term (WordN 2)) (conTerm 2) @=? conTerm False,-              testCase "On left constant and right add concrete Integers" $ do-                pevalLtNumTerm (conTerm 1 :: Term Integer) (pevalAddNumTerm (conTerm 2) (ssymTerm "a"))-                  @=? pevalLtNumTerm (conTerm $ -1 :: Term Integer) (ssymTerm "a"),-              testCase "On right constant left add concrete Integers" $ do-                pevalLtNumTerm (pevalAddNumTerm (conTerm 2) (ssymTerm "a")) (conTerm 1 :: Term Integer)-                  @=? pevalLtNumTerm (conTerm 1 :: Term Integer) (pevalUMinusNumTerm $ ssymTerm "a"),-              testCase "On right constant Integers" $ do-                pevalLtNumTerm (ssymTerm "a") (conTerm 1 :: Term Integer)-                  @=? pevalLtNumTerm (conTerm $ -1 :: Term Integer) (pevalUMinusNumTerm $ ssymTerm "a"),-              testCase "On right constant and left uminus Integers" $ do-                pevalLtNumTerm (pevalUMinusNumTerm $ ssymTerm "a") (conTerm 1 :: Term Integer)-                  @=? pevalLtNumTerm (conTerm $ -1 :: Term Integer) (ssymTerm "a"),-              testCase "On left add concrete Integers" $ do-                pevalLtNumTerm (pevalAddNumTerm (conTerm 2) (ssymTerm "a")) (ssymTerm "b" :: Term Integer)-                  @=? pevalLtNumTerm (conTerm 2 :: Term Integer) (pevalAddNumTerm (ssymTerm "b") (pevalUMinusNumTerm $ ssymTerm "a")),-              testCase "On right add concrete Integers" $ do-                pevalLtNumTerm (ssymTerm "b" :: Term Integer) (pevalAddNumTerm (conTerm 2) (ssymTerm "a"))-                  @=? pevalLtNumTerm (conTerm $ -2 :: Term Integer) (pevalAddNumTerm (ssymTerm "a") (pevalUMinusNumTerm $ ssymTerm "b")),-              testCase "On left constant and right add concrete BVs should not be simplified" $ do-                pevalLtNumTerm (concSignedBV 1) (pevalAddNumTerm (conTerm 2) (ssymTerm "a"))-                  @=? ltNumTerm (concSignedBV 1) (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a"))-                pevalLtNumTerm (concUnsignedBV 1) (pevalAddNumTerm (conTerm 2) (ssymTerm "a"))-                  @=? ltNumTerm (concUnsignedBV 1) (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")),-              testCase "On right constant and left add concrete BVs should not be simplified" $ do-                pevalLtNumTerm (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a")) (conTerm 1)-                  @=? ltNumTerm (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a")) (concSignedBV 1)-                pevalLtNumTerm (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")) (conTerm 1)-                  @=? ltNumTerm (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")) (concUnsignedBV 1),-              testCase "On right constant BVs should not be simplified" $ do-                pevalLtNumTerm (ssymTerm "a") (concSignedBV 1)-                  @=? ltNumTerm (ssymTerm "a" :: Term (IntN 5)) (concSignedBV 1)-                pevalLtNumTerm (ssymTerm "a") (concUnsignedBV 1)-                  @=? ltNumTerm (ssymTerm "a" :: Term (WordN 5)) (concUnsignedBV 1),-              testCase "On right constant and left uminus BVs should not be simplified" $ do-                pevalLtNumTerm (pevalUMinusNumTerm $ ssymTerm "a") (concSignedBV 1)-                  @=? ltNumTerm (pevalUMinusNumTerm $ ssymTerm "a" :: Term (IntN 5)) (concSignedBV 1)-                pevalLtNumTerm (pevalUMinusNumTerm $ ssymTerm "a") (concUnsignedBV 1)-                  @=? ltNumTerm (pevalUMinusNumTerm $ ssymTerm "a" :: Term (WordN 5)) (concUnsignedBV 1),-              testCase "On left add concrete BVs should not be simplified" $ do-                pevalLtNumTerm (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a")) (ssymTerm "b")-                  @=? ltNumTerm (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a")) (ssymTerm "b" :: Term (IntN 5))-                pevalLtNumTerm (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")) (ssymTerm "b")-                  @=? ltNumTerm (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")) (ssymTerm "b" :: Term (WordN 5)),-              testCase "On right add concrete BVs should not be simplified" $ do-                pevalLtNumTerm (ssymTerm "b") (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a"))-                  @=? ltNumTerm-                    (ssymTerm "b" :: Term (IntN 5))-                    (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a"))-                pevalLtNumTerm (ssymTerm "b") (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a"))-                  @=? ltNumTerm-                    (ssymTerm "b" :: Term (WordN 5))-                    (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")),-              testCase "On symbolic" $ do-                pevalLtNumTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b")-                  @=? ltNumTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b" :: Term Integer)-            ],-      let concSignedBV :: Integer -> Term (IntN 5) = conTerm . fromInteger-          concUnsignedBV :: Integer -> Term (WordN 5) = conTerm . fromInteger-       in testGroup-            "Le"-            [ testCase "On both concrete" $ do-                pevalLeNumTerm (conTerm 1 :: Term Integer) (conTerm 2) @=? conTerm True-                pevalLeNumTerm (conTerm 2 :: Term Integer) (conTerm 2) @=? conTerm True-                pevalLeNumTerm (conTerm 3 :: Term Integer) (conTerm 2) @=? conTerm False-                pevalLeNumTerm (conTerm 0 :: Term (IntN 2)) (conTerm 0) @=? conTerm True-                pevalLeNumTerm (conTerm 1 :: Term (IntN 2)) (conTerm 0) @=? conTerm False-                pevalLeNumTerm (conTerm 2 :: Term (IntN 2)) (conTerm 0) @=? conTerm True-                pevalLeNumTerm (conTerm 3 :: Term (IntN 2)) (conTerm 0) @=? conTerm True-                pevalLeNumTerm (conTerm 1 :: Term (WordN 2)) (conTerm 2) @=? conTerm True-                pevalLeNumTerm (conTerm 2 :: Term (WordN 2)) (conTerm 2) @=? conTerm True-                pevalLeNumTerm (conTerm 3 :: Term (WordN 2)) (conTerm 2) @=? conTerm False,-              testCase "On left constant and right add concrete Integers" $ do-                pevalLeNumTerm (conTerm 1 :: Term Integer) (pevalAddNumTerm (conTerm 2) (ssymTerm "a"))-                  @=? pevalLeNumTerm (conTerm $ -1 :: Term Integer) (ssymTerm "a"),-              testCase "On right constant and left add concrete Integers" $ do-                pevalLeNumTerm (pevalAddNumTerm (conTerm 2) (ssymTerm "a")) (conTerm 1 :: Term Integer)-                  @=? pevalLeNumTerm (conTerm 1 :: Term Integer) (pevalUMinusNumTerm $ ssymTerm "a"),-              testCase "On right constant Integers" $ do-                pevalLeNumTerm (ssymTerm "a") (conTerm 1 :: Term Integer)-                  @=? pevalLeNumTerm (conTerm $ -1 :: Term Integer) (pevalUMinusNumTerm $ ssymTerm "a"),-              testCase "On right constant left uminus Integers" $ do-                pevalLeNumTerm (pevalUMinusNumTerm $ ssymTerm "a") (conTerm 1 :: Term Integer)-                  @=? pevalLeNumTerm (conTerm $ -1 :: Term Integer) (ssymTerm "a"),-              testCase "On left add concrete Integers" $ do-                pevalLeNumTerm (pevalAddNumTerm (conTerm 2) (ssymTerm "a")) (ssymTerm "b" :: Term Integer)-                  @=? pevalLeNumTerm (conTerm 2 :: Term Integer) (pevalAddNumTerm (ssymTerm "b") (pevalUMinusNumTerm $ ssymTerm "a")),-              testCase "On right add concrete Integers" $ do-                pevalLeNumTerm (ssymTerm "b" :: Term Integer) (pevalAddNumTerm (conTerm 2) (ssymTerm "a"))-                  @=? pevalLeNumTerm (conTerm $ -2 :: Term Integer) (pevalAddNumTerm (ssymTerm "a") (pevalUMinusNumTerm $ ssymTerm "b")),-              testCase "On left constant and right add concrete BVs should not be simplified" $ do-                pevalLeNumTerm (concSignedBV 1) (pevalAddNumTerm (conTerm 2) (ssymTerm "a"))-                  @=? leNumTerm (concSignedBV 1) (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a"))-                pevalLeNumTerm (concUnsignedBV 1) (pevalAddNumTerm (conTerm 2) (ssymTerm "a"))-                  @=? leNumTerm (concUnsignedBV 1) (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")),-              testCase "On right constant and left add concrete BVs should not be simplified" $ do-                pevalLeNumTerm (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a")) (conTerm 1)-                  @=? leNumTerm (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a")) (concSignedBV 1)-                pevalLeNumTerm (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")) (conTerm 1)-                  @=? leNumTerm (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")) (concUnsignedBV 1),-              testCase "On right constant BVs should not be simplified" $ do-                pevalLeNumTerm (ssymTerm "a") (concSignedBV 1)-                  @=? leNumTerm (ssymTerm "a" :: Term (IntN 5)) (concSignedBV 1)-                pevalLeNumTerm (ssymTerm "a") (concUnsignedBV 1)-                  @=? leNumTerm (ssymTerm "a" :: Term (WordN 5)) (concUnsignedBV 1),-              testCase "On right constant and left uminus BVs should not be simplified" $ do-                pevalLeNumTerm (pevalUMinusNumTerm $ ssymTerm "a") (concSignedBV 1)-                  @=? leNumTerm (pevalUMinusNumTerm $ ssymTerm "a" :: Term (IntN 5)) (concSignedBV 1)-                pevalLeNumTerm (pevalUMinusNumTerm $ ssymTerm "a") (concUnsignedBV 1)-                  @=? leNumTerm (pevalUMinusNumTerm $ ssymTerm "a" :: Term (WordN 5)) (concUnsignedBV 1),-              testCase "On left add concrete BVs should not be simplified" $ do-                pevalLeNumTerm (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a")) (ssymTerm "b")-                  @=? leNumTerm (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a")) (ssymTerm "b" :: Term (IntN 5))-                pevalLeNumTerm (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")) (ssymTerm "b")-                  @=? leNumTerm (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")) (ssymTerm "b" :: Term (WordN 5)),-              testCase "Lt on right add concrete BVs should not be simplified" $ do-                pevalLeNumTerm (ssymTerm "b") (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a"))-                  @=? leNumTerm-                    (ssymTerm "b" :: Term (IntN 5))-                    (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a"))-                pevalLeNumTerm (ssymTerm "b") (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a"))-                  @=? leNumTerm-                    (ssymTerm "b" :: Term (WordN 5))-                    (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")),-              testCase "On symbolic" $ do-                pevalLeNumTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b")-                  @=? leNumTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b" :: Term Integer)-            ],-      testCase "Gt should be delegated to Lt" $-        pevalGtNumTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b")-          @=? pevalLtNumTerm (ssymTerm "b" :: Term Integer) (ssymTerm "a"),-      testCase "Ge should be delegated to Le" $ do-        pevalGeNumTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b")-          @=? pevalLeNumTerm (ssymTerm "b" :: Term Integer) (ssymTerm "a")-    ]
− test/Grisette/IR/SymPrim/Data/Prim/TabularFunTests.hs 
@@ -1,59 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators #-}--module Grisette.IR.SymPrim.Data.Prim.TabularFunTests (tabularFunTests) where--import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors-  ( conTerm,-    ssymTerm,-    tabularFunApplyTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term (Term)-import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool-  ( pevalEqvTerm,-    pevalITETerm,-  )-import Grisette.IR.SymPrim.Data.Prim.PartialEval.TabularFun-  ( pevalTabularFunApplyTerm,-  )-import Grisette.IR.SymPrim.Data.TabularFun-  ( type (=->) (TabularFun),-  )-import Test.Framework (Test, testGroup)-import Test.Framework.Providers.HUnit (testCase)-import Test.HUnit ((@=?))--tabularFunTests :: Test-tabularFunTests =-  testGroup-    "TabularFun"-    [ testGroup-        "ApplyF"-        [ testCase "On concrete" $ do-            let f :: Integer =-> Integer =-                  TabularFun [(1, 2), (3, 4)] 5-            pevalTabularFunApplyTerm (conTerm f) (conTerm 0) @=? conTerm 5-            pevalTabularFunApplyTerm (conTerm f) (conTerm 1) @=? conTerm 2-            pevalTabularFunApplyTerm (conTerm f) (conTerm 2) @=? conTerm 5-            pevalTabularFunApplyTerm (conTerm f) (conTerm 3) @=? conTerm 4-            pevalTabularFunApplyTerm (conTerm f) (conTerm 4) @=? conTerm 5,-          testCase "On concrete function" $ do-            let f :: Integer =-> Integer =-                  TabularFun [(1, 2), (3, 4)] 5-            pevalTabularFunApplyTerm (conTerm f) (ssymTerm "b")-              @=? pevalITETerm-                (pevalEqvTerm (conTerm 1 :: Term Integer) (ssymTerm "b"))-                (conTerm 2)-                ( pevalITETerm-                    (pevalEqvTerm (conTerm 3 :: Term Integer) (ssymTerm "b"))-                    (conTerm 4)-                    (conTerm 5)-                ),-          testCase "On symbolic" $ do-            pevalTabularFunApplyTerm (ssymTerm "f" :: Term (Integer =-> Integer)) (ssymTerm "a")-              @=? tabularFunApplyTerm-                (ssymTerm "f" :: Term (Integer =-> Integer))-                (ssymTerm "a" :: Term Integer)-        ]-    ]
− test/Grisette/IR/SymPrim/Data/SymPrimTests.hs 
@@ -1,1209 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NegativeLiterals #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeOperators #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}--module Grisette.IR.SymPrim.Data.SymPrimTests (symPrimTests) where--import Control.DeepSeq (NFData (rnf), force)-import Control.Exception-  ( ArithException (DivideByZero, Overflow, Underflow),-    catch,-    evaluate,-  )-import Control.Monad.Except (ExceptT, MonadError (throwError))-import Data.Bits-  ( Bits-      ( bit,-        bitSizeMaybe,-        complement,-        isSigned,-        popCount,-        rotate,-        shift,-        testBit,-        xor,-        (.&.),-        (.|.)-      ),-  )-import qualified Data.HashMap.Strict as M-import qualified Data.HashSet as S-import Data.Int (Int8)-import Data.Proxy (Proxy (Proxy))-import Data.Word (Word8)-import Grisette.Core.Control.Monad.UnionM (UnionM)-import Grisette.Core.Data.BV (IntN (IntN), WordN (WordN))-import Grisette.Core.Data.Class.BitVector-  ( SizedBV-      ( sizedBVConcat,-        sizedBVExt,-        sizedBVSelect,-        sizedBVSext,-        sizedBVZext-      ),-  )-import Grisette.Core.Data.Class.EvaluateSym-  ( EvaluateSym (evaluateSym),-  )-import Grisette.Core.Data.Class.ExtractSymbolics-  ( ExtractSymbolics (extractSymbolics),-  )-import Grisette.Core.Data.Class.Function (Apply (apply), Function ((#)))-import Grisette.Core.Data.Class.GenSym-  ( genSym,-    genSymSimple,-    nameWithInfo,-  )-import Grisette.Core.Data.Class.ITEOp (ITEOp (symIte))-import Grisette.Core.Data.Class.LogicalOp-  ( LogicalOp (symImplies, symNot, symXor, (.&&), (.||)),-  )-import Grisette.Core.Data.Class.Mergeable-  ( Mergeable (rootStrategy),-    MergingStrategy (SimpleStrategy),-  )-import Grisette.Core.Data.Class.ModelOps-  ( ModelOps (emptyModel, insertValue),-    ModelRep (buildModel),-  )-import Grisette.Core.Data.Class.SEq (SEq ((./=), (.==)))-import Grisette.Core.Data.Class.SOrd-  ( SOrd (symCompare, (.<), (.<=), (.>), (.>=)),-  )-import Grisette.Core.Data.Class.SafeDivision-  ( SafeDivision-      ( safeDiv,-        safeDiv',-        safeDivMod,-        safeDivMod',-        safeMod,-        safeMod',-        safeQuot,-        safeQuot',-        safeQuotRem,-        safeQuotRem',-        safeRem,-        safeRem'-      ),-  )-import Grisette.Core.Data.Class.SafeLinearArith-  ( SafeLinearArith-      ( safeAdd,-        safeAdd',-        safeMinus,-        safeMinus',-        safeNeg,-        safeNeg'-      ),-  )-import Grisette.Core.Data.Class.SimpleMergeable-  ( SimpleMergeable (mrgIte),-    merge,-    mrgIf,-    mrgSingle,-  )-import Grisette.Core.Data.Class.Solvable-  ( Solvable (con, conView, iinfosym, isym, ssym),-    pattern Con,-  )-import Grisette.Core.Data.Class.ToCon (ToCon (toCon))-import Grisette.Core.Data.Class.ToSym (ToSym (toSym))-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors-  ( conTerm,-    isymTerm,-    ssymTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term-  ( LinkedRep (wrapTerm),-    Term,-    TypedSymbol (SimpleSymbol),-    someTypedSymbol,-    type (-->),-  )-import Grisette.IR.SymPrim.Data.Prim.Model-  ( Model (Model),-    SymbolSet (SymbolSet),-  )-import Grisette.IR.SymPrim.Data.Prim.ModelValue (toModelValue)-import Grisette.IR.SymPrim.Data.Prim.PartialEval.BV-  ( pevalBVConcatTerm,-    pevalBVExtendTerm,-    pevalBVSelectTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bits-  ( pevalAndBitsTerm,-    pevalComplementBitsTerm,-    pevalOrBitsTerm,-    pevalRotateLeftTerm,-    pevalRotateRightTerm,-    pevalShiftLeftTerm,-    pevalShiftRightTerm,-    pevalXorBitsTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool-  ( pevalAndTerm,-    pevalEqvTerm,-    pevalITETerm,-    pevalImplyTerm,-    pevalNotTerm,-    pevalOrTerm,-    pevalXorTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.PartialEval.Integral-  ( pevalDivBoundedIntegralTerm,-    pevalDivIntegralTerm,-    pevalModBoundedIntegralTerm,-    pevalModIntegralTerm,-    pevalQuotBoundedIntegralTerm,-    pevalQuotIntegralTerm,-    pevalRemBoundedIntegralTerm,-    pevalRemIntegralTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.PartialEval.Num-  ( pevalAbsNumTerm,-    pevalAddNumTerm,-    pevalGeNumTerm,-    pevalGtNumTerm,-    pevalLeNumTerm,-    pevalLtNumTerm,-    pevalMinusNumTerm,-    pevalSignumNumTerm,-    pevalTimesNumTerm,-    pevalUMinusNumTerm,-  )-import Grisette.IR.SymPrim.Data.Prim.PartialEval.TabularFun-  ( pevalTabularFunApplyTerm,-  )-import Grisette.IR.SymPrim.Data.SymPrim-  ( ModelSymPair ((:=)),-    SymBool (SymBool),-    SymIntN (SymIntN),-    SymInteger (SymInteger),-    SymWordN (SymWordN),-    symSize,-    symsSize,-    (-->),-    type (-~>),-    type (=~>),-  )-import Grisette.IR.SymPrim.Data.TabularFun (type (=->))-import Test.Framework (Test, TestName, testGroup)-import Test.Framework.Providers.HUnit (testCase)-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.HUnit (Assertion, assertFailure, (@=?))-import Test.QuickCheck (Arbitrary, ioProperty)--newtype AEWrapper = AEWrapper ArithException deriving (Eq)--instance Show AEWrapper where-  show (AEWrapper x) = show x--instance NFData AEWrapper where-  rnf (AEWrapper x) = x `seq` ()--sameSafeDiv ::-  forall c s.-  ( Show s,-    Eq s,-    Eq c,-    Num c,-    Mergeable s,-    NFData c,-    Solvable c s-  ) =>-  c ->-  c ->-  (s -> s -> ExceptT ArithException UnionM s) ->-  (c -> c -> c) ->-  Assertion-sameSafeDiv i j f cf = do-  xc <- evaluate (force $ Right $ cf i j) `catch` \(e :: ArithException) -> return $ Left $ AEWrapper e-  case xc of-    Left (AEWrapper e) -> f (con i :: s) (con j) @=? merge (throwError e)-    Right c -> f (con i :: s) (con j) @=? mrgSingle (con c)--sameSafeDiv' ::-  forall c s.-  ( Show s,-    Eq s,-    Eq c,-    Num c,-    Mergeable s,-    NFData c,-    Solvable c s-  ) =>-  c ->-  c ->-  ((ArithException -> ()) -> s -> s -> ExceptT () UnionM s) ->-  (c -> c -> c) ->-  Assertion-sameSafeDiv' i j f cf = do-  xc <- evaluate (force $ Right $ cf i j) `catch` \(_ :: ArithException) -> return $ Left ()-  case xc of-    Left () -> f (const ()) (con i :: s) (con j) @=? merge (throwError ())-    Right c -> f (const ()) (con i :: s) (con j) @=? mrgSingle (con c)--sameSafeDivMod ::-  forall c s.-  ( Show s,-    Eq s,-    Eq c,-    Num c,-    Mergeable s,-    NFData c,-    Solvable c s-  ) =>-  c ->-  c ->-  (s -> s -> ExceptT ArithException UnionM (s, s)) ->-  (c -> c -> (c, c)) ->-  Assertion-sameSafeDivMod i j f cf = do-  xc <- evaluate (force $ Right $ cf i j) `catch` \(e :: ArithException) -> return $ Left $ AEWrapper e-  case xc of-    Left (AEWrapper e) -> f (con i :: s) (con j) @=? merge (throwError e)-    Right (c1, c2) -> f (con i :: s) (con j) @=? mrgSingle (con c1, con c2)--sameSafeDivMod' ::-  forall c s.-  ( Show s,-    Eq s,-    Eq c,-    Num c,-    Mergeable s,-    NFData c,-    Solvable c s-  ) =>-  c ->-  c ->-  ((ArithException -> ()) -> s -> s -> ExceptT () UnionM (s, s)) ->-  (c -> c -> (c, c)) ->-  Assertion-sameSafeDivMod' i j f cf = do-  xc <- evaluate (force $ Right $ cf i j) `catch` \(_ :: ArithException) -> return $ Left ()-  case xc of-    Left () -> f (const ()) (con i :: s) (con j) @=? merge (throwError ())-    Right (c1, c2) -> f (const ()) (con i :: s) (con j) @=? mrgSingle (con c1, con c2)--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) ->-  ((ArithException -> ()) -> s -> s -> ExceptT () UnionM s) ->-  (c -> c -> c) ->-  (Term c -> Term c -> Term c) ->-  [Test]-safeDivisionBoundedOnlyTests f f' cf pf =-  [ testCase "on concrete min divided by minus one" $ do-      sameSafeDiv minBound (-1) f cf-      sameSafeDiv' minBound (-1) f' cf,-    testCase "on symbolic" $ do-      f (ssym "a" :: s) (ssym "b")-        @=? ( mrgIf-                ((ssym "b" :: s) .== con (0 :: c) :: SymBool)-                (throwError DivideByZero)-                ( mrgIf-                    ((ssym "b" :: s) .== con (-1) .&& (ssym "a" :: s) .== con (minBound :: c) :: SymBool)-                    (throwError Overflow)-                    (mrgSingle $ wrapTerm $ pf (ssymTerm "a") (ssymTerm "b"))-                ) ::-                ExceptT ArithException UnionM s-            )-      f' (const ()) (ssym "a" :: s) (ssym "b")-        @=? ( mrgIf-                ((ssym "b" :: s) .== con (0 :: c) :: SymBool)-                (throwError ())-                ( mrgIf-                    ((ssym "b" :: s) .== con (-1) .&& (ssym "a" :: s) .== con (minBound :: c) :: SymBool)-                    (throwError ())-                    (mrgSingle $ wrapTerm $ pf (ssymTerm "a") (ssymTerm "b"))-                ) ::-                ExceptT () UnionM 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) ->-  ((ArithException -> ()) -> s -> s -> ExceptT () UnionM s) ->-  (Term c -> Term c -> Term c) ->-  [Test]-safeDivisionUnboundedOnlyTests f f' pf =-  [ testCase "on symbolic" $ do-      f (ssym "a" :: s) (ssym "b")-        @=? ( mrgIf-                ((ssym "b" :: s) .== con (0 :: c) :: SymBool)-                (throwError DivideByZero)-                (mrgSingle $ wrapTerm $ pf (ssymTerm "a") (ssymTerm "b")) ::-                ExceptT ArithException UnionM s-            )-      f' (const ()) (ssym "a" :: s) (ssym "b")-        @=? ( mrgIf-                ((ssym "b" :: s) .== con (0 :: c) :: SymBool)-                (throwError ())-                (mrgSingle $ wrapTerm $ pf (ssymTerm "a") (ssymTerm "b")) ::-                ExceptT () UnionM 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) =>-  (c0 -> c) ->-  (s -> s -> ExceptT ArithException UnionM s) ->-  ((ArithException -> ()) -> s -> s -> ExceptT () UnionM s) ->-  (c -> c -> c) ->-  [Test]-safeDivisionGeneralTests transform f f' cf =-  [ testProperty "on concrete prop" $ \(i0 :: c0, j0 :: c0) ->-      ioProperty $ do-        let i = transform i0-        let j = transform j0-        sameSafeDiv i j f cf-        sameSafeDiv' i j f' cf,-    testProperty "on concrete divided by zero" $ \(i0 :: c0) ->-      ioProperty $ do-        let i = transform i0-        sameSafeDiv i 0 f cf-        sameSafeDiv' i 0 f' cf,-    testCase "when divided by zero" $ do-      f (ssym "a" :: s) (con 0)-        @=? (merge $ throwError DivideByZero :: ExceptT ArithException UnionM s)-      f' (const ()) (ssym "a" :: s) (con 0)-        @=? (merge $ throwError () :: ExceptT () UnionM 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) =>-  TestName ->-  (c0 -> c) ->-  (s -> s -> ExceptT ArithException UnionM s) ->-  ((ArithException -> ()) -> s -> s -> ExceptT () UnionM s) ->-  (c -> c -> c) ->-  (Term c -> Term c -> Term c) ->-  Test-safeDivisionBoundedTests name transform f f' cf pf =-  testGroup name $-    safeDivisionGeneralTests transform f f' cf-      ++ safeDivisionBoundedOnlyTests f f' cf pf--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) =>-  TestName ->-  (c0 -> c) ->-  (s -> s -> ExceptT ArithException UnionM s) ->-  ((ArithException -> ()) -> s -> s -> ExceptT () UnionM s) ->-  (c -> c -> c) ->-  (Term c -> Term c -> Term c) ->-  Test-safeDivisionUnboundedTests name transform f f' cf pf =-  testGroup name $-    safeDivisionGeneralTests transform f f' cf-      ++ safeDivisionUnboundedOnlyTests f f' pf--safeDivModBoundedOnlyTests ::-  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, s)-  ) ->-  ( (ArithException -> ()) ->-    s ->-    s ->-    ExceptT () UnionM (s, s)-  ) ->-  (c -> c -> (c, c)) ->-  (Term c -> Term c -> Term c) ->-  (Term c -> Term c -> Term c) ->-  [Test]-safeDivModBoundedOnlyTests f f' cf pf1 pf2 =-  [ testCase "on concrete min divided by minus one" $ do-      sameSafeDivMod minBound (-1) f cf-      sameSafeDivMod' minBound (-1) f' cf,-    testCase "on symbolic" $ do-      f (ssym "a" :: s) (ssym "b")-        @=? ( mrgIf-                ((ssym "b" :: s) .== con (0 :: c) :: SymBool)-                (throwError DivideByZero)-                ( mrgIf-                    ((ssym "b" :: s) .== con (-1) .&& (ssym "a" :: s) .== con (minBound :: c) :: SymBool)-                    (throwError Overflow)-                    ( mrgSingle-                        ( wrapTerm $ pf1 (ssymTerm "a") (ssymTerm "b"),-                          wrapTerm $ pf2 (ssymTerm "a") (ssymTerm "b")-                        )-                    )-                ) ::-                ExceptT ArithException UnionM (s, s)-            )-      f' (const ()) (ssym "a" :: s) (ssym "b")-        @=? ( mrgIf-                ((ssym "b" :: s) .== con (0 :: c) :: SymBool)-                (throwError ())-                ( mrgIf-                    ((ssym "b" :: s) .== con (-1) .&& (ssym "a" :: s) .== con (minBound :: c) :: SymBool)-                    (throwError ())-                    ( mrgSingle-                        ( wrapTerm $ pf1 (ssymTerm "a") (ssymTerm "b"),-                          wrapTerm $ pf2 (ssymTerm "a") (ssymTerm "b")-                        )-                    )-                ) ::-                ExceptT () UnionM (s, s)-            )-  ]--safeDivModUnboundedOnlyTests ::-  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, s)-  ) ->-  ( (ArithException -> ()) ->-    s ->-    s ->-    ExceptT () UnionM (s, s)-  ) ->-  (Term c -> Term c -> Term c) ->-  (Term c -> Term c -> Term c) ->-  [Test]-safeDivModUnboundedOnlyTests f f' pf1 pf2 =-  [ testCase "on symbolic" $ do-      f (ssym "a" :: s) (ssym "b")-        @=? ( mrgIf-                ((ssym "b" :: s) .== con (0 :: c) :: SymBool)-                (throwError DivideByZero)-                ( mrgSingle-                    ( wrapTerm $ pf1 (ssymTerm "a") (ssymTerm "b"),-                      wrapTerm $ pf2 (ssymTerm "a") (ssymTerm "b")-                    )-                ) ::-                ExceptT ArithException UnionM (s, s)-            )-      f' (const ()) (ssym "a" :: s) (ssym "b")-        @=? ( mrgIf-                ((ssym "b" :: s) .== con (0 :: c) :: SymBool)-                (throwError ())-                ( mrgSingle-                    ( wrapTerm $ pf1 (ssymTerm "a") (ssymTerm "b"),-                      wrapTerm $ pf2 (ssymTerm "a") (ssymTerm "b")-                    )-                ) ::-                ExceptT () UnionM (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) =>-  (c0 -> c) ->-  ( s ->-    s ->-    ExceptT ArithException UnionM (s, s)-  ) ->-  ( (ArithException -> ()) ->-    s ->-    s ->-    ExceptT () UnionM (s, s)-  ) ->-  (c -> c -> (c, c)) ->-  [Test]-safeDivModGeneralTests transform f f' cf =-  [ testProperty "on concrete" $ \(i0 :: c0, j0 :: c0) ->-      ioProperty $ do-        let i = transform i0-        let j = transform j0-        sameSafeDivMod i j f cf-        sameSafeDivMod' i j f' cf,-    testProperty "on concrete divided by zero" $ \(i0 :: c0) ->-      ioProperty $ do-        let i = transform i0-        sameSafeDivMod i 0 f cf-        sameSafeDivMod' i 0 f' cf,-    testCase "when divided by zero" $ do-      f (ssym "a" :: s) (con 0)-        @=? (merge $ throwError DivideByZero :: ExceptT ArithException UnionM (s, s))-      f' (const ()) (ssym "a" :: s) (con 0)-        @=? (merge $ throwError () :: ExceptT () UnionM (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) =>-  TestName ->-  (c0 -> c) ->-  ( s ->-    s ->-    ExceptT ArithException UnionM (s, s)-  ) ->-  ( (ArithException -> ()) ->-    s ->-    s ->-    ExceptT () UnionM (s, s)-  ) ->-  (c -> c -> (c, c)) ->-  (Term c -> Term c -> Term c) ->-  (Term c -> Term c -> Term c) ->-  Test-safeDivModBoundedTests name transform f f' cf pf1 pf2 =-  testGroup name $-    safeDivModGeneralTests transform f f' cf-      ++ safeDivModBoundedOnlyTests f f' cf pf1 pf2--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) =>-  TestName ->-  (c0 -> c) ->-  ( s ->-    s ->-    ExceptT ArithException UnionM (s, s)-  ) ->-  ( (ArithException -> ()) ->-    s ->-    s ->-    ExceptT () UnionM (s, s)-  ) ->-  (c -> c -> (c, c)) ->-  (Term c -> Term c -> Term c) ->-  (Term c -> Term c -> Term c) ->-  Test-safeDivModUnboundedTests name transform f f' cf pf1 pf2 =-  testGroup name $-    safeDivModGeneralTests transform f f' cf-      ++ safeDivModUnboundedOnlyTests f f' pf1 pf2--symPrimTests :: Test-symPrimTests =-  testGroup-    "SymPrim"-    [ testGroup-        "General SymPrim"-        [ testGroup-            "Solvable"-            [ testCase "con" $ (con 1 :: SymInteger) @=? SymInteger (conTerm 1),-              testCase "ssym" $ (ssym "a" :: SymInteger) @=? SymInteger (ssymTerm "a"),-              testCase "isym" $ (isym "a" 1 :: SymInteger) @=? SymInteger (isymTerm "a" 1),-              testCase "conView" $ do-                conView (con 1 :: SymInteger) @=? Just 1-                conView (ssym "a" :: SymInteger) @=? Nothing-                case con 1 :: SymInteger of-                  Con 1 -> return ()-                  _ -> assertFailure "Bad match"-                case ssym "a" :: SymInteger of-                  Con _ -> assertFailure "Bad match"-                  _ -> return ()-            ],-          testGroup-            "ITEOp"-            [ testCase "symIte" $-                symIte (ssym "a" :: SymBool) (ssym "b" :: SymInteger) (ssym "c")-                  @=? SymInteger (pevalITETerm (ssymTerm "a") (ssymTerm "b") (ssymTerm "c"))-            ],-          testCase "Mergeable" $ do-            let SimpleStrategy s = rootStrategy :: MergingStrategy SymInteger-            s (ssym "a") (ssym "b") (ssym "c")-              @=? symIte (ssym "a" :: SymBool) (ssym "b" :: SymInteger) (ssym "c"),-          testCase "SimpleMergeable" $-            mrgIte (ssym "a" :: SymBool) (ssym "b") (ssym "c")-              @=? symIte (ssym "a" :: SymBool) (ssym "b" :: SymInteger) (ssym "c"),-          testCase "IsString" $ ("a" :: SymBool) @=? SymBool (ssymTerm "a"),-          testGroup-            "ToSym"-            [ testCase "From self" $ toSym (ssym "a" :: SymBool) @=? (ssym "a" :: SymBool),-              testCase "From concrete" $ toSym True @=? (con True :: SymBool)-            ],-          testGroup-            "ToCon"-            [ testCase "To self" $ toCon (ssym "a" :: SymBool) @=? (Nothing :: Maybe Bool),-              testCase "To concrete" $ toCon True @=? Just True-            ],-          testCase "EvaluateSym" $ do-            let m1 = emptyModel :: Model-            let m2 = insertValue (SimpleSymbol "a") (1 :: Integer) m1-            let m3 = insertValue (SimpleSymbol "b") True m2-            evaluateSym 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))-              @=? SymbolSet-                ( S.fromList-                    [ someTypedSymbol (SimpleSymbol "c" :: TypedSymbol Bool),-                      someTypedSymbol (SimpleSymbol "a" :: TypedSymbol Integer),-                      someTypedSymbol (SimpleSymbol "b" :: TypedSymbol Integer)-                    ]-                ),-          testCase "GenSym" $ do-            (genSym () "a" :: UnionM SymBool) @=? mrgSingle (isym "a" 0)-            (genSymSimple () "a" :: SymBool) @=? isym "a" 0-            (genSym (ssym "a" :: SymBool) "a" :: UnionM SymBool) @=? mrgSingle (isym "a" 0)-            (genSymSimple (ssym "a" :: SymBool) "a" :: SymBool) @=? isym "a" 0-            (genSym () (nameWithInfo "a" True) :: UnionM SymBool) @=? mrgSingle (iinfosym "a" 0 True)-            (genSymSimple () (nameWithInfo "a" True) :: SymBool) @=? iinfosym "a" 0 True,-          testCase "SEq" $ do-            (ssym "a" :: SymBool) .== ssym "b" @=? SymBool (pevalEqvTerm (ssymTerm "a" :: Term Bool) (ssymTerm "b"))-            (ssym "a" :: SymBool) ./= ssym "b" @=? SymBool (pevalNotTerm $ pevalEqvTerm (ssymTerm "a" :: Term Bool) (ssymTerm "b"))-        ],-      testGroup-        "SymBool"-        [ testGroup-            "LogicalOp"-            [ testCase ".||" $ ssym "a" .|| ssym "b" @=? SymBool (pevalOrTerm (ssymTerm "a") (ssymTerm "b")),-              testCase ".&&" $ ssym "a" .&& ssym "b" @=? SymBool (pevalAndTerm (ssymTerm "a") (ssymTerm "b")),-              testCase "symNot" $ symNot (ssym "a") @=? SymBool (pevalNotTerm (ssymTerm "a")),-              testCase "symXor" $ symXor (ssym "a") (ssym "b") @=? SymBool (pevalXorTerm (ssymTerm "a") (ssymTerm "b")),-              testCase "symImplies" $ symImplies (ssym "a") (ssym "b") @=? SymBool (pevalImplyTerm (ssymTerm "a") (ssymTerm "b"))-            ]-        ],-      testGroup-        "SymInteger"-        [ testGroup-            "Num"-            [ testCase "fromInteger" $ (1 :: SymInteger) @=? SymInteger (conTerm 1),-              testCase "(+)" $ (ssym "a" :: SymInteger) + ssym "b" @=? SymInteger (pevalAddNumTerm (ssymTerm "a") (ssymTerm "b")),-              testCase "(-)" $ (ssym "a" :: SymInteger) - ssym "b" @=? SymInteger (pevalMinusNumTerm (ssymTerm "a") (ssymTerm "b")),-              testCase "(*)" $ (ssym "a" :: SymInteger) * ssym "b" @=? SymInteger (pevalTimesNumTerm (ssymTerm "a") (ssymTerm "b")),-              testCase "negate" $ negate (ssym "a" :: SymInteger) @=? SymInteger (pevalUMinusNumTerm (ssymTerm "a")),-              testCase "abs" $ abs (ssym "a" :: SymInteger) @=? SymInteger (pevalAbsNumTerm (ssymTerm "a")),-              testCase "signum" $ signum (ssym "a" :: SymInteger) @=? SymInteger (pevalSignumNumTerm (ssymTerm "a"))-            ],-          testGroup-            "SafeDivision"-            [ safeDivisionUnboundedTests @Integer "safeDiv" id safeDiv safeDiv' div pevalDivIntegralTerm,-              safeDivisionUnboundedTests @Integer "safeMod" id safeMod safeMod' mod pevalModIntegralTerm,-              safeDivModUnboundedTests @Integer "safeDivMod" id safeDivMod safeDivMod' divMod pevalDivIntegralTerm pevalModIntegralTerm,-              safeDivisionUnboundedTests @Integer "safeQuot" id safeQuot safeQuot' quot pevalQuotIntegralTerm,-              safeDivisionUnboundedTests @Integer "safeRem" id safeRem safeRem' rem pevalRemIntegralTerm,-              safeDivModUnboundedTests @Integer "safeQuotRem" id safeQuotRem safeQuotRem' quotRem pevalQuotIntegralTerm pevalRemIntegralTerm-            ],-          testGroup-            "SafeLinearArith"-            [ testProperty "safeAdd on concrete" $ \(i :: Integer, j :: Integer) ->-                ioProperty $ do-                  safeAdd (con i :: SymInteger) (con j)-                    @=? (mrgSingle $ con $ i + j :: ExceptT ArithException UnionM SymInteger)-                  safeAdd' (const ()) (con i :: SymInteger) (con j)-                    @=? (mrgSingle $ con $ i + j :: ExceptT () UnionM SymInteger),-              testCase "safeAdd on symbolic" $ do-                safeAdd (ssym "a" :: SymInteger) (ssym "b")-                  @=? (mrgSingle $ SymInteger $ pevalAddNumTerm (ssymTerm "a") (ssymTerm "b") :: ExceptT ArithException UnionM SymInteger)-                safeAdd' (const ()) (ssym "a" :: SymInteger) (ssym "b")-                  @=? (mrgSingle $ SymInteger $ pevalAddNumTerm (ssymTerm "a") (ssymTerm "b") :: ExceptT () UnionM SymInteger),-              testProperty "safeNeg on concrete" $ \(i :: Integer) ->-                ioProperty $ do-                  safeNeg (con i :: SymInteger)-                    @=? (mrgSingle $ con $ -i :: ExceptT ArithException UnionM SymInteger)-                  safeNeg' (const ()) (con i :: SymInteger)-                    @=? (mrgSingle $ con $ -i :: ExceptT () UnionM SymInteger),-              testCase "safeNeg on symbolic" $ do-                safeNeg (ssym "a" :: SymInteger)-                  @=? (mrgSingle $ SymInteger $ pevalUMinusNumTerm (ssymTerm "a") :: ExceptT ArithException UnionM SymInteger)-                safeNeg' (const ()) (ssym "a" :: SymInteger)-                  @=? (mrgSingle $ SymInteger $ pevalUMinusNumTerm (ssymTerm "a") :: ExceptT () UnionM SymInteger),-              testProperty "safeMinus on concrete" $ \(i :: Integer, j :: Integer) ->-                ioProperty $ do-                  safeMinus (con i :: SymInteger) (con j)-                    @=? (mrgSingle $ con $ i - j :: ExceptT ArithException UnionM SymInteger)-                  safeMinus' (const ()) (con i :: SymInteger) (con j)-                    @=? (mrgSingle $ con $ i - j :: ExceptT () UnionM SymInteger),-              testCase "safeMinus on symbolic" $ do-                safeMinus (ssym "a" :: SymInteger) (ssym "b")-                  @=? (mrgSingle $ SymInteger $ pevalMinusNumTerm (ssymTerm "a") (ssymTerm "b") :: ExceptT ArithException UnionM SymInteger)-                safeMinus' (const ()) (ssym "a" :: SymInteger) (ssym "b")-                  @=? (mrgSingle $ SymInteger $ pevalMinusNumTerm (ssymTerm "a") (ssymTerm "b") :: ExceptT () UnionM SymInteger)-            ],-          testGroup-            "SOrd"-            [ testProperty "SOrd 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-                let a :: SymInteger = ssym "a"-                let b :: SymInteger = ssym "b"-                let at :: Term Integer = ssymTerm "a"-                let bt :: Term Integer = ssymTerm "b"-                a .<= b @=? SymBool (pevalLeNumTerm at bt)-                a .< b @=? SymBool (pevalLtNumTerm at bt)-                a .>= b @=? SymBool (pevalGeNumTerm at bt)-                a .> b @=? SymBool (pevalGtNumTerm at bt)-                (a `symCompare` ssym "b" :: UnionM Ordering)-                  @=? mrgIf (a .< b) (mrgSingle LT) (mrgIf (a .== b) (mrgSingle EQ) (mrgSingle GT))-            ]-        ],-      let au :: SymWordN 4 = ssym "a"-          bu :: SymWordN 4 = ssym "b"-          as :: SymIntN 4 = ssym "a"-          bs :: SymIntN 4 = ssym "b"-          aut :: Term (WordN 4) = ssymTerm "a"-          but :: Term (WordN 4) = ssymTerm "b"-          ast :: Term (IntN 4) = ssymTerm "a"-          bst :: Term (IntN 4) = ssymTerm "b"-       in testGroup-            "Sym BV"-            [ testGroup-                "Num"-                [ testCase "fromInteger" $ do-                    (1 :: SymWordN 4) @=? SymWordN (conTerm 1)-                    (1 :: SymIntN 4) @=? SymIntN (conTerm 1),-                  testCase "(+)" $ do-                    au + bu @=? SymWordN (pevalAddNumTerm aut but)-                    as + bs @=? SymIntN (pevalAddNumTerm ast bst),-                  testCase "(-)" $ do-                    au - bu @=? SymWordN (pevalMinusNumTerm aut but)-                    as - bs @=? SymIntN (pevalMinusNumTerm ast bst),-                  testCase "(*)" $ do-                    au * bu @=? SymWordN (pevalTimesNumTerm aut but)-                    as * bs @=? SymIntN (pevalTimesNumTerm ast bst),-                  testCase "negate" $ do-                    negate au @=? SymWordN (pevalUMinusNumTerm aut)-                    negate as @=? SymIntN (pevalUMinusNumTerm ast),-                  testCase "abs" $ do-                    abs au @=? SymWordN (pevalAbsNumTerm aut)-                    abs as @=? SymIntN (pevalAbsNumTerm ast),-                  testCase "signum" $ do-                    signum au @=? SymWordN (pevalSignumNumTerm aut)-                    signum as @=? SymIntN (pevalSignumNumTerm ast)-                ],-              testGroup-                "SafeDivision"-                [ testGroup-                    "WordN"-                    [ safeDivisionUnboundedTests @(WordN 4) "safeDiv" WordN safeDiv safeDiv' div pevalDivIntegralTerm,-                      safeDivisionUnboundedTests @(WordN 4) "safeMod" WordN safeMod safeMod' mod pevalModIntegralTerm,-                      safeDivModUnboundedTests @(WordN 4) "safeDivMod" WordN safeDivMod safeDivMod' divMod pevalDivIntegralTerm pevalModIntegralTerm,-                      safeDivisionUnboundedTests @(WordN 4) "safeQuot" WordN safeQuot safeQuot' quot pevalQuotIntegralTerm,-                      safeDivisionUnboundedTests @(WordN 4) "safeRem" WordN safeRem safeRem' rem pevalRemIntegralTerm,-                      safeDivModUnboundedTests @(WordN 4) "safeQuotRem" WordN safeQuotRem safeQuotRem' divMod pevalQuotIntegralTerm pevalRemIntegralTerm-                    ],-                  testGroup-                    "IntN"-                    [ safeDivisionBoundedTests @(IntN 4) "safeDiv" IntN safeDiv safeDiv' div pevalDivBoundedIntegralTerm,-                      safeDivisionUnboundedTests @(IntN 4) "safeMod" IntN safeMod safeMod' mod pevalModBoundedIntegralTerm,-                      safeDivModBoundedTests @(IntN 4) "safeDivMod" IntN safeDivMod safeDivMod' divMod pevalDivBoundedIntegralTerm pevalModBoundedIntegralTerm,-                      safeDivisionBoundedTests @(IntN 4) "safeQuot" IntN safeQuot safeQuot' quot pevalQuotBoundedIntegralTerm,-                      safeDivisionUnboundedTests @(IntN 4) "safeRem" IntN safeRem safeRem' rem pevalRemBoundedIntegralTerm,-                      safeDivModBoundedTests @(IntN 4) "safeQuotRem" IntN safeQuotRem safeQuotRem' quotRem pevalQuotBoundedIntegralTerm pevalRemBoundedIntegralTerm-                    ]-                ],-              testGroup-                "SafeLinearArith"-                [ testGroup-                    "IntN"-                    [ testProperty "safeAdd on concrete" $ \(i :: Int8, j :: Int8) ->-                        ioProperty $-                          let iint = fromIntegral i :: Integer-                              jint = fromIntegral j-                           in safeAdd (toSym i :: SymIntN 8) (toSym j)-                                @=? mrgIf-                                  (iint + jint .< fromIntegral (i + j))-                                  (throwError Underflow)-                                  ( mrgIf-                                      (iint + jint .> fromIntegral (i + j))-                                      (throwError Overflow)-                                      (mrgSingle $ toSym $ i + j :: ExceptT ArithException UnionM (SymIntN 8))-                                  ),-                      testProperty "safeMinus on concrete" $ \(i :: Int8, j :: Int8) ->-                        ioProperty $-                          let iint = fromIntegral i :: Integer-                              jint = fromIntegral j-                           in safeMinus (toSym i :: SymIntN 8) (toSym j)-                                @=? mrgIf-                                  (iint - jint .< fromIntegral (i - j))-                                  (throwError Underflow)-                                  ( mrgIf-                                      (iint - jint .> fromIntegral (i - j))-                                      (throwError Overflow)-                                      (mrgSingle $ toSym $ i - j :: ExceptT ArithException UnionM (SymIntN 8))-                                  ),-                      testProperty "safeNeg on concrete" $ \(i :: Int8) ->-                        ioProperty $-                          let iint = fromIntegral i :: Integer-                           in safeNeg (toSym i :: SymIntN 8)-                                @=? mrgIf-                                  (-iint .< fromIntegral (-i))-                                  (throwError Underflow)-                                  ( mrgIf-                                      (-iint .> fromIntegral (-i))-                                      (throwError Overflow)-                                      (mrgSingle $ toSym $ -i :: ExceptT ArithException UnionM (SymIntN 8))-                                  )-                    ],-                  testGroup-                    "WordN"-                    [ testProperty "safeAdd on concrete" $ \(i :: Word8, j :: Word8) ->-                        ioProperty $-                          let iint = fromIntegral i :: Integer-                              jint = fromIntegral j-                           in safeAdd (toSym i :: SymWordN 8) (toSym j)-                                @=? mrgIf-                                  (iint + jint .< fromIntegral (i + j))-                                  (throwError Underflow)-                                  ( mrgIf-                                      (iint + jint .> fromIntegral (i + j))-                                      (throwError Overflow)-                                      (mrgSingle $ toSym $ i + j :: ExceptT ArithException UnionM (SymWordN 8))-                                  ),-                      testProperty "safeMinus on concrete" $ \(i :: Word8, j :: Word8) ->-                        ioProperty $-                          let iint = fromIntegral i :: Integer-                              jint = fromIntegral j-                           in safeMinus (toSym i :: SymWordN 8) (toSym j)-                                @=? mrgIf-                                  (iint - jint .< fromIntegral (i - j))-                                  (throwError Underflow)-                                  ( mrgIf-                                      (iint - jint .> fromIntegral (i - j))-                                      (throwError Overflow)-                                      (mrgSingle $ toSym $ i - j :: ExceptT ArithException UnionM (SymWordN 8))-                                  ),-                      testProperty "safeNeg on concrete" $ \(i :: Word8) ->-                        ioProperty $-                          let iint = fromIntegral i :: Integer-                           in safeNeg (toSym i :: SymWordN 8)-                                @=? mrgIf-                                  (-iint .< fromIntegral (-i))-                                  (throwError Underflow)-                                  ( mrgIf-                                      (-iint .> fromIntegral (-i))-                                      (throwError Overflow)-                                      (mrgSingle $ toSym $ -i :: ExceptT ArithException UnionM (SymWordN 8))-                                  )-                    ]-                ],-              testGroup-                "SOrd"-                [ testProperty "SOrd 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-                    let js :: IntN 4 = fromInteger j-                    let normalizeu k = k - k `div` 16 * 16-                    let normalizes k = if normalizeu k >= 8 then normalizeu k - 16 else normalizeu k-                    (con iu :: SymWordN 4) .<= con ju @=? (con (normalizeu i <= normalizeu j) :: SymBool)-                    (con iu :: SymWordN 4) .< con ju @=? (con (normalizeu i < normalizeu j) :: SymBool)-                    (con iu :: SymWordN 4) .>= con ju @=? (con (normalizeu i >= normalizeu j) :: SymBool)-                    (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)-                    (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-                    au .<= bu @=? SymBool (pevalLeNumTerm aut but)-                    au .< bu @=? SymBool (pevalLtNumTerm aut but)-                    au .>= bu @=? SymBool (pevalGeNumTerm aut but)-                    au .> bu @=? SymBool (pevalGtNumTerm aut but)-                    (au `symCompare` bu :: UnionM Ordering)-                      @=? mrgIf (au .< bu) (mrgSingle LT) (mrgIf (au .== bu) (mrgSingle EQ) (mrgSingle GT))--                    as .<= bs @=? SymBool (pevalLeNumTerm ast bst)-                    as .< bs @=? SymBool (pevalLtNumTerm ast bst)-                    as .>= bs @=? SymBool (pevalGeNumTerm ast bst)-                    as .> bs @=? SymBool (pevalGtNumTerm ast bst)-                    (as `symCompare` bs :: UnionM Ordering)-                      @=? mrgIf (as .< bs) (mrgSingle LT) (mrgIf (as .== bs) (mrgSingle EQ) (mrgSingle GT))-                ],-              testGroup-                "Bits"-                [ testCase ".&." $ do-                    au .&. bu @=? SymWordN (pevalAndBitsTerm aut but)-                    as .&. bs @=? SymIntN (pevalAndBitsTerm ast bst),-                  testCase ".|." $ do-                    au .|. bu @=? SymWordN (pevalOrBitsTerm aut but)-                    as .|. bs @=? SymIntN (pevalOrBitsTerm ast bst),-                  testCase "xor" $ do-                    au `xor` bu @=? SymWordN (pevalXorBitsTerm aut but)-                    as `xor` bs @=? SymIntN (pevalXorBitsTerm ast bst),-                  testCase "complement" $ do-                    complement au @=? SymWordN (pevalComplementBitsTerm aut)-                    complement as @=? SymIntN (pevalComplementBitsTerm ast),-                  testCase "shift" $ do-                    shift au 1 @=? SymWordN (pevalShiftLeftTerm aut $ conTerm 1)-                    shift as 1 @=? SymIntN (pevalShiftLeftTerm ast $ conTerm 1)-                    shift au (-1) @=? SymWordN (pevalShiftRightTerm aut $ conTerm 1)-                    shift as (-1) @=? SymIntN (pevalShiftRightTerm ast $ conTerm 1),-                  testCase "rotate" $ do-                    rotate au 1 @=? SymWordN (pevalRotateLeftTerm aut $ conTerm 1)-                    rotate as 1 @=? SymIntN (pevalRotateLeftTerm ast $ conTerm 1)-                    rotate au (-1) @=? SymWordN (pevalRotateRightTerm aut $ conTerm 1)-                    rotate as (-1) @=? SymIntN (pevalRotateRightTerm ast $ conTerm 1),-                  testCase "bitSize" $ do-                    bitSizeMaybe au @=? Just 4-                    bitSizeMaybe as @=? Just 4,-                  testCase "isSigned" $ do-                    isSigned au @=? False-                    isSigned as @=? True,-                  testCase "testBit would only work on concrete ones" $ do-                    testBit (con 3 :: SymWordN 4) 1 @=? True-                    testBit (con 3 :: SymWordN 4) 2 @=? False-                    testBit (con 3 :: SymIntN 4) 1 @=? True-                    testBit (con 3 :: SymIntN 4) 2 @=? False,-                  testCase "bit would work" $ do-                    bit 1 @=? (con 2 :: SymWordN 4)-                    bit 1 @=? (con 2 :: SymIntN 4),-                  testCase "popCount would only work on concrete ones" $ do-                    popCount (con 3 :: SymWordN 4) @=? 2-                    popCount (con 3 :: SymWordN 4) @=? 2-                    popCount (con 3 :: SymIntN 4) @=? 2-                    popCount (con 3 :: SymIntN 4) @=? 2-                ],-              testGroup-                "sizedBVConcat"-                [ testCase "sizedBVConcat" $-                    sizedBVConcat-                      (ssym "a" :: SymWordN 4)-                      (ssym "b" :: SymWordN 3)-                      @=? SymWordN-                        ( pevalBVConcatTerm-                            (ssymTerm "a" :: Term (WordN 4))-                            (ssymTerm "b" :: Term (WordN 3))-                        )-                ],-              testGroup-                "sizedBVExt for Sym BV"-                [ testCase "sizedBVZext" $ do-                    sizedBVZext (Proxy @6) au @=? SymWordN (pevalBVExtendTerm False (Proxy @6) aut)-                    sizedBVZext (Proxy @6) as @=? SymIntN (pevalBVExtendTerm False (Proxy @6) ast),-                  testCase "sizedBVSext" $ do-                    sizedBVSext (Proxy @6) au @=? SymWordN (pevalBVExtendTerm True (Proxy @6) aut)-                    sizedBVSext (Proxy @6) as @=? SymIntN (pevalBVExtendTerm True (Proxy @6) ast),-                  testCase "sizedBVExt" $ do-                    sizedBVExt (Proxy @6) au @=? SymWordN (pevalBVExtendTerm False (Proxy @6) aut)-                    sizedBVExt (Proxy @6) as @=? SymIntN (pevalBVExtendTerm True (Proxy @6) ast)-                ],-              testGroup-                "sizedBVSelect for Sym BV"-                [ testCase "sizedBVSelect" $ do-                    sizedBVSelect (Proxy @2) (Proxy @1) au-                      @=? SymWordN (pevalBVSelectTerm (Proxy @2) (Proxy @1) aut)-                    sizedBVSelect (Proxy @2) (Proxy @1) as-                      @=? SymIntN (pevalBVSelectTerm (Proxy @2) (Proxy @1) ast)-                ],-              testGroup-                "conversion between Int8 and Sym BV"-                [ testCase "toSym" $ do-                    toSym (0 :: Int8) @=? (con 0 :: SymIntN 8)-                    toSym (-127 :: Int8) @=? (con $ -127 :: SymIntN 8)-                    toSym (-128 :: Int8) @=? (con $ -128 :: SymIntN 8)-                    toSym (127 :: Int8) @=? (con 127 :: SymIntN 8),-                  testCase "toCon" $ do-                    toCon (con 0 :: SymIntN 8) @=? Just (0 :: Int8)-                    toCon (con $ -127 :: SymIntN 8) @=? Just (-127 :: Int8)-                    toCon (con $ -128 :: SymIntN 8) @=? Just (-128 :: Int8)-                    toCon (con 127 :: SymIntN 8) @=? Just (127 :: Int8)-                ],-              testGroup-                "conversion between Word8 and Sym BV"-                [ testCase "toSym" $ do-                    toSym (0 :: Word8) @=? (con 0 :: SymWordN 8)-                    toSym (1 :: Word8) @=? (con 1 :: SymWordN 8)-                    toSym (255 :: Word8) @=? (con 255 :: SymWordN 8),-                  testCase "toCon" $ do-                    toCon (con 0 :: SymWordN 8) @=? Just (0 :: Word8)-                    toCon (con 1 :: SymWordN 8) @=? Just (1 :: Word8)-                    toCon (con 255 :: SymWordN 8) @=? Just (255 :: Word8)-                ]-            ],-      testGroup-        "TabularFun"-        [ testCase "#" $-            (ssym "a" :: SymInteger =~> SymInteger)-              # ssym "b"-              @=? SymInteger (pevalTabularFunApplyTerm (ssymTerm "a" :: Term (Integer =-> Integer)) (ssymTerm "b")),-          testCase "apply" $-            apply-              (ssym "f" :: SymInteger =~> SymInteger =~> SymInteger)-              (ssym "a")-              (ssym "b")-              @=? SymInteger-                ( pevalTabularFunApplyTerm-                    ( pevalTabularFunApplyTerm-                        (ssymTerm "f" :: Term (Integer =-> Integer =-> Integer))-                        (ssymTerm "a")-                    )-                    (ssymTerm "b")-                )-        ],-      testGroup-        "GeneralFun"-        [ testCase "evaluate" $ do-            evaluateSym-              False-              (buildModel ("a" := (1 :: Integer), "b" := (2 :: Integer)))-              (con ("a" --> "a" + "b") :: SymInteger -~> SymInteger)-              @=? (con ("a" --> "a" + 2) :: SymInteger -~> SymInteger)-            evaluateSym-              False-              (buildModel ("a" := (1 :: Integer), "b" := (2 :: Integer), "c" := (3 :: Integer)))-              (con ("a" --> con ("b" --> "a" + "b" + "c")) :: SymInteger -~> SymInteger -~> SymInteger)-              @=? con ("a" --> con ("b" --> "a" + "b" + 3) :: Integer --> Integer --> Integer),-          testCase "#" $ do-            let f :: SymInteger -~> SymInteger -~> SymInteger =-                  con ("a" --> con ("b" --> "a" + "b"))-            f # ssym "x" @=? con ("b" --> "x" + "b"),-          testCase "apply" $ do-            let f :: SymInteger -~> SymInteger -~> SymInteger =-                  con ("a" --> con ("b" --> "a" + "b"))-            apply f "x" "y" @=? "x" + "y"-        ],-      testGroup-        "Symbolic size"-        [ testCase "symSize" $ do-            symSize (ssym "a" :: SymInteger) @=? 1-            symSize (con 1 :: SymInteger) @=? 1-            symSize (con 1 + ssym "a" :: SymInteger) @=? 3-            symSize (ssym "a" + ssym "a" :: SymInteger) @=? 2-            symSize (-(ssym "a") :: SymInteger) @=? 2-            symSize (symIte (ssym "a" :: SymBool) (ssym "b") (ssym "c") :: SymInteger) @=? 4,-          testCase "symsSize" $ symsSize [ssym "a" :: SymInteger, ssym "a" + ssym "a"] @=? 2-        ],-      let asymbol :: TypedSymbol Integer = "a"-          bsymbol :: TypedSymbol Bool = "b"-          csymbol :: TypedSymbol Integer = "c"-          dsymbol :: TypedSymbol Bool = "d"-          esymbol :: TypedSymbol (WordN 4) = "e"-          fsymbol :: TypedSymbol (IntN 4) = "f"-          gsymbol :: TypedSymbol (WordN 16) = "g"-          hsymbol :: TypedSymbol (IntN 16) = "h"-          va :: Integer = 1-          vc :: Integer = 2-          ve :: WordN 4 = 3-          vf :: IntN 4 = 4-          vg :: WordN 16 = 5-          vh :: IntN 16 = 6-       in testCase-            "construting Model from ModelSymPair"-            $ do-              buildModel ("a" := va) @=? Model (M.singleton (someTypedSymbol asymbol) (toModelValue va))-              buildModel ("a" := va, "b" := True)-                @=? Model-                  ( M.fromList-                      [ (someTypedSymbol asymbol, toModelValue va),-                        (someTypedSymbol bsymbol, toModelValue True)-                      ]-                  )-              buildModel-                ( "a" := va,-                  "b" := True,-                  "c" := vc-                )-                @=? Model-                  ( M.fromList-                      [ (someTypedSymbol asymbol, toModelValue va),-                        (someTypedSymbol bsymbol, toModelValue True),-                        (someTypedSymbol csymbol, toModelValue vc)-                      ]-                  )-              buildModel-                ( "a" := va,-                  "b" := True,-                  "c" := vc,-                  "d" := False-                )-                @=? Model-                  ( M.fromList-                      [ (someTypedSymbol asymbol, toModelValue va),-                        (someTypedSymbol bsymbol, toModelValue True),-                        (someTypedSymbol csymbol, toModelValue vc),-                        (someTypedSymbol dsymbol, toModelValue False)-                      ]-                  )-              buildModel-                ( "a" := va,-                  "b" := True,-                  "c" := vc,-                  "d" := False,-                  "e" := ve-                )-                @=? Model-                  ( M.fromList-                      [ (someTypedSymbol asymbol, toModelValue va),-                        (someTypedSymbol bsymbol, toModelValue True),-                        (someTypedSymbol csymbol, toModelValue vc),-                        (someTypedSymbol dsymbol, toModelValue False),-                        (someTypedSymbol esymbol, toModelValue ve)-                      ]-                  )-              buildModel-                ( "a" := va,-                  "b" := True,-                  "c" := vc,-                  "d" := False,-                  "e" := ve,-                  "f" := vf-                )-                @=? Model-                  ( M.fromList-                      [ (someTypedSymbol asymbol, toModelValue va),-                        (someTypedSymbol bsymbol, toModelValue True),-                        (someTypedSymbol csymbol, toModelValue vc),-                        (someTypedSymbol dsymbol, toModelValue False),-                        (someTypedSymbol esymbol, toModelValue ve),-                        (someTypedSymbol fsymbol, toModelValue vf)-                      ]-                  )-              buildModel-                ( "a" := va,-                  "b" := True,-                  "c" := vc,-                  "d" := False,-                  "e" := ve,-                  "f" := vf,-                  "g" := vg-                )-                @=? Model-                  ( M.fromList-                      [ (someTypedSymbol asymbol, toModelValue va),-                        (someTypedSymbol bsymbol, toModelValue True),-                        (someTypedSymbol csymbol, toModelValue vc),-                        (someTypedSymbol dsymbol, toModelValue False),-                        (someTypedSymbol esymbol, toModelValue ve),-                        (someTypedSymbol fsymbol, toModelValue vf),-                        (someTypedSymbol gsymbol, toModelValue vg)-                      ]-                  )-              buildModel-                ( "a" := va,-                  "b" := True,-                  "c" := vc,-                  "d" := False,-                  "e" := ve,-                  "f" := vf,-                  "g" := vg,-                  "h" := vh-                )-                @=? Model-                  ( M.fromList-                      [ (someTypedSymbol asymbol, toModelValue va),-                        (someTypedSymbol bsymbol, toModelValue True),-                        (someTypedSymbol csymbol, toModelValue vc),-                        (someTypedSymbol dsymbol, toModelValue False),-                        (someTypedSymbol esymbol, toModelValue ve),-                        (someTypedSymbol fsymbol, toModelValue vf),-                        (someTypedSymbol gsymbol, toModelValue vg),-                        (someTypedSymbol hsymbol, toModelValue vh)-                      ]-                  )-    ]
− test/Grisette/IR/SymPrim/Data/TabularFunTests.hs 
@@ -1,25 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators #-}--module Grisette.IR.SymPrim.Data.TabularFunTests (tabularFunTests) where--import Grisette.Core.Data.Class.Function (Function ((#)))-import Grisette.IR.SymPrim.Data.TabularFun-  ( type (=->) (TabularFun),-  )-import Test.Framework (Test, testGroup)-import Test.Framework.Providers.HUnit (testCase)-import Test.HUnit ((@=?))--tabularFunTests :: Test-tabularFunTests =-  testGroup-    "TabularFun"-    [ testCase "Tabular application" $ do-        let f :: Integer =-> Integer = TabularFun [(1, 2), (3, 4)] 5-        (f # 0) @=? 5-        (f # 1) @=? 2-        (f # 2) @=? 5-        (f # 3) @=? 4-        (f # 4) @=? 5-    ]
+ test/Grisette/Lib/Control/ApplicativeTest.hs view
@@ -0,0 +1,225 @@+{-# LANGUAGE OverloadedStrings #-}++module Grisette.Lib.Control.ApplicativeTest+  ( applicativeFunctionTests,+  )+where++import Control.Applicative (Alternative (empty))+import Control.Monad.State+  ( MonadState (get, put),+    MonadTrans (lift),+    StateT (runStateT),+  )+import Control.Monad.Trans.Maybe (MaybeT (MaybeT))+import Grisette+  ( AsKey1,+    SymBranching (mrgIfPropagatedStrategy),+    Union,+    mrgAsum,+    mrgEmpty,+    mrgPure,+    mrgReturn,+    mrgSingle,+  )+import Grisette.Lib.Control.Applicative+  ( mrgLiftA,+    mrgLiftA2,+    mrgLiftA3,+    mrgMany,+    mrgOptional,+    mrgSome,+    (.*>),+    (.<*),+    (.<**>),+    (.<*>),+    (.<|>),+  )+import Grisette.TestUtil.NoMerge+  ( NoMerge (NoMerge),+    noMergeNotMerged,+    oneNotMerged,+  )+import Grisette.TestUtil.SymbolicAssertion ((.@?=))+import Test.Framework+  ( Test,+    TestOptions' (topt_timeout),+    plusTestOptions,+    testGroup,+  )+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit ((@?=))++applicativeFunctionTests :: Test+applicativeFunctionTests =+  testGroup+    "Applicative"+    [ 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 :: Union Integer),+          testCase "merge arguments" $ do+            let actual = (return (const NoMerge)) .<*> oneNotMerged+            actual @?= (mrgSingle NoMerge :: AsKey1 Union NoMerge)+        ],+      testGroup+        "mrgLiftA2"+        [ testCase "merge result" $ do+            let actual =+                  mrgLiftA2 (const $ const 1) noMergeNotMerged noMergeNotMerged+            let expected = mrgPure 1 :: AsKey1 Union Int+            actual .@?= expected,+          testCase "merge argument" $ do+            let actual =+                  mrgLiftA2 (const $ const NoMerge) oneNotMerged oneNotMerged+            let expected = mrgPure NoMerge+            actual @?= expected+        ],+      testGroup+        ".*>"+        [ testCase "merge result" $+            noMergeNotMerged .*> oneNotMerged .@?= mrgSingle 1,+          testCase "merge arguments" $+            oneNotMerged .*> return NoMerge @?= mrgSingle NoMerge+        ],+      testGroup+        ".<*"+        [ testCase "merge result" $+            oneNotMerged .<* noMergeNotMerged .@?= mrgSingle 1,+          testCase "merge arguments" $+            return NoMerge .<* oneNotMerged @?= mrgSingle NoMerge+        ],+      testCase "mrgEmpty" $+        (mrgEmpty :: MaybeT Union Integer) .@?= MaybeT (mrgReturn Nothing),+      testGroup+        ".<|>"+        [ testCase "merge result" $+            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 Union NoMerge+            lhs .<|> return NoMerge @?= expected+        ],+      plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $+        testGroup+          "mrgSome"+          [ testCase "merge" $+              runStateT (mrgSome f) 100 .@?= (mrgSingle (replicate 100 (), 0)),+            testCase "single" $+              runStateT (mrgSome f) 1 .@?= (mrgSingle ([()], 0)),+            testCase "zero" $+              runStateT (mrgSome f) 0 .@?= MaybeT (mrgReturn Nothing)+          ],+      plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $+        testGroup+          "mrgMany"+          [ testCase "merge" $+              runStateT (mrgMany f) 100 .@?= (mrgSingle (replicate 100 (), 0)),+            testCase "single" $+              runStateT (mrgMany f) 1 .@?= (mrgSingle ([()], 0)),+            testCase "zero" $+              runStateT (mrgMany f) 0 .@?= (mrgSingle ([], 0))+          ],+      testGroup+        ".<**>"+        [ testCase "merge result" $ do+            let actual =+                  mrgIfPropagatedStrategy "a" (return $ -1) (return 1)+                    .<**> (return (\x -> x * x))+            actual .@?= (mrgSingle 1 :: AsKey1 Union Integer),+          testCase "merge arguments" $ do+            let actual = oneNotMerged .<**> (return (const NoMerge))+            actual @?= (mrgSingle NoMerge :: AsKey1 Union NoMerge)+        ],+      testGroup+        "mrgLiftA"+        [ testCase "merge result" $ do+            let actual = mrgLiftA (const 1) noMergeNotMerged+            let expected = mrgReturn 1 :: AsKey1 Union Int+            actual .@?= expected,+          testCase "merge argument" $ do+            let actual = mrgLiftA (const NoMerge) oneNotMerged+            let expected = mrgReturn NoMerge+            actual @?= expected+        ],+      testGroup+        "mrgLiftA3"+        [ testCase "merge result" $ do+            let actual =+                  mrgLiftA3+                    (const $ const $ const 1)+                    noMergeNotMerged+                    noMergeNotMerged+                    noMergeNotMerged+            let expected = mrgReturn 1 :: AsKey1 Union Int+            actual .@?= expected,+          testCase "merge argument" $ do+            let actual =+                  mrgLiftA3+                    (const $ const $ const NoMerge)+                    oneNotMerged+                    oneNotMerged+                    oneNotMerged+            let expected = mrgReturn NoMerge+            actual @?= expected+        ],+      testGroup+        "mrgOptional"+        [ testCase "one" $ do+            let actual =+                  mrgOptional+                    ( MaybeT $+                        mrgIfPropagatedStrategy+                          "a"+                          (return $ Just 1)+                          (return $ Just 1)+                    )+            let expected = mrgSingle (Just 1) :: MaybeT Union (Maybe Int)+            actual .@?= expected,+          testCase "none" $ do+            let actual =+                  mrgOptional+                    ( MaybeT $+                        mrgIfPropagatedStrategy "a" (return Nothing) (return Nothing)+                    )+            let expected = mrgSingle Nothing :: MaybeT Union (Maybe Int)+            actual .@?= expected+        ],+      plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $+        testGroup+          "mrgAsum"+          [ testCase "merge" $ do+              let none =+                    MaybeT $+                      mrgIfPropagatedStrategy "a" (return Nothing) (return Nothing)+              let expected =+                    MaybeT (mrgSingle Nothing) ::+                      MaybeT Union (Maybe Int)+              mrgAsum (replicate 100 none) .@?= expected,+            testCase "semantics" $ do+              (mrgAsum [mrgEmpty, mrgEmpty] :: MaybeT Union Integer)+                .@?= mrgEmpty+              (mrgAsum [mrgPure 1, mrgEmpty] :: MaybeT Union Integer)+                .@?= mrgPure 1+              (mrgAsum [mrgEmpty, mrgPure 1] :: MaybeT Union Integer)+                .@?= mrgPure 1+              (mrgAsum [mrgPure 2, mrgPure 1] :: MaybeT Union Integer)+                .@?= mrgPure 2+          ]+    ]++f :: StateT Int (MaybeT Union) ()+f = do+  i <- get+  if (i == 0)+    then empty+    else do+      put (i - 1)+      lift . lift $+        mrgIfPropagatedStrategy "a" (return ()) (return ())
test/Grisette/Lib/Control/Monad/ExceptTests.hs view
@@ -2,33 +2,89 @@  module Grisette.Lib.Control.Monad.ExceptTests (monadExceptFunctionTests) where +import Control.Monad.Error.Class (MonadError (throwError)) import Control.Monad.Trans.Except (ExceptT (ExceptT), runExceptT)-import Grisette.Core.Control.Monad.UnionM (UnionM)-import Grisette.Core.Data.Class.ITEOp (ITEOp (symIte))-import Grisette.Core.Data.Class.SimpleMergeable-  ( UnionLike (unionIf),+import Grisette+  ( ITEOp (symIte),+    SymBranching (mrgIfPropagatedStrategy),+    SymEq ((.==)),+    Union,+    mrgIf,     mrgSingle,   )-import Grisette.IR.SymPrim.Data.SymPrim (SymBool) import Grisette.Lib.Control.Monad.Except   ( mrgCatchError,+    mrgHandleError,+    mrgLiftEither,+    mrgMapError,+    mrgModifyError,     mrgThrowError,+    mrgTryError,+    mrgWithError,   )+import Grisette.SymPrim (SymBool, SymInteger)+import Grisette.TestUtil.SymbolicAssertion ((.@?=)) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase)-import Test.HUnit ((@?=)) +exceptUnion :: ExceptT SymInteger Union SymInteger+exceptUnion = mrgIfPropagatedStrategy "a" (throwError "b") (return "c")+ monadExceptFunctionTests :: Test monadExceptFunctionTests =   testGroup     "Except"     [ testCase "mrgThrowError" $-        runExceptT (mrgThrowError 1 :: ExceptT Integer UnionM ())-          @?= mrgSingle (Left 1),+        runExceptT (mrgThrowError 1 :: ExceptT Integer Union ())+          .@?= mrgSingle (Left 1),       testCase "mrgCatchError" $-        ( ExceptT (unionIf "a" (return $ Left "b") (return $ Right "c")) ::-            ExceptT SymBool UnionM SymBool+        ( mrgIfPropagatedStrategy "a" (throwError "b") (return "c") ::+            ExceptT SymBool Union SymBool         )           `mrgCatchError` return-          @?= mrgSingle (symIte "a" "b" "c")+          .@?= mrgSingle (symIte "a" "b" "c"),+      testCase "mrgLiftEither" $ do+        runExceptT (mrgLiftEither (Left "a") :: ExceptT SymBool Union ())+          .@?= mrgSingle (Left "a"),+      testCase "mrgTryError" $ do+        let expected = mrgIf "a" (mrgSingle (Left "b")) (mrgSingle (Right "c"))+        mrgTryError exceptUnion .@?= expected,+      testCase "mrgWithError" $ do+        let expected = mrgIf "a" (mrgThrowError $ "b" + 1) (mrgSingle "c")+        mrgWithError (+ 1) exceptUnion .@?= expected,+      testCase "mrgCatchError" $+        mrgHandleError+          return+          ( mrgIfPropagatedStrategy "a" (throwError "b") (return "c") ::+              ExceptT SymBool Union SymBool+          )+          .@?= mrgSingle (symIte "a" "b" "c"),+      testCase "mrgMapError" $ do+        let expected =+              ( mrgIf+                  "a"+                  (mrgThrowError (Just "b"))+                  (mrgSingle $ ("c" :: SymInteger) .== 1) ::+                  ExceptT (Maybe SymInteger) Union SymBool+              )+        mrgMapError+          ( \m -> ExceptT $ do+              v <- runExceptT m+              case v of+                Left _ -> error "Should not happen"+                Right (Left e) -> return $ Right $ Left $ Just e+                Right (Right v) -> return $ Right $ Right $ v .== 1+          )+          exceptUnion+          .@?= expected,+      testCase "mrgModifyError" $ do+        let original =+              mrgIf "a" (mrgThrowError "b") (mrgSingle "c") ::+                ExceptT SymInteger (ExceptT SymBool Union) SymInteger+        let expected =+              mrgIf+                "a"+                (mrgThrowError $ ("b" :: SymInteger) .== 1)+                (mrgSingle "c")+        mrgModifyError (.== 1) original .@?= expected     ]
test/Grisette/Lib/Control/Monad/State/ClassTests.hs view
@@ -3,8 +3,7 @@   ) where -import Control.Monad.State.Lazy (state)-import Control.Monad.Trans.State.Lazy (runStateT)+import Control.Monad.Trans.State.Lazy (StateT (StateT), runStateT) import Grisette.Lib.Control.Monad.State.Class   ( mrgGet,     mrgGets,@@ -28,9 +27,9 @@   testGroup     "Class"     [ testCase "mrgState" $ mrgStateTest mrgState runStateT,-      testCase "mrgGet" $ mrgGetTest state runStateT mrgGet,-      testCase "mrgPut" $ mrgPutTest state runStateT mrgPut,-      testCase "mrgModify" $ mrgModifyTest state runStateT mrgModify,-      testCase "mrgModify'" $ mrgModifyTest state runStateT mrgModify',-      testCase "mrgGets" $ mrgGetsTest state runStateT mrgGets+      testCase "mrgGet" $ mrgGetTest StateT runStateT mrgGet,+      testCase "mrgPut" $ mrgPutTest StateT runStateT mrgPut,+      testCase "mrgModify" $ mrgModifyTest StateT runStateT mrgModify,+      testCase "mrgModify'" $ mrgModifyTest StateT runStateT mrgModify',+      testCase "mrgGets" $ mrgGetsTest StateT runStateT mrgGets     ]
test/Grisette/Lib/Control/Monad/Trans/ClassTests.hs view
@@ -6,14 +6,16 @@ where  import Control.Monad.Except (ExceptT)-import Grisette.Core.Control.Monad.UnionM (UnionM)-import Grisette.Core.Data.Class.ITEOp (ITEOp (symIte))-import Grisette.Core.Data.Class.SimpleMergeable-  ( UnionLike (single, unionIf),+import Grisette+  ( AsKey,+    AsKey1,+    ITEOp (symIte),+    SymBranching (mrgIfPropagatedStrategy),+    Union,     mrgSingle,   )-import Grisette.IR.SymPrim.Data.SymPrim (SymBool) import Grisette.Lib.Control.Monad.Trans (mrgLift)+import Grisette.SymPrim (SymBool) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit ((@?=))@@ -24,10 +26,10 @@     "Class"     [ testCase "mrgLift" $ do         ( mrgLift-            ( unionIf "a" (single "b") (single "c") ::-                UnionM SymBool+            ( mrgIfPropagatedStrategy "a" (return "b") (return "c") ::+                AsKey1 Union (AsKey SymBool)             ) ::-            ExceptT SymBool UnionM SymBool+            ExceptT (AsKey SymBool) (AsKey1 Union) (AsKey SymBool)           )           @?= mrgSingle (symIte "a" "b" "c")     ]
+ test/Grisette/Lib/Control/Monad/Trans/ExceptTests.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE OverloadedStrings #-}++module Grisette.Lib.Control.Monad.Trans.ExceptTests (exceptTests) where++import Control.Monad.Except+  ( ExceptT (ExceptT),+    MonadError (throwError),+    runExceptT,+  )+import Grisette+  ( ITEOp (symIte),+    SymBranching (mrgIfPropagatedStrategy),+    Union,+    mrgIf,+    mrgSingle,+  )+import Grisette.Lib.Control.Monad.Trans.Except+  ( mrgCatchE,+    mrgExcept,+    mrgRunExceptT,+    mrgThrowE,+    mrgWithExceptT,+  )+import Grisette.SymPrim (SymBool, SymInteger)+import Grisette.TestUtil.SymbolicAssertion ((.@?=))+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit (testCase)++unmergedExceptT :: ExceptT SymInteger Union SymBool+unmergedExceptT =+  mrgIfPropagatedStrategy+    "e"+    (mrgIfPropagatedStrategy "c" (throwError "a") (throwError "b"))+    (return "d")++mergedExceptT :: ExceptT SymInteger Union SymBool+mergedExceptT =+  ExceptT $+    mrgIf "e" (mrgSingle (Left (symIte "c" "a" "b"))) (mrgSingle (Right "d"))++mergedExceptTPlus1 :: ExceptT SymInteger Union SymBool+mergedExceptTPlus1 =+  ExceptT $+    mrgIf "e" (mrgSingle (Left (symIte "c" "a" "b" + 1))) (mrgSingle (Right "d"))++exceptTests :: Test+exceptTests =+  testGroup+    "Except"+    [ testCase "mrgExcept" $ do+        let actual = mrgExcept (Left "a") :: ExceptT SymInteger Union SymBool+        let expected = ExceptT (mrgSingle (Left "a"))+        actual .@?= expected,+      testCase "mrgRunExceptT" $ do+        mrgRunExceptT unmergedExceptT .@?= runExceptT mergedExceptT,+      testCase "mrgWithExceptT" $ do+        mrgWithExceptT (+ 1) unmergedExceptT .@?= mergedExceptTPlus1,+      testCase "mrgThrowE" $ do+        let actual = mrgThrowE "a" :: ExceptT SymInteger Union SymBool+        actual .@?= ExceptT (mrgSingle (Left "a")),+      testCase "mrgCatchE" $ do+        let actual = mrgCatchE unmergedExceptT (throwError . (+ 1))+        actual .@?= mergedExceptTPlus1+    ]
test/Grisette/Lib/Control/Monad/Trans/State/Common.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-}  module Grisette.Lib.Control.Monad.Trans.State.Common@@ -14,64 +15,72 @@   ) where -import Grisette.Core.Control.Monad.UnionM (UnionM, unionSize)-import Grisette.Core.Data.Class.LogicalOp (LogicalOp ((.&&)))-import Grisette.Core.Data.Class.SimpleMergeable-  ( SimpleMergeable (mrgIte),-    UnionLike (unionIf),+import Grisette+  ( LogicalOp ((.&&)),+    MonadUnion,+    SimpleMergeable (mrgIte),+    SymBool,+    SymBranching (mrgIfPropagatedStrategy),+    Union,     mrgSingle,+    unionSize,   )-import Grisette.Core.Data.Class.TestValues (ssymBool)-import Grisette.IR.SymPrim.Data.SymPrim (SymBool)+import Grisette.Core.Data.Class.TestValues+  ( ssymBool,+  ) import Grisette.TestUtil.SymbolicAssertion ((@?=~)) import Test.HUnit (Assertion, (@?=)) -type StateFunc stateT s a = (s -> (a, s)) -> stateT s UnionM a+type StateConstructor stateT s a = (s -> Union (a, s)) -> stateT s Union a -type RunStateFunc stateT s a = stateT s UnionM a -> s -> UnionM (a, s)+type StateFunc stateT s a = (s -> (a, s)) -> stateT s Union a -type EvalStateFunc stateT s a = stateT s UnionM a -> s -> UnionM a+type RunStateFunc stateT s a = stateT s Union a -> s -> Union (a, s) -type ExecStateFunc stateT s a = stateT s UnionM a -> s -> UnionM s+type EvalStateFunc stateT s a = stateT s Union a -> s -> Union a +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 -> Union (SymBool, SymBool)+bodyA s = return (s .&& ssymBool "av", s .&& ssymBool "as")+ stateA ::-  StateFunc stateT SymBool SymBool -> stateT SymBool UnionM SymBool-stateA state = state (\s -> (s .&& ssymBool "av", s .&& ssymBool "as"))+  StateConstructor stateT SymBool SymBool -> stateT SymBool Union SymBool+stateA state = state bodyA +bodyB :: SymBool -> Union (SymBool, SymBool)+bodyB s = return (s .&& ssymBool "bv", s .&& ssymBool "bs")+ stateB ::-  StateFunc stateT SymBool SymBool -> stateT SymBool UnionM SymBool-stateB state = state (\s -> (s .&& ssymBool "bv", s .&& ssymBool "bs"))+  StateConstructor stateT SymBool SymBool -> stateT SymBool Union SymBool+stateB state = state bodyB  stateAB ::-  (UnionLike (stateT SymBool UnionM)) =>-  StateFunc stateT SymBool SymBool ->-  stateT SymBool UnionM SymBool-stateAB state =-  unionIf-    (ssymBool "c")-    (stateA state)-    (stateB state)+  (SymBranching (stateT SymBool Union)) =>+  StateConstructor stateT SymBool SymBool ->+  stateT SymBool Union SymBool+stateAB state = mrgIfPropagatedStrategy (ssymBool "c") (state bodyA) (state bodyB)  mrgStateTest ::-  (UnionLike (stateT SymBool UnionM)) =>+  (MonadUnion (stateT SymBool Union)) =>   StateFunc stateT SymBool SymBool ->   RunStateFunc stateT SymBool SymBool ->   Assertion@@ -80,7 +89,8 @@         mrgState (\s -> (s .&& ssymBool "av", s .&& ssymBool "as"))   let b =         mrgState (\s -> (s .&& ssymBool "bv", s .&& ssymBool "bs"))-  let actual = runStateT (unionIf (ssymBool "c") a b) (ssymBool "d")+  let actual =+        runStateT (mrgIfPropagatedStrategy (ssymBool "c") a b) (ssymBool "d")   let expected =         mrgSingle           ( mrgIte@@ -96,8 +106,8 @@   actual @?=~ expected  mrgRunStateTTest ::-  (UnionLike (stateT SymBool UnionM)) =>-  StateFunc stateT SymBool SymBool ->+  (MonadUnion (stateT SymBool Union)) =>+  StateConstructor stateT SymBool SymBool ->   RunStateFunc stateT SymBool SymBool ->   Assertion mrgRunStateTTest state mrgRunStateT = do@@ -117,8 +127,8 @@   actual @?=~ expected  mrgEvalStateTTest ::-  (UnionLike (stateT SymBool UnionM)) =>-  StateFunc stateT SymBool SymBool ->+  (MonadUnion (stateT SymBool Union)) =>+  StateConstructor stateT SymBool SymBool ->   EvalStateFunc stateT SymBool SymBool ->   Assertion mrgEvalStateTTest state mrgEvalStateT = do@@ -134,8 +144,8 @@   actual @?=~ expected  mrgExecStateTTest ::-  (UnionLike (stateT SymBool UnionM)) =>-  StateFunc stateT SymBool SymBool ->+  (MonadUnion (stateT SymBool Union)) =>+  StateConstructor stateT SymBool SymBool ->   ExecStateFunc stateT SymBool SymBool ->   Assertion mrgExecStateTTest state mrgExecStateT = do@@ -151,15 +161,15 @@   actual @?=~ expected  mrgMapStateTTest ::-  (UnionLike (stateT SymBool UnionM)) =>-  StateFunc stateT SymBool SymBool ->+  (MonadUnion (stateT SymBool Union)) =>+  StateConstructor stateT SymBool SymBool ->   RunStateFunc stateT SymBool SymBool ->   MapStateFunc stateT SymBool SymBool ->   Assertion mrgMapStateTTest state runStateT mrgMapStateT = do   let a = mrgMapStateT id (stateA state)   let b = mrgMapStateT id (stateB state)-  let actual = runStateT (unionIf (ssymBool "c") a b) (ssymBool "d")+  let actual = runStateT (mrgIfPropagatedStrategy (ssymBool "c") a b) (ssymBool "d")   let expected =         mrgSingle           ( mrgIte@@ -175,15 +185,15 @@   actual @?=~ expected  mrgWithStateTTest ::-  (UnionLike (stateT SymBool UnionM)) =>-  StateFunc stateT SymBool SymBool ->+  (MonadUnion (stateT SymBool Union)) =>+  StateConstructor stateT SymBool SymBool ->   RunStateFunc stateT SymBool SymBool ->   WithStateFunc stateT SymBool SymBool ->   Assertion mrgWithStateTTest state runStateT mrgWithStateT = do   let a = mrgWithStateT (.&& ssymBool "x") (stateA state)   let b = mrgWithStateT (.&& ssymBool "y") (stateB state)-  let actual = runStateT (unionIf (ssymBool "c") a b) (ssymBool "d")+  let actual = runStateT (mrgIfPropagatedStrategy (ssymBool "c") a b) (ssymBool "d")   let expected =         mrgSingle           ( mrgIte@@ -199,15 +209,15 @@   actual @?=~ expected  mrgGetTest ::-  (UnionLike (stateT SymBool UnionM), Monad (stateT SymBool UnionM)) =>-  StateFunc stateT SymBool SymBool ->+  (MonadUnion (stateT SymBool Union)) =>+  StateConstructor stateT SymBool SymBool ->   RunStateFunc stateT SymBool SymBool ->   GetFunc stateT SymBool SymBool ->   Assertion mrgGetTest state runStateT mrgGet = do   let a = do stateA state; mrgGet   let b = do stateB state; mrgGet-  let actual = runStateT (unionIf (ssymBool "c") a b) (ssymBool "d")+  let actual = runStateT (mrgIfPropagatedStrategy (ssymBool "c") a b) (ssymBool "d")   let expected =         mrgSingle           ( mrgIte@@ -223,32 +233,31 @@   actual @?=~ expected  mrgPutTest ::-  (UnionLike (stateT SymBool UnionM), Monad (stateT SymBool UnionM)) =>-  StateFunc stateT SymBool SymBool ->+  (MonadUnion (stateT SymBool Union)) =>+  StateConstructor stateT SymBool SymBool ->   RunStateFunc stateT SymBool () ->   PutFunc stateT SymBool SymBool ->   Assertion mrgPutTest state runStateT mrgPut = do   let a = do stateA state; mrgPut (ssymBool "x")   let b = do stateB state; mrgPut (ssymBool "y")-  let actual = runStateT (unionIf (ssymBool "c") a b) (ssymBool "d")+  let actual = runStateT (mrgIfPropagatedStrategy (ssymBool "c") a b) (ssymBool "d")   let expected =         mrgSingle-          ( mrgIte (ssymBool "c") ((), ssymBool "x") ((), ssymBool "y")-          )+          (mrgIte (ssymBool "c") ((), ssymBool "x") ((), ssymBool "y"))   unionSize actual @?= 1   actual @?=~ expected  mrgModifyTest ::-  (UnionLike (stateT SymBool UnionM), Monad (stateT SymBool UnionM)) =>-  StateFunc stateT SymBool SymBool ->+  (MonadUnion (stateT SymBool Union)) =>+  StateConstructor stateT SymBool SymBool ->   RunStateFunc stateT SymBool () ->   ModifyFunc stateT SymBool SymBool ->   Assertion mrgModifyTest state runStateT mrgModify = do   let a = do stateA state; mrgModify (.&& ssymBool "x")   let b = do stateB state; mrgModify (.&& ssymBool "y")-  let actual = runStateT (unionIf (ssymBool "c") a b) (ssymBool "d")+  let actual = runStateT (mrgIfPropagatedStrategy (ssymBool "c") a b) (ssymBool "d")   let expected =         mrgSingle           ( mrgIte@@ -264,15 +273,16 @@   actual @?=~ expected  mrgGetsTest ::-  (UnionLike (stateT SymBool UnionM), Monad (stateT SymBool UnionM)) =>-  StateFunc stateT SymBool SymBool ->+  (MonadUnion (stateT SymBool Union)) =>+  StateConstructor stateT SymBool SymBool ->   RunStateFunc stateT SymBool SymBool ->   GetsFunc stateT SymBool SymBool ->   Assertion mrgGetsTest state runStateT mrgGets = do   let a = do stateA state; mrgGets (.&& ssymBool "x")   let b = do stateB state; mrgGets (.&& ssymBool "y")-  let actual = runStateT (unionIf (ssymBool "c") a b) (ssymBool "d")+  let actual =+        runStateT (mrgIfPropagatedStrategy (ssymBool "c") a b) (ssymBool "d")   let expected =         mrgSingle           ( mrgIte
test/Grisette/Lib/Control/Monad/Trans/State/LazyTests.hs view
@@ -3,8 +3,7 @@   ) where -import Control.Monad.State.Lazy (state)-import Control.Monad.Trans.State.Lazy (runStateT)+import Control.Monad.Trans.State.Lazy (StateT (StateT), runStateT) import Grisette.Lib.Control.Monad.Trans.State.Common   ( mrgEvalStateTTest,     mrgExecStateTTest,@@ -38,15 +37,15 @@   testGroup     "Lazy"     [ testCase "mrgState" $ mrgStateTest mrgState runStateT,-      testCase "mrgRunStateT" $ mrgRunStateTTest state mrgRunStateT,-      testCase "mrgEvalStateT" $ mrgEvalStateTTest state mrgEvalStateT,-      testCase "mrgExecStateT" $ mrgExecStateTTest state mrgExecStateT,-      testCase "mrgMapStateT" $ mrgMapStateTTest state runStateT mrgMapStateT,+      testCase "mrgRunStateT" $ mrgRunStateTTest StateT mrgRunStateT,+      testCase "mrgEvalStateT" $ mrgEvalStateTTest StateT mrgEvalStateT,+      testCase "mrgExecStateT" $ mrgExecStateTTest StateT mrgExecStateT,+      testCase "mrgMapStateT" $ mrgMapStateTTest StateT runStateT mrgMapStateT,       testCase "mrgWithStateT" $-        mrgWithStateTTest state runStateT mrgWithStateT,-      testCase "mrgGet" $ mrgGetTest state runStateT mrgGet,-      testCase "mrgPut" $ mrgPutTest state runStateT mrgPut,-      testCase "mrgModify" $ mrgModifyTest state runStateT mrgModify,-      testCase "mrgModify'" $ mrgModifyTest state runStateT mrgModify',-      testCase "mrgGets" $ mrgGetsTest state runStateT mrgGets+        mrgWithStateTTest StateT runStateT mrgWithStateT,+      testCase "mrgGet" $ mrgGetTest StateT runStateT mrgGet,+      testCase "mrgPut" $ mrgPutTest StateT runStateT mrgPut,+      testCase "mrgModify" $ mrgModifyTest StateT runStateT mrgModify,+      testCase "mrgModify'" $ mrgModifyTest StateT runStateT mrgModify',+      testCase "mrgGets" $ mrgGetsTest StateT runStateT mrgGets     ]
test/Grisette/Lib/Control/Monad/Trans/State/StrictTests.hs view
@@ -3,8 +3,7 @@   ) where -import Control.Monad.State.Strict (state)-import Control.Monad.Trans.State.Strict (runStateT)+import Control.Monad.Trans.State.Strict (StateT (StateT), runStateT) import Grisette.Lib.Control.Monad.Trans.State.Common   ( mrgEvalStateTTest,     mrgExecStateTTest,@@ -38,15 +37,15 @@   testGroup     "Strict"     [ testCase "mrgState" $ mrgStateTest mrgState runStateT,-      testCase "mrgRunStateT" $ mrgRunStateTTest state mrgRunStateT,-      testCase "mrgEvalStateT" $ mrgEvalStateTTest state mrgEvalStateT,-      testCase "mrgExecStateT" $ mrgExecStateTTest state mrgExecStateT,-      testCase "mrgMapStateT" $ mrgMapStateTTest state runStateT mrgMapStateT,+      testCase "mrgRunStateT" $ mrgRunStateTTest StateT mrgRunStateT,+      testCase "mrgEvalStateT" $ mrgEvalStateTTest StateT mrgEvalStateT,+      testCase "mrgExecStateT" $ mrgExecStateTTest StateT mrgExecStateT,+      testCase "mrgMapStateT" $ mrgMapStateTTest StateT runStateT mrgMapStateT,       testCase "mrgWithStateT" $-        mrgWithStateTTest state runStateT mrgWithStateT,-      testCase "mrgGet" $ mrgGetTest state runStateT mrgGet,-      testCase "mrgPut" $ mrgPutTest state runStateT mrgPut,-      testCase "mrgModify" $ mrgModifyTest state runStateT mrgModify,-      testCase "mrgModify'" $ mrgModifyTest state runStateT mrgModify',-      testCase "mrgGets" $ mrgGetsTest state runStateT mrgGets+        mrgWithStateTTest StateT runStateT mrgWithStateT,+      testCase "mrgGet" $ mrgGetTest StateT runStateT mrgGet,+      testCase "mrgPut" $ mrgPutTest StateT runStateT mrgPut,+      testCase "mrgModify" $ mrgModifyTest StateT runStateT mrgModify,+      testCase "mrgModify'" $ mrgModifyTest StateT runStateT mrgModify',+      testCase "mrgGets" $ mrgGetsTest StateT runStateT mrgGets     ]
test/Grisette/Lib/Control/MonadTests.hs view
@@ -3,23 +3,81 @@  module Grisette.Lib.Control.MonadTests (monadFunctionTests) where +import Control.Monad (MonadPlus (mzero), when)+import Control.Monad.Except (ExceptT (ExceptT), MonadError (throwError))+import Control.Monad.State+  ( MonadState (get, put),+    MonadTrans (lift),+    StateT (runStateT),+  ) import Control.Monad.Trans.Maybe (MaybeT (MaybeT))-import Grisette.Core.Control.Monad.UnionM (UnionM)-import Grisette.Core.Data.Class.SimpleMergeable-  ( UnionLike (single, unionIf),+import Grisette+  ( AsKey1 (AsKey1),+    ITEOp (symIte),+    LogicalOp ((.&&), (.||)),+    Solvable (con),+    SymBranching (mrgIfPropagatedStrategy),+    SymEq ((./=), (.==)),+    SymInteger,+    SymOrd ((.<=)),+    Union,+    mrgFilterM,+    mrgGuard,     mrgIf,+    mrgLiftM,+    mrgLiftM5,+    mrgMapAndUnzipM,+    mrgReplicateM,+    mrgReplicateM_,     mrgSingle,+    mrgWhen,+    mrgZipWithM,+    symReplicateM_,+    symWhen,   ) import Grisette.Lib.Control.Monad-  ( mrgFmap,+  ( mrgAp,+    mrgFail,     mrgFoldM,+    mrgFoldM_,+    mrgForever,+    mrgJoin,+    mrgLiftM2,+    mrgLiftM3,+    mrgLiftM4,+    mrgMfilter,     mrgMplus,     mrgMzero,     mrgReturn,+    mrgUnless,+    mrgZipWithM_,+    symFilterM,+    symGuard,+    symMfilter,+    symReplicateM,+    symUnless,+    (.<$!>),+    (.<=<),+    (.=<<),+    (.>=>),     (.>>),     (.>>=),   )-import Test.Framework (Test, testGroup)+import Grisette.Lib.Control.Monad.Except+  ( mrgThrowError,+  )+import Grisette.TestUtil.NoMerge+  ( NoMerge (NoMerge),+    noMergeNotMerged,+    oneNotMerged,+  )+import Grisette.TestUtil.SymbolicAssertion ((.@?=))+import Test.Framework+  ( Test,+    TestOptions' (topt_timeout),+    plusTestOptions,+    testGroup,+  ) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit ((@?=)) @@ -27,38 +85,450 @@ monadFunctionTests =   testGroup     "Monad"-    [ testCase "mrgReturn" $ do-        (mrgReturn 1 :: UnionM Integer) @?= mrgSingle 1,-      testCase "mrgFoldM" $ do-        ( mrgFoldM-            (\acc (c, v) -> unionIf c (single $ acc + v) (single $ acc * v))-            10-            [("a", 2), ("b", 3)] ::-            UnionM Integer-          )-          @?= mrgIf-            "a"-            (mrgIf "b" (mrgReturn 15) (mrgReturn 36))-            (mrgIf "b" (mrgReturn 23) (mrgReturn 60)),+    [ 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 :: Union Integer),+          testCase "merge argument" $ do+            let actual =+                  mrgIfPropagatedStrategy "a" (return (1 :: Int)) (return 1)+                    .>>= const (return NoMerge)+            AsKey1 actual @?= AsKey1 (mrgSingle NoMerge :: Union NoMerge)+        ],+      testGroup+        ".>>"+        [ testCase "merge result" $ do+            let actual =+                  ( mrgIfPropagatedStrategy "a" (return $ -1) (return 1) ::+                      Union Integer+                  )+                    .>> mrgIfPropagatedStrategy "a" (return $ -1) (return 1)+            let expected =+                  mrgIf "a" (mrgReturn $ -1) (mrgReturn 1) ::+                    Union Integer+            actual .@?= expected,+          testCase "merge lhs" $ do+            let actual =+                  ( mrgIfPropagatedStrategy "a" (return 1) (return 1) ::+                      Union Integer+                  )+                    .>> return NoMerge+            let expected = mrgReturn NoMerge :: Union NoMerge+            AsKey1 actual @?= AsKey1 expected+        ],+      testCase "mrgFail" $ do+        let actual = mrgFail "a" :: MaybeT Union Int+        actual .@?= MaybeT (mrgSingle Nothing),       testCase "mrgMzero" $ do-        (mrgMzero :: MaybeT UnionM Integer) @?= MaybeT (mrgReturn Nothing),-      testCase "mrgMplus" $ do-        (mrgMzero `mrgMplus` mrgMzero :: MaybeT UnionM Integer) @?= MaybeT (mrgReturn Nothing)-        (mrgReturn 1 `mrgMplus` mrgMzero :: MaybeT UnionM Integer)-          @?= mrgReturn 1-        (mrgMzero `mrgMplus` mrgReturn 1 :: MaybeT UnionM Integer)-          @?= mrgReturn 1-        (mrgReturn 2 `mrgMplus` mrgReturn 1 :: MaybeT UnionM Integer)-          @?= mrgReturn 2,-      testCase "mrgFmap" $ do-        mrgFmap (\x -> x * x) (mrgIf "a" (mrgReturn $ -1) (mrgReturn 1) :: UnionM Integer)-          @?= mrgReturn 1,-      testCase ".>>" $ do-        (unionIf "a" (single $ -1) (single 1) :: UnionM Integer)-          .>> unionIf "a" (single $ -1) (single 1)-          @?= (mrgIf "a" (mrgReturn $ -1) (mrgReturn 1) :: UnionM Integer),-      testCase ".>>=" $ do-        unionIf "a" (single $ -1) (single 1)-          .>>= (\x -> return $ x * x)-          @?= (mrgSingle 1 :: UnionM Integer)+        (mrgMzero :: MaybeT Union Integer) .@?= MaybeT (mrgReturn Nothing),+      testGroup+        "mrgMplus"+        [ testCase "merge result" $ do+            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 (AsKey1 Union) NoMerge+            let rhs = return NoMerge+            lhs `mrgMplus` rhs @?= MaybeT (mrgReturn $ Just NoMerge)+        ],+      testGroup+        ".=<<"+        [ testCase "merge result" $ do+            let actual =+                  (\x -> return $ x * x)+                    .=<< mrgIfPropagatedStrategy "a" (return $ -1) (return 1)+            actual .@?= (mrgSingle 1 :: Union Integer),+          testCase "merge argument" $ do+            let actual =+                  const (return NoMerge)+                    .=<< mrgIfPropagatedStrategy "a" (return (1 :: Int)) (return 1)+            actual @?= (mrgSingle NoMerge :: AsKey1 Union NoMerge)+        ],+      testGroup+        ".>=>"+        [ testCase "merge result" $ do+            let lhs =+                  const+                    ( mrgIfPropagatedStrategy+                        "a"+                        (return $ -1)+                        (return 1) ::+                        Union Integer+                    )+            let actual = lhs .>=> (\x -> return $ x * x)+            actual (0 :: Integer) .@?= (mrgSingle 1 :: Union Integer),+          testCase "merge lhs result" $ do+            let lhs =+                  const+                    ( mrgIfPropagatedStrategy+                        "a"+                        (return 1)+                        (return 1) ::+                        AsKey1 Union Integer+                    )+            let actual = lhs .>=> const (return NoMerge)+            actual (0 :: Integer) @?= mrgSingle NoMerge+        ],+      testGroup+        ".<=<"+        [ testCase "merge result" $ do+            let rhs =+                  const+                    ( mrgIfPropagatedStrategy+                        "a"+                        (return $ -1)+                        (return 1) ::+                        Union Integer+                    )+            let actual = (\x -> return $ x * x) .<=< rhs+            actual (0 :: Integer) .@?= (mrgSingle 1 :: Union Integer),+          testCase "merge rhs result" $ do+            let rhs =+                  const+                    ( mrgIfPropagatedStrategy+                        "a"+                        (return 1)+                        (return 1) ::+                        AsKey1 Union Integer+                    )+            let actual = const (return NoMerge) .<=< rhs+            actual (0 :: Integer) @?= mrgSingle NoMerge+        ],+      testCase "mrgForever" $ do+        let f :: StateT Int (ExceptT NoMerge (AsKey1 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 (AsKey1 Union)) NoMerge+        runStateT actual 10 @?= ExceptT (mrgReturn $ Left NoMerge),+      testCase "mrgJoin" $+        mrgJoin (return $ return 1) .@?= (mrgSingle 1 :: Union Integer),+      testCase "mrgMfilter" $ do+        let actual = mrgMfilter (const True) (return 1 :: MaybeT Union Int)+        actual .@?= (mrgSingle 1),+      testCase "symMfilter" $ do+        let actual = symMfilter (.== 0) (return "a" :: MaybeT Union SymInteger)+        let expected =+              mrgIf ("a" .== (0 :: SymInteger)) (mrgReturn "a") mrgMzero+        actual .@?= expected,+      testGroup+        "mrgFilterM"+        [ testCase "merge result" $ do+            let actual = mrgFilterM (return . odd) [1, 2, 3, 4]+            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] :: AsKey1 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] :: Union [Int]+            actual .@?= expected,+          testCase "merge argument" $ do+            let actual =+                  symFilterM+                    ( const $+                        mrgIfPropagatedStrategy+                          "a"+                          (return $ con True)+                          (return $ con True)+                    )+                    [NoMerge, NoMerge]+            let expected = mrgReturn [NoMerge, NoMerge] :: AsKey1 Union [NoMerge]+            actual @?= expected,+          testCase "symbolic semantics" $ do+            let a = "a" :: SymInteger+            let b = "b" :: SymInteger+            let actual = symFilterM (return . (./= 0)) [a, b]+            let expected =+                  mrgIf (a .== 0 .&& b .== 0) (return []) $+                    mrgIf+                      (a .== 0 .|| b .== 0)+                      (return [symIte (a ./= 0) a b])+                      (return [a, b]) ::+                    Union [SymInteger]+            actual .@?= expected+            actual .@?= expected+        ],+      plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $+        testCase "mrgMapAndUnzipM" $ do+          let actual =+                mrgMapAndUnzipM+                  ( \x ->+                      mrgIfPropagatedStrategy+                        "a"+                        (return (x, x + 1))+                        (return (x, x + 1))+                  )+                  [1 .. 100] ::+                  Union ([Int], [Int])+          let expected = mrgReturn ([1 .. 100], [2 .. 101])+          actual .@?= expected,+      plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $+        testCase "mrgZipWithM" $ do+          let actual =+                mrgZipWithM+                  ( \x y ->+                      mrgIfPropagatedStrategy+                        "a"+                        (return $ x + y)+                        (return $ x + y)+                  )+                  [1 .. 100]+                  [1 .. 100] ::+                  Union ([Int])+          let expected = mrgReturn ((* 2) <$> [1 .. 100])+          actual .@?= expected,+      plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $+        testCase "mrgZipWithM_" $ do+          let actual =+                mrgZipWithM_+                  ( \x y ->+                      mrgIfPropagatedStrategy+                        "a"+                        (return $ x + y)+                        (return $ x + y)+                  )+                  [1 .. 100 :: Int]+                  [1 .. 100] ::+                  Union ()+          let expected = mrgReturn ()+          actual .@?= expected,+      plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $+        testCase "mrgFoldM" $ do+          let actual =+                mrgFoldM+                  ( \acc v ->+                      mrgIfPropagatedStrategy+                        "a"+                        (return $ acc + v)+                        (return $ acc + v)+                  )+                  10+                  [1 .. 100] ::+                  Union Integer+          actual .@?= mrgReturn 5060,+      plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $+        testCase "mrgFoldM_" $ do+          let actual =+                mrgFoldM_+                  ( \acc v ->+                      mrgIfPropagatedStrategy+                        "a"+                        (return $ acc + v)+                        (return $ acc + v)+                  )+                  10+                  [1 .. 100 :: Int] ::+                  Union ()+          actual .@?= mrgReturn (),+      plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $+        testCase "mrgReplicateM" $ do+          let actual =+                mrgReplicateM+                  100+                  (mrgIfPropagatedStrategy "a" (return 1) (return 1)) ::+                  Union [Int]+          actual .@?= mrgReturn [1 | _ <- [1 .. 100]],+      plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $+        testGroup+          "symReplicateM"+          [ testCase "merge result and intermediate" $ do+              let actual =+                    symReplicateM+                      200+                      (100 :: SymInteger)+                      (mrgIfPropagatedStrategy "a" (return 1) (return 1)) ::+                      Union [Int]+              actual .@?= mrgReturn [1 | _ <- [1 .. 100]],+            testCase "symbolic semantics" $ do+              let a = "a" :: SymInteger+              let actual =+                    symReplicateM+                      2+                      a+                      (mrgIfPropagatedStrategy "a" (return 1) (return 1)) ::+                      Union [Int]+              let expected =+                    mrgIf+                      (a .<= 0)+                      (return [])+                      (mrgIf (a .== 1) (return [1]) (return [1, 1])) ::+                      Union [Int]+              actual .@?= expected+          ],+      plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $+        testCase "mrgReplicateM_" $ do+          let actual = mrgReplicateM_ 100 noMergeNotMerged :: AsKey1 Union ()+          actual .@?= mrgReturn (),+      plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $+        testGroup+          "symReplicateM_"+          [ testCase "merge result and intermediate" $ do+              let actual =+                    symReplicateM_ 200 (100 :: SymInteger) noMergeNotMerged ::+                      AsKey1 Union ()+              actual .@?= mrgReturn ()+          ],+      testCase "mrgGuard" $ do+        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 Union ()+        symGuard "a" .@?= expected,+      testCase "mrgWhen" $ do+        mrgWhen True (throwError "a")+          .@?= (mrgThrowError "a" :: ExceptT String Union ())+        mrgWhen False (throwError "a")+          .@?= (mrgReturn () :: ExceptT String Union ()),+      testCase "symWhen" $ do+        let expected =+              mrgIf "a" (mrgThrowError "x") (return ()) ::+                ExceptT String Union ()+        symWhen "a" (throwError "x") .@?= expected,+      testCase "mrgUnless" $ do+        mrgUnless False (throwError "a")+          .@?= (mrgThrowError "a" :: ExceptT String Union ())+        mrgUnless True (throwError "a")+          .@?= (mrgReturn () :: ExceptT String Union ()),+      testCase "symUnless" $ do+        let expected =+              mrgIf "a" (return ()) (mrgThrowError "x") ::+                ExceptT String Union ()+        symUnless "a" (throwError "x") .@?= expected,+      testGroup+        "mrgLiftM"+        [ testCase "merge result" $ do+            let actual = mrgLiftM (const 1) noMergeNotMerged+            let expected = mrgReturn 1 :: AsKey1 Union Int+            actual .@?= expected,+          testCase "merge argument" $ do+            let actual = mrgLiftM (const NoMerge) oneNotMerged+            let expected = mrgReturn NoMerge+            actual @?= expected+        ],+      testGroup+        "mrgLiftM2"+        [ testCase "merge result" $ do+            let actual =+                  mrgLiftM2 (const $ const 1) noMergeNotMerged noMergeNotMerged+            let expected = mrgReturn 1 :: AsKey1 Union Int+            actual .@?= expected,+          testCase "merge argument" $ do+            let actual =+                  mrgLiftM2 (const $ const NoMerge) oneNotMerged oneNotMerged+            let expected = mrgReturn NoMerge+            actual @?= expected+        ],+      testGroup+        "mrgLiftM3"+        [ testCase "merge result" $ do+            let actual =+                  mrgLiftM3+                    (const $ const $ const 1)+                    noMergeNotMerged+                    noMergeNotMerged+                    noMergeNotMerged+            let expected = mrgReturn 1 :: AsKey1 Union Int+            actual .@?= expected,+          testCase "merge argument" $ do+            let actual =+                  mrgLiftM3+                    (const $ const $ const NoMerge)+                    oneNotMerged+                    oneNotMerged+                    oneNotMerged+            let expected = mrgReturn NoMerge+            actual @?= expected+        ],+      testGroup+        "mrgLiftM4"+        [ testCase "merge result" $ do+            let actual =+                  mrgLiftM4+                    (const $ const $ const $ const 1)+                    noMergeNotMerged+                    noMergeNotMerged+                    noMergeNotMerged+                    noMergeNotMerged+            let expected = mrgReturn 1 :: AsKey1 Union Int+            actual .@?= expected,+          testCase "merge argument" $ do+            let actual =+                  mrgLiftM4+                    (const $ const $ const $ const NoMerge)+                    oneNotMerged+                    oneNotMerged+                    oneNotMerged+                    oneNotMerged+            let expected = mrgReturn NoMerge+            actual @?= expected+        ],+      testGroup+        "mrgLiftM5"+        [ testCase "merge result" $ do+            let actual =+                  mrgLiftM5+                    (const $ const $ const $ const $ const 1)+                    noMergeNotMerged+                    noMergeNotMerged+                    noMergeNotMerged+                    noMergeNotMerged+                    noMergeNotMerged+            let expected = mrgReturn 1 :: AsKey1 Union Int+            actual .@?= expected,+          testCase "merge argument" $ do+            let actual =+                  mrgLiftM5+                    (const $ const $ const $ const $ const NoMerge)+                    oneNotMerged+                    oneNotMerged+                    oneNotMerged+                    oneNotMerged+                    oneNotMerged+            let expected = mrgReturn NoMerge+            actual @?= expected+        ],+      testGroup+        "mrgAp"+        [ testCase "merge result" $ do+            let actual = mrgAp (return $ const 1) noMergeNotMerged+            let expected = mrgReturn 1 :: AsKey1 Union Int+            actual .@?= expected,+          testCase "merge argument" $ do+            let actual = mrgAp (return $ const NoMerge) oneNotMerged+            let expected = mrgReturn NoMerge+            actual @?= expected+        ],+      testGroup+        ".<$!>"+        [ testCase "merge result" $ do+            let actual = const 1 .<$!> noMergeNotMerged+            let expected = mrgReturn 1 :: AsKey1 Union Int+            actual .@?= expected,+          testCase "merge argument" $ do+            let actual = const NoMerge .<$!> oneNotMerged+            let expected = mrgReturn NoMerge+            actual @?= expected+        ]     ]
test/Grisette/Lib/Data/FoldableTests.hs view
@@ -7,24 +7,54 @@     MonadError (throwError),     runExceptT,   )-import Control.Monad.Trans.Maybe (MaybeT)-import Grisette.Core.Control.Monad.UnionM (UnionM)-import Grisette.Core.Data.Class.SimpleMergeable-  ( UnionLike (single, unionIf),+import Control.Monad.Trans.Maybe (MaybeT (MaybeT))+import Grisette+  ( AsKey1,+    ITEOp (symIte),+    LogicalOp ((.&&), (.||)),+    SymBool,+    SymBranching (mrgIfPropagatedStrategy),+    SymEq ((./=), (.==)),+    SymInteger,+    SymOrd (symCompare, (.<=), (.>)),+    Union,     mrgIf,+    symAll,+    symAny,+    symOr,   ) import Grisette.Lib.Control.Monad (mrgMzero, mrgReturn) import Grisette.Lib.Data.Foldable-  ( mrgFoldlM,+  ( mrgFind,+    mrgFoldlM,     mrgFoldrM,     mrgForM_,     mrgFor_,     mrgMapM_,+    mrgMaximum,+    mrgMaximumBy,+    mrgMinimum,+    mrgMinimumBy,     mrgMsum,+    mrgSequenceA_,     mrgSequence_,     mrgTraverse_,+    symAnd,+    symElem,+    symMaximum,+    symMaximumBy,+    symMinimum,+    symMinimumBy,+    symNotElem,   )-import Test.Framework (Test, testGroup)+import Grisette.TestUtil.NoMerge (noMergeNotMerged, oneNotMerged)+import Grisette.TestUtil.SymbolicAssertion ((.@?=))+import Test.Framework+  ( Test,+    TestOptions' (topt_timeout),+    plusTestOptions,+    testGroup,+  ) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit ((@?=)) @@ -32,99 +62,237 @@ foldableFunctionTests =   testGroup     "Foldable"-    [ testCase "mrgFoldlM" $ do-        ( mrgFoldlM-            (\acc (c, v) -> unionIf c (single $ acc + v) (single $ acc * v))-            10-            [("a", 2), ("b", 3)] ::-            UnionM Integer-          )-          @?= mrgIf-            "a"-            (mrgIf "b" (mrgReturn 15) (mrgReturn 36))+    [ testCase "symElem" $ do+        let [a, b, c] = ["a", "b", "c"] :: [SymInteger]+        let actual = symElem a [b, c]+        actual .@?= (a .== b .|| a .== c),+      testCase "mrgMaximum" $ do+        let [a, b, c] = ["a", "b", "c"] :: [SymInteger]+        let actual = mrgMaximum [[a], [b, a], [c, a, b]]+        let expected =+              mrgIf+                (a .> b .&& a .> c)+                (return [a])+                (mrgIf (b .> c) (return [b, a]) (return [c, a, b])) ::+                Union [SymInteger]+        actual .@?= expected,+      testCase "symMaximum" $ do+        let [a, b, c] = ["a", "b", "c"] :: [SymInteger]+        let actual = symMaximum [a, b, c]+        let expected = symIte (a .> b .&& a .> c) a (symIte (b .> c) b c)+        actual .@?= expected,+      testCase "mrgMinimum" $ do+        let [a, b, c] = ["a", "b", "c"] :: [SymInteger]+        let actual = mrgMinimum [[a], [b, a], [c, a, b]]+        let expected =+              mrgIf+                (a .<= b .&& a .<= c)+                (return [a])+                (mrgIf (b .<= c) (return [b, a]) (return [c, a, b])) ::+                Union [SymInteger]+        actual .@?= expected,+      testCase "symMinimum" $ do+        let [a, b, c] = ["a", "b", "c"] :: [SymInteger]+        let actual = symMinimum [a, b, c]+        let expected = symIte (a .<= b .&& a .<= c) a (symIte (b .<= c) b c)+        actual .@?= expected,+      plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $+        testGroup+          "mrgFoldrM"+          [ testCase "semantics" $ do+              let actual =+                    mrgFoldrM+                      ( \(c, v) acc ->+                          mrgIfPropagatedStrategy+                            c+                            (return $ acc + v)+                            (return $ acc * v)+                      )+                      10+                      [("a", 2), ("b", 3)] ::+                      AsKey1 Union Integer+              let expected =+                    mrgIf+                      "b"+                      (mrgIf "a" (mrgReturn 15) (mrgReturn 26))+                      (mrgIf "a" (mrgReturn 32) (mrgReturn 60))+              actual @?= expected,+            testCase "merge intermediate" $ do+              let actual = mrgFoldrM (const $ const oneNotMerged) 1 [1 .. 1000]+              let expected = mrgReturn 1 :: AsKey1 Union Int+              actual @?= expected+          ],+      plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $+        testGroup+          "mrgFoldlM"+          [ testCase "semantics" $ do+              let actual =+                    mrgFoldlM+                      ( \acc (c, v) ->+                          mrgIfPropagatedStrategy+                            c+                            (return $ acc + v)+                            (return $ acc * v)+                      )+                      10+                      [("a", 2), ("b", 3)] ::+                      AsKey1 Union Integer+              let expected =+                    mrgIf+                      "a"+                      (mrgIf "b" (mrgReturn 15) (mrgReturn 36))+                      (mrgIf "b" (mrgReturn 23) (mrgReturn 60))+              actual @?= expected,+            testCase "merge intermediate" $ do+              let actual = mrgFoldlM (const $ const oneNotMerged) 1 [1 .. 1000]+              let expected = mrgReturn 1 :: AsKey1 Union Int+              actual @?= expected+          ],+      plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $+        testGroup "mrgTraverse_, mrgMapM_, mrgFor_, mrgForM_" $ do+          (name, func0, func1) <-+            [ ("mrgTraverse_", mrgTraverse_, mrgTraverse_),+              ("mrgMapM_", mrgMapM_, mrgMapM_),+              ("mrgFor_", flip mrgFor_, flip mrgFor_),+              ("mrgForM_", flip mrgForM_, flip mrgForM_)+            ]+          [ testGroup+              name+              [ testCase "semantics" $ do+                  let actual =+                        runExceptT+                          ( func0+                              ( \(c, x) ->+                                  ExceptT $+                                    mrgIfPropagatedStrategy+                                      c+                                      (return $ Left x)+                                      (return $ Right c)+                              )+                              [("a", 3), ("b", 2)] ::+                              ExceptT Integer (AsKey1 Union) ()+                          )+                  let expected = runExceptT $ do+                        _ <- mrgIf "a" (throwError 3) (return ())+                        _ <- mrgIf "b" (throwError 2) (return ())+                        mrgReturn ()+                  actual @?= expected,+                testCase "discard and merge intermediate" $ do+                  let actual = func1 (const noMergeNotMerged) [1 .. 1000]+                  let expected = mrgReturn () :: AsKey1 Union ()+                  actual @?= expected+              ]+            ],+      plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $+        testGroup "mrgSequence_, mrgSequenceA_" $ do+          (name, func0, func1) <-+            [ ("mrgSequence_", mrgSequence_, mrgSequence_),+              ("mrgSequenceA_", mrgSequenceA_, mrgSequenceA_)+            ]+          [ testGroup+              name+              [ testCase "semantics" $ do+                  let actual =+                        runExceptT+                          ( func0 $+                              ( \(c, x) ->+                                  ExceptT $+                                    mrgIfPropagatedStrategy+                                      c+                                      (return $ Left x)+                                      (return $ Right c)+                              )+                                <$> [("a", 3), ("b", 2)] ::+                              ExceptT Integer (AsKey1 Union) ()+                          )+                  let expected = runExceptT $ do+                        _ <- mrgIf "a" (throwError 3) (return ())+                        _ <- mrgIf "b" (throwError 2) (return ())+                        mrgReturn ()+                  actual @?= expected,+                testCase "discard and merge intermediate" $ do+                  let actual = func1 (replicate 1000 noMergeNotMerged)+                  let expected = mrgReturn () :: AsKey1 Union ()+                  actual @?= expected+              ]+            ],+      plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $+        testGroup+          "mrgMsum"+          [ testCase "merge" $ do+              let none =+                    MaybeT $+                      mrgIfPropagatedStrategy "a" (return Nothing) (return Nothing)+              let expected =+                    MaybeT (mrgReturn Nothing) ::+                      MaybeT Union (Maybe Int)+              mrgMsum (replicate 100 none) @?= expected,+            testCase "semantics" $ do+              (mrgMsum [mrgMzero, mrgMzero] :: MaybeT Union Integer)+                @?= mrgMzero+              (mrgMsum [mrgReturn 1, mrgMzero] :: MaybeT Union Integer)+                @?= mrgReturn 1+              (mrgMsum [mrgMzero, mrgReturn 1] :: MaybeT Union Integer)+                @?= mrgReturn 1+              (mrgMsum [mrgReturn 2, mrgReturn 1] :: MaybeT Union Integer)+                @?= mrgReturn 2+          ],+      testCase "symAnd" $ do+        let [a, b, c] = ["a", "b", "c"] :: [SymBool]+        symAnd [a, b, c] .@?= (a .&& b .&& c),+      testCase "symOr" $ do+        let [a, b, c] = ["a", "b", "c"] :: [SymBool]+        symOr [a, b, c] .@?= (a .|| b .|| c),+      testCase "symAny" $ do+        let [a, b, c] = ["a", "b", "c"] :: [SymInteger]+        symAny (.== 0) [a, b, c] .@?= (a .== 0 .|| b .== 0 .|| c .== 0),+      testCase "symAll" $ do+        let [a, b, c] = ["a", "b", "c"] :: [SymInteger]+        symAll (.== 0) [a, b, c] .@?= (a .== 0 .&& b .== 0 .&& c .== 0),+      testCase "mrgMaximumBy" $ do+        let [a, b, c] = ["a", "b", "c"] :: [SymInteger]+        let actual = mrgMaximumBy symCompare [[a], [b, a], [c, a, b]]+        let expected =+              mrgIf+                (a .> b .&& a .> c)+                (return [a])+                (mrgIf (b .> c) (return [b, a]) (return [c, a, b])) ::+                Union [SymInteger]+        actual .@?= expected,+      testCase "symMaximumBy" $ do+        let [a, b, c] = ["a", "b", "c"] :: [SymInteger]+        let actual = symMaximumBy symCompare [a, b, c]+        let expected = symIte (a .> b .&& a .> c) a (symIte (b .> c) b c)+        actual .@?= expected,+      testCase "mrgMinimumBy" $ do+        let [a, b, c] = ["a", "b", "c"] :: [SymInteger]+        let actual = mrgMinimumBy symCompare [[a], [b, a], [c, a, b]]+        let expected =+              mrgIf+                (a .<= b .&& a .<= c)+                (return [a])+                (mrgIf (b .<= c) (return [b, a]) (return [c, a, b])) ::+                Union [SymInteger]+        actual .@?= expected,+      testCase "symMinimumBy" $ do+        let [a, b, c] = ["a", "b", "c"] :: [SymInteger]+        let actual = symMinimumBy symCompare [a, b, c]+        let expected = symIte (a .<= b .&& a .<= c) a (symIte (b .<= c) b c)+        actual .@?= expected,+      testCase "symNotElem" $ do+        let [a, b, c] = ["a", "b", "c"] :: [SymInteger]+        let actual = symNotElem a [b, c]+        actual .@?= (a ./= b .&& a ./= c),+      testCase "mrgFind" $ do+        let [a, b, c] = ["a", "b", "c"] :: [SymInteger]+        let actual = mrgFind (.== 0) [a, b, c] :: Union (Maybe SymInteger)+        actual+          .@?= mrgIf+            (a .== 0)+            (return $ Just a)             ( mrgIf-                "b"-                (mrgReturn 23)-                (mrgReturn 60)-            ),-      testCase "mrgFoldrM" $ do-        ( mrgFoldrM-            (\(c, v) acc -> unionIf c (single $ acc + v) (single $ acc * v))-            10-            [("a", 2), ("b", 3)] ::-            UnionM Integer-          )-          @?= mrgIf-            "b"-            (mrgIf "a" (mrgReturn 15) (mrgReturn 26))-            (mrgIf "a" (mrgReturn 32) (mrgReturn 60)),-      testCase "mrgTraverse_" $ do-        runExceptT-          ( mrgTraverse_-              (\(c, x) -> ExceptT $ unionIf c (return $ Left x) (return $ Right c))-              [("a", 3), ("b", 2)] ::-              ExceptT Integer (UnionM) ()-          )-          @?= runExceptT-            ( do-                _ <- mrgIf "a" (throwError 3) (return ())-                _ <- mrgIf "b" (throwError 2) (return ())-                mrgReturn ()-            ),-      testCase "mrgFor_" $ do-        runExceptT-          ( mrgFor_-              [("a", 3), ("b", 2)]-              (\(c, x) -> ExceptT $ unionIf c (return $ Left x) (return $ Right c)) ::-              ExceptT Integer UnionM ()-          )-          @?= runExceptT-            ( do-                _ <- mrgIf "a" (throwError 3) (return ())-                _ <- mrgIf "b" (throwError 2) (return ())-                mrgReturn ()-            ),-      testCase "mrgMapM_" $ do-        runExceptT-          ( mrgMapM_-              (\(c, x) -> ExceptT $ unionIf c (return $ Left x) (return $ Right c))-              [("a", 3), ("b", 2)] ::-              ExceptT Integer UnionM ()-          )-          @?= runExceptT-            ( do-                _ <- mrgIf "a" (throwError 3) (return ())-                _ <- mrgIf "b" (throwError 2) (return ())-                mrgReturn ()-            ),-      testCase "mrgForM_" $ do-        runExceptT-          ( mrgForM_-              [("a", 3), ("b", 2)]-              (\(c, x) -> ExceptT $ unionIf c (return $ Left x) (return $ Right c)) ::-              ExceptT Integer UnionM ()-          )-          @?= runExceptT-            ( do-                _ <- mrgIf "a" (throwError 3) (return ())-                _ <- mrgIf "b" (throwError 2) (return ())-                mrgReturn ()-            ),-      testCase "mrgSequence_" $ do-        runExceptT-          ( mrgSequence_-              [mrgIf "a" (throwError 3) (return ()), mrgIf "b" (throwError 2) (return ())] ::-              ExceptT Integer UnionM ()-          )-          @?= runExceptT-            ( do-                _ <- mrgIf "a" (throwError 3) (return ())-                _ <- mrgIf "b" (throwError 2) (return ())-                mrgReturn ()-            ),-      testCase "mrgMsum" $ do-        (mrgMsum [mrgMzero, mrgMzero] :: MaybeT UnionM Integer) @?= mrgMzero-        (mrgMsum [mrgReturn 1, mrgMzero] :: MaybeT UnionM Integer) @?= mrgReturn 1-        (mrgMsum [mrgMzero, mrgReturn 1] :: MaybeT UnionM Integer) @?= mrgReturn 1-        (mrgMsum [mrgReturn 2, mrgReturn 1] :: MaybeT UnionM Integer) @?= mrgReturn 2+                (b .== 0)+                (return $ Just b)+                (mrgIf (c .== 0) (return $ Just c) (return Nothing))+            )     ]
+ test/Grisette/Lib/Data/FunctorTests.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE OverloadedStrings #-}++module Grisette.Lib.Data.FunctorTests (functorFunctionTests) where++import Grisette+  ( AsKey,+    AsKey1,+    ITEOp (symIte),+    SymBranching (mrgIfPropagatedStrategy),+    SymInteger,+    Union,+    mrgIf,+    mrgSingle,+    mrgVoid,+  )+import Grisette.Lib.Data.Functor+  ( mrgFmap,+    mrgUnzip,+    (.$>),+    (.<$),+    (.<$>),+    (.<&>),+  )+import Grisette.TestUtil.NoMerge+  ( NoMerge (NoMerge),+    noMergeNotMerged,+    oneNotMerged,+  )+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit ((@?=))++functorFunctionTests :: Test+functorFunctionTests =+  testGroup+    "Functor"+    [ testGroup+        "mrgFmap"+        [ testCase "merge result" $ do+            let actual =+                  mrgFmap (\x -> x * x) $+                    mrgIfPropagatedStrategy "a" (return $ -1) (return 1)+            actual @?= (mrgSingle 1 :: AsKey1 Union Integer),+          testCase "merge arguments" $ do+            let actual = mrgFmap (const NoMerge) oneNotMerged+            actual @?= (mrgSingle NoMerge :: AsKey1 Union NoMerge)+        ],+      testGroup+        ".<$>"+        [ testCase "merge result" $ do+            let actual =+                  (\x -> x * x)+                    .<$> mrgIfPropagatedStrategy "a" (return $ -1) (return 1)+            actual @?= (mrgSingle 1 :: AsKey1 Union Integer),+          testCase "merge arguments" $ do+            let actual = (const NoMerge) .<$> oneNotMerged+            actual @?= (mrgSingle NoMerge :: AsKey1 Union NoMerge)+        ],+      testGroup+        ".<$"+        [ testCase "merge result" $+            1 .<$ noMergeNotMerged @?= (mrgSingle 1 :: AsKey1 Union Integer),+          testCase "merge arguments" $+            NoMerge .<$ oneNotMerged @?= (mrgSingle NoMerge :: AsKey1 Union NoMerge)+        ],+      testGroup+        ".$>"+        [ testCase "merge result" $+            noMergeNotMerged .$> 1 @?= (mrgSingle 1 :: AsKey1 Union Integer),+          testCase "merge arguments" $+            oneNotMerged .$> NoMerge @?= (mrgSingle NoMerge :: AsKey1 Union NoMerge)+        ],+      testGroup+        ".<&>"+        [ testCase "merge result" $ do+            let actual =+                  mrgIfPropagatedStrategy "a" (return $ -1) (return 1)+                    .<&> (\x -> x * x)+            actual @?= (mrgSingle 1 :: AsKey1 Union Integer),+          testCase "merge arguments" $ do+            let actual = oneNotMerged .<&> (const NoMerge)+            actual @?= (mrgSingle NoMerge :: AsKey1 Union NoMerge)+        ],+      testCase "mrgUnzip" $ do+        let actual =+              mrgUnzip+                (mrgIfPropagatedStrategy "x" (return ("a", 1)) (return ("b", 2)))+        let expected =+              ( mrgSingle (symIte "x" "a" "b"),+                mrgIf "x" 1 2+              ) ::+                (AsKey1 Union (AsKey SymInteger), AsKey1 Union Integer)+        actual @?= expected,+      testCase "mrgVoid" $ do+        let actual = mrgVoid noMergeNotMerged+        let expected = mrgSingle () :: AsKey1 Union ()+        actual @?= expected+    ]
+ test/Grisette/Lib/Data/ListTests.hs view
@@ -0,0 +1,751 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Use elemIndex" #-}+{-# HLINT ignore "Use elemIndices" #-}+{-# HLINT ignore "Use nub" #-}+{-# HLINT ignore "Use union" #-}+{-# HLINT ignore "Use intersect" #-}+{-# HLINT ignore "Use insert" #-}+{-# HLINT ignore "Use group" #-}++module Grisette.Lib.Data.ListTests (listTests) where++import Data.List+  ( delete,+    deleteBy,+    deleteFirstsBy,+    dropWhileEnd,+    elemIndex,+    elemIndices,+    findIndex,+    findIndices,+    group,+    groupBy,+    insert,+    insertBy,+    intersect,+    intersectBy,+    isInfixOf,+    isPrefixOf,+    isSubsequenceOf,+    isSuffixOf,+    nub,+    nubBy,+    partition,+    stripPrefix,+    union,+    unionBy,+    (\\),+  )+import Grisette+  ( ITEOp (symIte),+    LogicalOp (symNot, (.&&), (.||)),+    Solvable (con),+    SymBool,+    SymEq ((./=), (.==)),+    SymOrd (symCompare, (.<=), (.>=)),+    Union,+    mrgGroupBy,+    mrgIf,+  )+import Grisette.Lib.Control.Applicative (mrgPure)+import Grisette.Lib.Data.List+  ( mrgBreak,+    mrgDelete,+    mrgDeleteBy,+    mrgDeleteFirstsBy,+    mrgDrop,+    mrgDropWhile,+    mrgDropWhileEnd,+    mrgElemIndex,+    mrgElemIndices,+    mrgFilter,+    mrgFindIndex,+    mrgFindIndices,+    mrgGroup,+    mrgInsert,+    mrgInsertBy,+    mrgIntersect,+    mrgIntersectBy,+    mrgLookup,+    mrgNub,+    mrgNubBy,+    mrgPartition,+    mrgSpan,+    mrgSplitAt,+    mrgStripPrefix,+    mrgTake,+    mrgTakeWhile,+    mrgUnion,+    mrgUnionBy,+    symIsInfixOf,+    symIsPrefixOf,+    symIsSubsequenceOf,+    symIsSuffixOf,+    (.!?),+    (.\\),+  )+import Grisette.SymPrim (SymInteger)+import Grisette.TestUtil.SymbolicAssertion ((.@?=))+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.QuickCheck (Gen, forAll, ioProperty, listOf, oneof)++aint, bint, cint, dint, eint, fint :: SymInteger+aint = "a"+bint = "b"+cint = "c"+dint = "d"+eint = "e"+fint = "f"++ranint :: Gen SymInteger+ranint = oneof $ return <$> [aint, bint, cint, dint, eint, fint, -1, 0, 1]++ranilist :: Gen [SymInteger]+ranilist = listOf ranint++listTests :: Test+listTests =+  testGroup+    "List"+    [ testGroup+        "mrgTake"+        [ testProperty "concrete int" $+            \(n :: Integer) -> forAll ranilist $ \ranilist -> ioProperty $ do+              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] :: Union [SymInteger]+            let expected =+                  mrgIf (aint .<= 0) (return []) $+                    mrgIf (aint .== 1) (return [bint]) $+                      mrgIf (aint .== 2) (return [bint, cint]) $+                        return [bint, cint, dint]+            actual .@?= expected+        ],+      testGroup+        "mrgDrop"+        [ testProperty "concrete int" $+            \(n :: Integer) -> forAll ranilist $ \ranilist -> ioProperty $ do+              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] :: Union [SymInteger]+            let expected =+                  mrgIf (aint .>= 3) (return []) $+                    mrgIf (aint .== 2) (return [dint]) $+                      mrgIf (aint .== 1) (return [cint, dint]) $+                        return [bint, cint, dint]+            actual .@?= expected+        ],+      testGroup+        "mrgSplitAt"+        [ testProperty "concrete int" $+            \(n :: Integer) -> forAll ranilist $ \ranilist -> ioProperty $ do+              let actual =+                    mrgSplitAt n ranilist ::+                      Union ([SymInteger], [SymInteger])+              let expected = mrgPure $ splitAt (fromInteger n) ranilist+              actual .@?= expected,+          testCase "symbolic int" $ do+            let actual =+                  mrgSplitAt aint [bint, cint, dint] ::+                    Union ([SymInteger], [SymInteger])+            let expected =+                  mrgIf (aint .<= 0) (return ([], [bint, cint, dint])) $+                    mrgIf (aint .== 1) (return ([bint], [cint, dint])) $+                      mrgIf (aint .== 2) (return ([bint, cint], [dint])) $+                        return ([bint, cint, dint], [])+            actual .@?= expected+        ],+      testGroup+        "mrgTakeWhile"+        [ testProperty "concrete int" $+            \ranilist -> ioProperty $ do+              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] :: Union [SymInteger]+            let expected =+                  mrgIf (aint ./= 0) (return []) $+                    mrgIf (bint ./= 0) (return [aint]) $+                      mrgIf (cint ./= 0) (return ([aint, bint])) $+                        return [aint, bint, cint]+            actual .@?= expected+        ],+      testGroup+        "mrgDropWhile"+        [ testProperty "concrete int" $+            \ranilist -> ioProperty $ do+              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] :: Union [SymInteger]+            let expected =+                  mrgIf+                    ((aint .== 0 .&& bint .== 0) .&& cint .== 0)+                    (return [])+                    $ mrgIf (aint .== 0 .&& bint .== 0) (return [cint])+                    $ mrgIf (aint .== 0) (return ([bint, cint]))+                    $ return [aint, bint, cint]+            actual .@?= expected+        ],+      testGroup+        "mrgDropWhileEnd"+        [ testProperty "concrete int" $+            \ranilist -> ioProperty $ do+              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] ::+                    Union [SymInteger]+            let expected =+                  mrgIf+                    ((cint .== 0 .&& bint .== 0) .&& aint .== 0)+                    (return [])+                    $ mrgIf (cint .== 0 .&& bint .== 0) (return [aint])+                    $ mrgIf (cint .== 0) (return ([aint, bint]))+                    $ return [aint, bint, cint]+            actual .@?= expected+        ],+      testGroup+        "mrgSpan"+        [ testProperty "concrete int" $+            \ranilist -> ioProperty $ do+              let actual =+                    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] ::+                    Union ([SymInteger], [SymInteger])+            let expected =+                  mrgIf (aint ./= 0) (return ([], [aint, bint, cint])) $+                    mrgIf (bint ./= 0) (return ([aint], [bint, cint])) $+                      mrgIf (cint ./= 0) (return ([aint, bint], [cint])) $+                        return ([aint, bint, cint], [])+            actual .@?= expected+        ],+      testGroup+        "mrgBreak"+        [ testProperty "concrete int" $+            \ranilist -> ioProperty $ do+              let actual =+                    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] ::+                    Union ([SymInteger], [SymInteger])+            let expected =+                  mrgIf (aint .== 0) (return ([], [aint, bint, cint])) $+                    mrgIf (bint .== 0) (return ([aint], [bint, cint])) $+                      mrgIf (cint .== 0) (return ([aint, bint], [cint])) $+                        return ([aint, bint, cint], [])+            actual .@?= expected+        ],+      testGroup+        "mrgStripPrefix"+        [ testProperty "concrete int" $+            \l1 l2 -> ioProperty $ do+              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] ::+                    Union (Maybe [SymInteger])+            let expected =+                  mrgIf+                    ((aint ./= cint) .|| (bint ./= dint))+                    (return Nothing)+                    (return $ Just [eint])+            actual .@?= expected+        ],+      testGroup+        "mrgGroup"+        [ testProperty "concrete int" $+            \l -> ioProperty $ do+              let actual = mrgGroup l :: Union [[Integer]]+              let expected = mrgPure $ group l+              actual .@?= expected,+          testCase "symbolic int" $ do+            let actual = mrgGroup [aint, bint, cint] :: Union [[SymInteger]]+            let expected =+                  mrgIf+                    (aint .== bint .&& aint .== cint)+                    (return [[aint, bint, cint]])+                    $ mrgIf+                      (aint .== bint .|| bint .== cint)+                      ( mrgIf (aint .== bint) (return [[aint, bint], [cint]]) $+                          return [[aint], [bint, cint]]+                      )+                    $ return [[aint], [bint], [cint]]++            actual .@?= expected+        ],+      testGroup+        "symIsPrefixOf"+        [ testProperty "concrete int" $+            \(l1 :: [Int]) l2 -> ioProperty $ do+              let actual = symIsPrefixOf l1 l2 :: SymBool+              let expected = con $ isPrefixOf l1 l2+              actual .@?= expected,+          testCase "symbolic int" $ do+            let actual = symIsPrefixOf [aint, bint] [cint, dint, eint]+            actual .@?= (aint .== cint .&& bint .== dint),+          testCase "symbolic int, not long enough" $ do+            let actual = symIsPrefixOf [cint, dint, eint] [aint, bint]+            actual .@?= con False+        ],+      testGroup+        "symIsSuffixOf"+        [ testProperty "concrete int" $+            \(l1 :: [Int]) l2 -> ioProperty $ do+              let actual = symIsSuffixOf l1 l2 :: SymBool+              let expected = con $ isSuffixOf l1 l2+              actual .@?= expected,+          testCase "symbolic int" $ do+            let actual = symIsSuffixOf [aint, bint] [cint, dint, eint]+            actual .@?= (bint .== eint .&& aint .== dint),+          testCase "symbolic int, not long enough" $ do+            let actual = symIsSuffixOf [cint, dint, eint] [aint, bint]+            actual .@?= con False+        ],+      testGroup+        "symIsInfixOf"+        [ testProperty "concrete int" $+            \(l1 :: [Int]) l2 -> ioProperty $ do+              let actual = symIsInfixOf l1 l2 :: SymBool+              let expected = con $ isInfixOf l1 l2+              actual .@?= expected,+          testCase "symbolic int" $ do+            let actual = symIsInfixOf [aint, bint] [cint, dint, eint, fint]+            actual+              .@?= ( (aint .== cint .&& bint .== dint)+                       .|| (aint .== dint .&& bint .== eint)+                   )+              .|| (aint .== eint .&& bint .== fint),+          testCase "symbolic int, not long enough" $ do+            let actual = symIsInfixOf [cint, dint, eint] [aint, bint]+            actual .@?= con False+        ],+      testGroup+        "symIsSubsequenceOf"+        [ testProperty "concrete int" $+            \(l1 :: [Int]) l2 -> ioProperty $ do+              let actual = symIsSubsequenceOf l1 l2 :: SymBool+              let expected = con $ isSubsequenceOf l1 l2+              actual .@?= expected,+          testCase "symbolic int" $ do+            let actual =+                  symIsSubsequenceOf [aint, bint] [cint, dint, eint, fint]+            actual+              .@?= symIte+                (aint .== cint)+                (bint .== dint .|| (bint .== eint .|| bint .== fint))+                ( symIte+                    (aint .== dint)+                    (bint .== eint .|| bint .== fint)+                    (aint .== eint .&& bint .== fint)+                ),+          testCase "symbolic int, not long enough" $ do+            let actual = symIsSubsequenceOf [cint, dint, eint] [aint, bint]+            actual .@?= con False+        ],+      testGroup+        "mrgLookup"+        [ testProperty "concrete int" $+            \v l -> ioProperty $ do+              let actual = mrgLookup (v :: Integer) l :: Union (Maybe Integer)+              let expected = mrgPure $ lookup v l+              actual .@?= expected,+          testCase "symbolic int" $ do+            let actual =+                  mrgLookup+                    aint+                    [ (bint, Just cint),+                      (dint, Nothing),+                      (fint, Just eint)+                    ] ::+                    Union (Maybe (Maybe SymInteger))+            let expected =+                  mrgIf+                    ((aint ./= bint .&& aint ./= dint) .&& aint ./= fint)+                    (return Nothing)+                    $ mrgIf (aint .== bint) (return $ Just $ Just cint)+                    $ mrgIf+                      (aint .== dint)+                      (return $ Just Nothing)+                      (return $ Just $ Just eint)+            actual .@?= expected+        ],+      testGroup+        "mrgFilter"+        [ testProperty "concrete int" $+            \l -> ioProperty $ do+              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] :: Union [SymInteger]+            let expected =+                  mrgIf (aint ./= 0 .&& bint ./= 0) (return []) $+                    mrgIf+                      (aint ./= 0 .|| bint ./= 0)+                      (return [symIte (aint .== 0) aint bint])+                      (return [aint, bint])+            actual .@?= expected+        ],+      testGroup+        "mrgPartition"+        [ testProperty "concrete int" $+            \l -> ioProperty $ do+              let actual =+                    mrgPartition (.== 0) l ::+                      Union ([Integer], [Integer])+              let expected = mrgPure $ partition (== 0) l+              actual .@?= expected,+          testCase "symbolic int" $ do+            let actual =+                  mrgPartition (.== 0) [aint, bint] ::+                    Union ([SymInteger], [SymInteger])+            let expected =+                  mrgIf+                    (aint ./= 0 .&& bint ./= 0)+                    (return ([], [aint, bint]))+                    $ mrgIf+                      (aint ./= 0 .|| bint ./= 0)+                      ( return+                          ( [symIte (aint .== 0) aint bint],+                            [symIte (aint .== 0) bint aint]+                          )+                      )+                      (return ([aint, bint], []))+            actual .@?= expected+        ],+      testGroup+        ".!?"+        [ testProperty "concrete int" $+            \l (i :: Int) -> ioProperty $ do+              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 :: Union (Maybe SymInteger)+            let expected =+                  mrgIf+                    (dint ./= 0 .&& dint ./= 1 .&& dint ./= 2)+                    (return Nothing)+                    ( return $+                        Just $+                          symIte (dint .== 0) aint $+                            symIte (dint .== 1) bint cint+                    )+            actual .@?= expected+        ],+      testGroup+        "mrgElemIndex"+        [ testProperty "concrete int" $+            \(v :: Integer) l -> ioProperty $ do+              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] ::+                    Union (Maybe SymInteger)+            let expected =+                  mrgIf+                    (aint ./= bint .&& aint ./= cint .&& aint ./= dint)+                    (mrgPure Nothing)+                    ( mrgPure $+                        Just $+                          symIte (aint .== bint) 0 (symIte (aint .== cint) 1 2)+                    )+            actual .@?= expected+        ],+      testGroup+        "mrgElemIndices"+        [ testProperty "concrete int" $+            \(v :: Integer) l -> ioProperty $ do+              let actual = mrgElemIndices v l :: Union [Int]+              let expected = mrgPure $ elemIndices v l+              actual .@?= expected+        ],+      testGroup+        "mrgFindIndex"+        [ testProperty "concrete int" $+            \(l :: [Integer]) -> ioProperty $ do+              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] ::+                    Union (Maybe SymInteger)+            let expected =+                  mrgIf+                    (aint ./= 0 .&& bint ./= 0 .&& cint ./= 0)+                    (mrgPure Nothing)+                    ( mrgPure $+                        Just $+                          symIte (aint .== 0) 0 (symIte (bint .== 0) 1 2)+                    )+            actual .@?= expected+        ],+      testGroup+        "mrgFindIndices"+        [ testProperty "concrete int" $+            \(l :: [Integer]) -> ioProperty $ do+              let actual = mrgFindIndices (.== 0) l :: Union [Int]+              let expected = mrgPure $ findIndices (== 0) l+              actual .@?= expected+        ],+      testGroup+        "mrgNub"+        [ testProperty "concrete int" $+            \l -> ioProperty $ do+              let actual = mrgNub l :: Union [Integer]+              let expected = mrgPure $ nub l+              actual .@?= expected,+          testCase "symbolic int" $ do+            let actual = mrgNub [aint, bint, cint] :: Union [SymInteger]+            let expected =+                  mrgIf+                    (bint .== aint .&& cint .== aint)+                    (return [aint])+                    $ mrgIf+                      (bint .== aint .|| cint .== bint .|| cint .== aint)+                      (return [aint, symIte (bint .== aint) cint bint])+                      (return [aint, bint, cint])+            actual .@?= expected+        ],+      testGroup+        "mrgDelete"+        [ testProperty "concrete int" $+            \i l -> ioProperty $ do+              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] :: Union [SymInteger]+            let expected =+                  mrgIf+                    (aint .== bint .|| aint .== cint .|| aint .== dint)+                    ( return+                        [ symIte (aint .== bint) cint bint,+                          symIte (aint .== bint .|| aint .== cint) dint cint+                        ]+                    )+                    (return [bint, cint, dint])+            actual .@?= expected+        ],+      testGroup+        ".\\\\"+        [ testProperty "concrete int" $+            \l1 l2 -> ioProperty $ do+              let actual = l1 .\\ l2 :: Union [Integer]+              let expected = mrgPure $ l1 \\ l2+              actual .@?= expected+        ],+      testGroup+        "mrgUnion"+        [ testProperty "concrete int" $+            \l1 l2 -> ioProperty $ do+              let actual = mrgUnion l1 l2 :: Union [Integer]+              let expected = mrgPure $ union l1 l2+              actual .@?= expected+        ],+      testGroup+        "mrgIntersect"+        [ testProperty "concrete int" $+            \l1 l2 -> ioProperty $ do+              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] :: Union [SymInteger]+            let expected =+                  mrgIf+                    ( symNot $+                        (bint .== cint .|| bint .== dint)+                          .|| (aint .== cint .|| aint .== dint)+                    )+                    (return [])+                    ( mrgIf+                        ( symNot $+                            (bint .== cint .|| bint .== dint)+                              .&& (aint .== cint .|| aint .== dint)+                        )+                        ( return+                            [symIte (bint .== cint .|| bint .== dint) bint aint]+                        )+                        (return [aint, bint])+                    )+            actual .@?= expected+        ],+      testGroup+        "mrgNubBy"+        [ testProperty "concrete int" $+            \l -> ioProperty $ do+              let actual = mrgNubBy (.==) l :: Union [Integer]+              let expected = mrgPure $ nubBy (==) l+              actual .@?= expected,+          testCase "symbolic int" $ do+            let actual =+                  mrgNubBy (.==) [aint, bint, cint] :: Union [SymInteger]+            let expected =+                  mrgIf+                    (bint .== aint .&& cint .== aint)+                    (return [aint])+                    $ mrgIf+                      (bint .== aint .|| cint .== bint .|| cint .== aint)+                      (return [aint, symIte (bint .== aint) cint bint])+                      (return [aint, bint, cint])+            actual .@?= expected+        ],+      testGroup+        "mrgDeleteBy"+        [ testProperty "concrete int" $+            \i l -> ioProperty $ do+              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] ::+                    Union [SymInteger]+            let expected =+                  mrgIf+                    (aint ./= bint .|| aint ./= cint .|| aint ./= dint)+                    ( return+                        [ symIte (aint ./= bint) cint bint,+                          symIte (aint ./= bint .|| aint ./= cint) dint cint+                        ]+                    )+                    (return [bint, cint, dint])+            actual .@?= expected+        ],+      testGroup+        "mrgDeleteFirstsBy"+        [ testProperty "concrete int" $+            \l1 l2 -> ioProperty $ do+              let actual = mrgDeleteFirstsBy (./=) l1 l2 :: Union [Integer]+              let expected = mrgPure $ deleteFirstsBy (/=) l1 l2+              actual .@?= expected+        ],+      testGroup+        "mrgUnionBy"+        [ testProperty "concrete int" $+            \l1 l2 -> ioProperty $ do+              let actual = mrgUnionBy (.==) l1 l2 :: Union [Integer]+              let expected = mrgPure $ unionBy (==) l1 l2+              actual .@?= expected+        ],+      testGroup+        "mrgIntersectBy"+        [ testProperty "concrete int" $+            \l1 l2 -> ioProperty $ do+              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] ::+                    Union [SymInteger]+            let expected =+                  mrgIf+                    ( symNot $+                        (bint .== cint .|| bint .== dint)+                          .|| (aint .== cint .|| aint .== dint)+                    )+                    (return [])+                    ( mrgIf+                        ( symNot $+                            (bint .== cint .|| bint .== dint)+                              .&& (aint .== cint .|| aint .== dint)+                        )+                        ( return+                            [symIte (bint .== cint .|| bint .== dint) bint aint]+                        )+                        (return [aint, bint])+                    )+            actual .@?= expected+        ],+      testGroup+        "mrgGroupBy"+        [ testProperty "concrete int" $+            \l -> ioProperty $ do+              let actual = mrgGroupBy (.==) l :: Union [[Integer]]+              let expected = mrgPure $ groupBy (==) l+              actual .@?= expected,+          testCase "symbolic int" $ do+            let actual =+                  mrgGroupBy (.==) [aint, bint, cint] :: Union [[SymInteger]]+            let expected =+                  mrgIf+                    (aint .== bint .&& aint .== cint)+                    (return [[aint, bint, cint]])+                    $ mrgIf+                      (aint .== bint .|| bint .== cint)+                      ( mrgIf (aint .== bint) (return [[aint, bint], [cint]]) $+                          return [[aint], [bint, cint]]+                      )+                    $ return [[aint], [bint], [cint]]++            actual .@?= expected+        ],+      testGroup+        "mrgInsert"+        [ testProperty "concrete int" $+            \i l -> ioProperty $ do+              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] :: Union [SymInteger]+            let expected =+                  mrgPure+                    [ symIte (aint .<= bint) aint bint,+                      symIte (aint .<= bint) bint $+                        symIte (aint .<= cint) aint cint,+                      symIte (aint .<= bint .|| aint .<= cint) cint $+                        symIte (aint .<= dint) aint dint,+                      symIte+                        (aint .<= bint .|| aint .<= cint .|| aint .<= dint)+                        dint+                        aint+                    ]+            actual .@?= expected+        ],+      testGroup+        "mrgInsertBy"+        [ testProperty "concrete int" $+            \i l -> ioProperty $ do+              let actual = mrgInsertBy symCompare i l :: Union [Integer]+              let expected = mrgPure $ insertBy compare i l+              actual .@?= expected+        ]+    ]
test/Grisette/Lib/Data/TraversableTests.hs view
@@ -5,108 +5,169 @@ import Control.Monad.Except   ( ExceptT (ExceptT),     MonadError (throwError),-    runExceptT,   )-import Grisette.Core.Control.Monad.UnionM (UnionM)-import Grisette.Core.Data.Class.SimpleMergeable-  ( UnionLike (unionIf),+import Grisette+  ( SymBranching (mrgIfPropagatedStrategy),+    Union,     mrgIf,     mrgSingle,   )+import Grisette.Lib.Control.Monad (mrgReturn) import Grisette.Lib.Data.Traversable   ( mrgFor,+    mrgForAccumM,     mrgForM,+    mrgMapAccumM,     mrgMapM,     mrgSequence,     mrgSequenceA,     mrgTraverse,   )-import Test.Framework (Test, testGroup)+import Grisette.TestUtil.NoMerge (oneNotMerged)+import Grisette.TestUtil.SymbolicAssertion ((.@?=))+import Test.Framework+  ( Test,+    TestOptions' (topt_timeout),+    plusTestOptions,+    testGroup,+  ) import Test.Framework.Providers.HUnit (testCase)-import Test.HUnit ((@?=))  traversableFunctionTests :: Test traversableFunctionTests =   testGroup     "Traversable"-    [ testCase "mrgTraverse" $ do-        runExceptT-          ( mrgTraverse-              (\(c, d, x, y, z) -> ExceptT $ unionIf c (return $ Left x) (unionIf d (return $ Right y) (return $ Right z)))-              [("a", "c", 3, 4, 5), ("b", "d", 2, 3, 6)] ::-              ExceptT Integer UnionM [Integer]-          )-          @?= runExceptT-            ( do-                a <- mrgIf "a" (throwError 3) (mrgIf "c" (return 4) (return 5))-                b <- mrgIf "b" (throwError 2) (mrgIf "d" (return 3) (return 6))-                mrgSingle [a, b]-            ),-      testCase "mrgSequenceA" $ do-        runExceptT-          ( mrgSequenceA-              [ ExceptT $ unionIf "a" (return $ Left 3) (unionIf "c" (return $ Right 4) (return $ Right 5)),-                ExceptT $ unionIf "b" (return $ Left 2) (unionIf "d" (return $ Right 3) (return $ Right 6))-              ] ::-              ExceptT Integer UnionM [Integer]-          )-          @?= runExceptT-            ( do-                a <- mrgIf "a" (throwError 3) (mrgIf "c" (return 4) (return 5))-                b <- mrgIf "b" (throwError 2) (mrgIf "d" (return 3) (return 6))-                mrgSingle [a, b]-            ),-      testCase "mrgMapM" $ do-        runExceptT-          ( mrgMapM-              (\(c, d, x, y, z) -> ExceptT $ unionIf c (return $ Left x) (unionIf d (return $ Right y) (return $ Right z)))-              [("a", "c", 3, 4, 5), ("b", "d", 2, 3, 6)] ::-              ExceptT Integer UnionM [Integer]-          )-          @?= runExceptT-            ( do-                a <- mrgIf "a" (throwError 3) (mrgIf "c" (return 4) (return 5))-                b <- mrgIf "b" (throwError 2) (mrgIf "d" (return 3) (return 6))-                mrgSingle [a, b]-            ),-      testCase "mrgSequence" $ do-        runExceptT-          ( mrgSequence-              [ ExceptT $ unionIf "a" (return $ Left 3) (unionIf "c" (return $ Right 4) (return $ Right 5)),-                ExceptT $ unionIf "b" (return $ Left 2) (unionIf "d" (return $ Right 3) (return $ Right 6))-              ] ::-              ExceptT Integer UnionM [Integer]-          )-          @?= runExceptT-            ( do-                a <- mrgIf "a" (throwError 3) (mrgIf "c" (return 4) (return 5))-                b <- mrgIf "b" (throwError 2) (mrgIf "d" (return 3) (return 6))-                mrgSingle [a, b]-            ),-      testCase "mrgFor" $ do-        runExceptT-          ( mrgFor-              [("a", "c", 3, 4, 5), ("b", "d", 2, 3, 6)]-              (\(c, d, x, y, z) -> ExceptT $ unionIf c (return $ Left x) (unionIf d (return $ Right y) (return $ Right z))) ::-              ExceptT Integer UnionM [Integer]-          )-          @?= runExceptT-            ( do-                a <- mrgIf "a" (throwError 3) (mrgIf "c" (return 4) (return 5))-                b <- mrgIf "b" (throwError 2) (mrgIf "d" (return 3) (return 6))-                mrgSingle [a, b]-            ),-      testCase "mrgForM" $ do-        runExceptT-          ( mrgForM-              [("a", "c", 3, 4, 5), ("b", "d", 2, 3, 6)]-              (\(c, d, x, y, z) -> ExceptT $ unionIf c (return $ Left x) (unionIf d (return $ Right y) (return $ Right z))) ::-              ExceptT Integer UnionM [Integer]-          )-          @?= runExceptT-            ( do-                a <- mrgIf "a" (throwError 3) (mrgIf "c" (return 4) (return 5))-                b <- mrgIf "b" (throwError 2) (mrgIf "d" (return 3) (return 6))-                mrgSingle [a, b]-            )+    [ plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $+        testGroup "mrgTraverse, mrgMapM, mrgFor, mrgForM" $ do+          (name, func0, func1) <-+            [ ("mrgTraverse", mrgTraverse, mrgTraverse),+              ("mrgMapM", mrgMapM, mrgMapM),+              ("mrgFor", flip mrgFor, flip mrgFor),+              ("mrgForM", flip mrgForM, flip mrgForM)+            ]+          return $+            testGroup+              name+              [ testCase "semantics" $ do+                  let actual =+                        func0+                          ( \(c, d, x, y, z) ->+                              ExceptT $+                                mrgIfPropagatedStrategy+                                  c+                                  (return $ Left x)+                                  ( mrgIfPropagatedStrategy+                                      d+                                      (return $ Right y)+                                      (return $ Right z)+                                  )+                          )+                          [("a", "c", 3, 4, 5), ("b", "d", 2, 3, 6)] ::+                          ExceptT Integer Union [Integer]+                  let expected = do+                        a <-+                          mrgIf+                            "a"+                            (throwError 3)+                            (mrgIf "c" (return 4) (return 5))+                        b <-+                          mrgIf+                            "b"+                            (throwError 2)+                            (mrgIf "d" (return 3) (return 6))+                        mrgSingle [a, b]+                  actual .@?= expected,+                testCase "merge intermediate" $ do+                  let actual = func1 (const oneNotMerged) [1 .. 1000]+                  let expected = mrgReturn $ replicate 1000 1+                  actual .@?= expected+              ],+      plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $+        testGroup "mrgSequenceA, mrgSequence" $ do+          (name, func0, func1) <-+            [ ("mrgSequenceA", mrgSequenceA, mrgSequenceA),+              ("mrgSequence", mrgSequence, mrgSequence)+            ]+          return $+            testGroup+              name+              [ testCase "semantics" $ do+                  let actual =+                        func0+                          [ ExceptT $+                              mrgIfPropagatedStrategy+                                "a"+                                (return $ Left 3)+                                ( mrgIfPropagatedStrategy+                                    "c"+                                    (return $ Right 4)+                                    (return $ Right 5)+                                ),+                            ExceptT $+                              mrgIfPropagatedStrategy+                                "b"+                                (return $ Left 2)+                                ( mrgIfPropagatedStrategy+                                    "d"+                                    (return $ Right 3)+                                    (return $ Right 6)+                                )+                          ] ::+                          ExceptT Integer Union [Integer]+                  let expected = do+                        a <-+                          mrgIf+                            "a"+                            (throwError 3)+                            (mrgIf "c" (return 4) (return 5))+                        b <-+                          mrgIf+                            "b"+                            (throwError 2)+                            (mrgIf "d" (return 3) (return 6))+                        mrgSingle [a, b]+                  actual .@?= expected,+                testCase "merge intermediate" $ do+                  let actual = func1 (replicate 1000 oneNotMerged)+                  let expected = mrgReturn $ replicate 1000 1+                  actual .@?= expected+              ],+      plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $+        testGroup "mrgMapAccumM, mrgForAccumM" $ do+          (name, func0, func1) <-+            [ ("mrgMapAccumM", mrgMapAccumM, mrgMapAccumM),+              ( "mrgForAccumM",+                \f s t -> mrgForAccumM s t f,+                \f s t -> mrgForAccumM s t f+              )+            ]+          return $+            testGroup+              name+              [ testCase "semantics" $ do+                  let actual =+                        func0 (\a b -> mrgSingle (a + b, a - b)) 0 [1 .. 1000]+                  let expected =+                        mrgReturn+                          ( 500500,+                            [(i - 1) * i `div` 2 - i | i <- [1 .. 1000]]+                          ) ::+                          Union (Integer, [Integer])+                  actual .@?= expected,+                testCase "merge intermediate" $ do+                  let actual =+                        func1+                          ( \_ _ ->+                              mrgIfPropagatedStrategy+                                "a"+                                (return (1, 1))+                                (return (1, 1))+                          )+                          0+                          [1 .. 1000]+                  let expected =+                        mrgReturn (1, replicate 1000 1) ::+                          Union (Integer, [Integer])+                  actual .@?= expected+              ]     ]
+ test/Grisette/SymPrim/AlgRealTests.hs view
@@ -0,0 +1,105 @@+{-# HLINT ignore "Unused LANGUAGE pragma" #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++module Grisette.SymPrim.AlgRealTests (algRealTests) where++import Control.DeepSeq (NFData, force)+import Control.Exception (ArithException, evaluate, try)+import Grisette.Internal.SymPrim.AlgReal (AlgReal)+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.HUnit (assertBool, (@?=))+import Test.QuickCheck (ioProperty)++unaryOpComplianceWithRational ::+  (NFData a, NFData b) =>+  String ->+  (AlgReal -> a) ->+  (Rational -> b) ->+  (a -> b -> Bool) ->+  Test+unaryOpComplianceWithRational name algRealOp rationalOp cmp =+  testProperty name $ \x -> ioProperty $ do+    actual <- try $ evaluate $ force $ algRealOp (fromRational x)+    expected <- try $ evaluate $ force $ rationalOp x+    case (actual, expected) of+      (Left (ea :: ArithException), Left ee) -> ea @?= ee+      (Right a, Right e) -> assertBool "Not compliant" $ cmp a e+      _ -> assertBool "Not compliant" False++binOpComplianceWithRational ::+  (NFData a, NFData b) =>+  String ->+  (AlgReal -> AlgReal -> a) ->+  (Rational -> Rational -> b) ->+  (a -> b -> Bool) ->+  Test+binOpComplianceWithRational name algRealOp rationalOp cmp =+  testProperty name $ \x y -> ioProperty $ do+    actual <-+      try $ evaluate $ force $ algRealOp (fromRational x) (fromRational y)+    expected <- try $ evaluate $ force $ rationalOp x y+    case (actual, expected) of+      (Left (ea :: ArithException), Left ee) -> ea @?= ee+      (Right a, Right e) -> assertBool "Not compliant" $ cmp a e+      _ -> assertBool "Not compliant" False++eqAlgRealRational :: AlgReal -> Rational -> Bool+eqAlgRealRational l r = l == fromRational r++algRealTests :: Test+algRealTests =+  testGroup+    "AlgReal"+    [ testGroup+        "Eq"+        [ binOpComplianceWithRational "==" (==) (==) (==),+          binOpComplianceWithRational "/=" (/=) (/=) (==)+        ],+      testGroup+        "Ord"+        [ binOpComplianceWithRational "<" (<) (<) (==),+          binOpComplianceWithRational "<=" (<=) (<=) (==),+          binOpComplianceWithRational ">" (>) (>) (==),+          binOpComplianceWithRational ">=" (>=) (>=) (==)+        ],+      testGroup+        "Num"+        [ binOpComplianceWithRational "+" (+) (+) eqAlgRealRational,+          binOpComplianceWithRational "*" (*) (*) eqAlgRealRational,+          binOpComplianceWithRational "-" (-) (-) eqAlgRealRational,+          unaryOpComplianceWithRational+            "negate"+            negate+            negate+            eqAlgRealRational,+          unaryOpComplianceWithRational "abs" abs abs eqAlgRealRational,+          unaryOpComplianceWithRational+            "signum"+            signum+            signum+            eqAlgRealRational,+          testProperty "fromInteger" $ \x ->+            let actual = fromInteger x+                expected = fromRational $ toRational x+             in eqAlgRealRational actual expected+        ],+      testCase "Lift" $ do+        let x = 1 :: AlgReal+        $$([||x||]) @?= x,+      testGroup+        "Fractional"+        [ binOpComplianceWithRational "/" (/) (/) eqAlgRealRational,+          unaryOpComplianceWithRational+            "recip"+            recip+            recip+            eqAlgRealRational,+          testProperty "fromRational" $ \x ->+            let actual = fromRational x+             in eqAlgRealRational actual x+        ]+    ]
+ test/Grisette/SymPrim/BVTests.hs view
@@ -0,0 +1,530 @@+{-# LANGUAGE BinaryLiterals #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE NegativeLiterals #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Grisette.SymPrim.BVTests (bvTests) where++import Control.DeepSeq (NFData (rnf), deepseq, force)+import Control.Exception+  ( ArithException,+    SomeException,+    catch,+    evaluate,+  )+import Control.Monad (when)+import Data.Bifunctor (Bifunctor (bimap))+import Data.Bits+  ( Bits+      ( bit,+        bitSizeMaybe,+        clearBit,+        complement,+        complementBit,+        isSigned,+        popCount,+        rotate,+        rotateL,+        rotateR,+        setBit,+        shift,+        shiftL,+        shiftR,+        testBit,+        xor,+        zeroBits,+        (.&.),+        (.|.)+      ),+    FiniteBits (countLeadingZeros, countTrailingZeros, finiteBitSize),+  )+import Data.Int (Int8)+import Data.Proxy (Proxy (Proxy))+import Data.Serialize (decode, encode)+import Data.Typeable (Typeable, typeRep)+import Data.Word (Word8)+import GHC.Stack (HasCallStack)+import Grisette+  ( BV (bv),+    SizedBV+      ( sizedBVConcat,+        sizedBVExt,+        sizedBVSelect,+        sizedBVSext,+        sizedBVZext+      ),+    SomeIntN,+    SomeWordN,+    pattern SomeIntN,+    pattern SomeWordN,+  )+import Grisette.Internal.SymPrim.BV+  ( IntN (IntN),+    WordN (unWordN),+  )+import Test.Framework (Test, TestName, testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.HUnit (Assertion, assertFailure, (@=?), (@?=))+import Test.QuickCheck (Arbitrary, Property, ioProperty)++unaryConform :: forall a b c d. (Show c, Eq c, HasCallStack) => (a -> b) -> (d -> c) -> (a -> c) -> (b -> d) -> a -> Property+unaryConform a2b d2c f g x = ioProperty $ f x @=? d2c (g (a2b x))++binaryConform ::+  forall a b c d e f.+  (Show e, Eq e, HasCallStack) =>+  (a -> b) ->+  (c -> d) ->+  (f -> e) ->+  (a -> c -> e) ->+  (b -> d -> f) ->+  a ->+  c ->+  Property+binaryConform a2b c2d f2e f g x y = ioProperty $ f x y @=? f2e (g (a2b x) (c2d y))++wordUnaryConform :: (HasCallStack) => (WordN 8 -> WordN 8) -> (Word8 -> Word8) -> Word8 -> Assertion+wordUnaryConform f g x = unWordN (f (fromIntegral x)) @=? toInteger (g x)++wordUnaryNonNegIntConform :: (HasCallStack) => (Int -> WordN 8) -> (Int -> Word8) -> Int -> Assertion+wordUnaryNonNegIntConform f g y = when (y >= 0) $ unWordN (f y) @=? toInteger (g y)++wordBinIntConform :: (HasCallStack) => (WordN 8 -> Int -> WordN 8) -> (Word8 -> Int -> Word8) -> Word8 -> Int -> Assertion+wordBinIntConform f g x y = unWordN (f (fromIntegral x) y) @=? toInteger (g x y)++wordBinNonNegIntConform :: (HasCallStack) => (WordN 8 -> Int -> WordN 8) -> (Word8 -> Int -> Word8) -> Word8 -> Int -> Assertion+wordBinNonNegIntConform f g x y = when (y >= 0) $ unWordN (f (fromIntegral x) y) @=? toInteger (g x y)++wordBinConform :: (HasCallStack) => (WordN 8 -> WordN 8 -> WordN 8) -> (Word8 -> Word8 -> Word8) -> Word8 -> Word8 -> Assertion+wordBinConform f g x y = unWordN (f (fromIntegral x) (fromIntegral y)) @=? toInteger (g x y)++intN8eqint8 :: IntN 8 -> Int8 -> Assertion+intN8eqint8 (IntN v) i+  | v < 0 = assertFailure "Bad IntN"+  | v <= 127 = v @=? fromIntegral i+  | v == 128 = i @=? -128+  | otherwise = 256 - v @=? fromIntegral (-i)++intUnaryConform :: (IntN 8 -> IntN 8) -> (Int8 -> Int8) -> Int8 -> Assertion+intUnaryConform f g x = intN8eqint8 (f (fromIntegral x)) (g x)++intUnaryNonNegIntConform :: (Int -> IntN 8) -> (Int -> Int8) -> Int -> Assertion+intUnaryNonNegIntConform f g y = when (y >= 0) $ intN8eqint8 (f y) (g y)++intBinIntConform :: (IntN 8 -> Int -> IntN 8) -> (Int8 -> Int -> Int8) -> Int8 -> Int -> Assertion+intBinIntConform f g x y = intN8eqint8 (f (fromIntegral x) y) (g x y)++intBinNonNegIntConform :: (IntN 8 -> Int -> IntN 8) -> (Int8 -> Int -> Int8) -> Int8 -> Int -> Assertion+intBinNonNegIntConform f g x y = when (y >= 0) $ intN8eqint8 (f (fromIntegral x) y) (g x y)++intBinConform :: (IntN 8 -> IntN 8 -> IntN 8) -> (Int8 -> Int8 -> Int8) -> Int8 -> Int8 -> Assertion+intBinConform f g x y = intN8eqint8 (f (fromIntegral x) (fromIntegral y)) (g x y)++finiteBitsConformTest ::+  forall ref typ.+  ( Arbitrary ref,+    Typeable ref,+    Typeable typ,+    Show ref,+    FiniteBits ref,+    FiniteBits typ,+    Integral ref,+    Integral typ+  ) =>+  Proxy ref ->+  Proxy typ ->+  Int ->+  Test+finiteBitsConformTest pref ptyp numBits =+  testGroup+    (show (typeRep ptyp) ++ " conform to " ++ show (typeRep pref) ++ " for FiniteBits instances")+    [ testCase "finiteBitSize" $ finiteBitSize (0 :: typ) @=? numBits,+      testProperty "countLeadingZeros" $ unaryConform @ref @typ fromIntegral id countLeadingZeros countLeadingZeros,+      testProperty "countTrailingZeros" $ unaryConform @ref @typ fromIntegral id countTrailingZeros countTrailingZeros+    ]++boundedConformTest ::+  forall ref typ.+  (Typeable ref, Typeable typ, Bounded typ, Bounded ref, Integral ref, Num typ, Eq typ, Show typ) =>+  Proxy ref ->+  Proxy typ ->+  Test+boundedConformTest pref ptyp =+  testGroup+    (show (typeRep ptyp) ++ " conform to " ++ show (typeRep pref) ++ " for Bounded instances")+    [ testCase "minBound" $ (minBound :: typ) @=? fromIntegral (minBound :: ref),+      testCase "maxBound" $ (maxBound :: typ) @=? fromIntegral (maxBound :: ref)+    ]++shouldThrow :: (NFData a) => String -> a -> IO ()+shouldThrow name x = do+  errored <- catch (evaluate $ x `deepseq` True) (\(_ :: SomeException) -> return False)+  when errored $ assertFailure $ name ++ " should throw an exception"++succPredLikeTest ::+  forall a b.+  (Arbitrary a, Eq a, Eq b, Show a, Show b, NFData b) =>+  TestName ->+  String ->+  (a -> b) ->+  (a -> a) ->+  (b -> b) ->+  a ->+  b ->+  Test+succPredLikeTest name boundName a2b fa fb bounda boundb =+  testGroup+    name+    [ testProperty (name ++ " non " ++ boundName) $+        ioProperty . \(x :: a) ->+          if x == bounda then return () else a2b (fa x) @=? fb (a2b x),+      testCase (name ++ " " ++ boundName) $ shouldThrow (name ++ " " ++ boundName) $ fb boundb+    ]++enumConformTest ::+  forall ref typ.+  ( Arbitrary ref,+    Typeable ref,+    Typeable typ,+    Show ref,+    Show typ,+    NFData typ,+    Integral ref,+    Integral typ,+    Bounded ref,+    Bounded typ+  ) =>+  Proxy ref ->+  Proxy typ ->+  Test+enumConformTest pref ptyp =+  testGroup+    (show (typeRep ptyp) ++ " conform to " ++ show (typeRep pref) ++ " for Enum instances")+    [ succPredLikeTest @ref @typ "succ" "maxBound" fromIntegral succ succ maxBound maxBound,+      succPredLikeTest @ref @typ "pred" "minBound" fromIntegral pred pred minBound minBound,+      testGroup+        "toEnum"+        [ testProperty "toEnum in bounds" $+            ioProperty . \(x :: ref) ->+              toInteger (toEnum (fromIntegral x) :: ref) @=? toInteger (toEnum (fromIntegral x) :: typ),+          testCase "toEnum (fromIntegral minBound - 1)" $+            shouldThrow "toEnum (fromIntegral minBound - 1)" (toEnum (fromIntegral (minBound :: typ) - 1) :: typ),+          testCase "toEnum (fromIntegral maxBound + 1)" $+            shouldThrow "toEnum (fromIntegral maxBound + 1)" (toEnum (fromIntegral (maxBound :: typ) + 1) :: typ)+        ],+      testProperty "fromEnum" $ unaryConform @ref @typ fromIntegral id fromEnum fromEnum,+      testProperty "enumFrom" $ unaryConform @ref @typ fromIntegral (fromIntegral <$>) enumFrom enumFrom,+      testProperty "enumFromThen" $ \(x :: ref) y ->+        ioProperty $ do+          if x == y+            then return ()+            else do+              (fromIntegral <$> enumFromThen x y) @=? enumFromThen (fromIntegral x :: typ) (fromIntegral y),+      testProperty "enumFromTo" $ binaryConform @ref @typ fromIntegral fromIntegral (fromIntegral <$>) enumFromTo enumFromTo,+      testProperty "enumFromThenTo" $ \(x :: ref) y z ->+        ioProperty $+          if x == y+            then return ()+            else (fromIntegral <$> enumFromThenTo x y z) @=? enumFromThenTo (fromIntegral x :: typ) (fromIntegral y) (fromIntegral z)+    ]++newtype AEWrapper = AEWrapper ArithException deriving (Eq)++instance Show AEWrapper where+  show (AEWrapper x) = show x++instance NFData AEWrapper where+  rnf (AEWrapper x) = x `seq` ()++sameDiv :: (NFData a, NFData b, Eq b, Show b) => a -> a -> (a -> b) -> (a -> a -> a) -> (b -> b -> b) -> IO ()+sameDiv x y a2b fa fb = do+  xa <- evaluate (force $ Right $ fa x y) `catch` \(e :: ArithException) -> return $ Left $ AEWrapper e+  xb <- evaluate (force $ Right $ fb (a2b x) (a2b y)) `catch` \(e :: ArithException) -> return $ Left $ AEWrapper e+  xb @=? a2b <$> xa++sameDivMod :: (NFData a, NFData b, Eq b, Show b) => a -> a -> (a -> b) -> (a -> a -> (a, a)) -> (b -> b -> (b, b)) -> IO ()+sameDivMod x y a2b fa fb = do+  xa <- evaluate (force $ Right $ fa x y) `catch` \(e :: ArithException) -> return $ Left $ AEWrapper e+  xb <- evaluate (force $ Right $ fb (a2b x) (a2b y)) `catch` \(e :: ArithException) -> return $ Left $ AEWrapper e+  xb @=? bimap a2b a2b <$> xa++divLikeTest ::+  forall a b.+  (Arbitrary a, Eq b, Num a, Show a, Bounded a, Show b, NFData b, NFData a) =>+  TestName ->+  (a -> b) ->+  (a -> a -> a) ->+  (b -> b -> b) ->+  Test+divLikeTest name a2b fa fb =+  testGroup+    name+    [ testCase "divided by zero" $ do+        sameDiv 1 0 a2b fa fb+        sameDiv 0 0 a2b fa fb+        sameDiv (-1) 0 a2b fa fb+        sameDiv minBound 0 a2b fa fb+        sameDiv maxBound 0 a2b fa fb,+      testCase "min divided by -1" $ do+        sameDiv minBound (-1) a2b fa fb,+      testProperty "prop" $ \(x :: a) y -> ioProperty $ sameDiv x y a2b fa fb+    ]++divModLikeTest ::+  forall a b.+  (Arbitrary a, Eq b, Num a, NFData a, Show a, Bounded a, Show b, NFData b) =>+  TestName ->+  (a -> b) ->+  (a -> a -> (a, a)) ->+  (b -> b -> (b, b)) ->+  Test+divModLikeTest name a2b fa fb =+  testGroup+    name+    [ testCase "divided by zero" $ do+        sameDivMod 1 0 a2b fa fb+        sameDivMod 0 0 a2b fa fb+        sameDivMod (-1) 0 a2b fa fb+        sameDivMod minBound 0 a2b fa fb+        sameDivMod maxBound 0 a2b fa fb,+      testCase "min divided by -1" $ do+        sameDivMod minBound (-1) a2b fa fb,+      testProperty "prop" $ \(x :: a) y -> ioProperty $ sameDivMod x y a2b fa fb+    ]++realConformTest ::+  forall proxy ref typ.+  (Typeable ref, Typeable typ, Integral ref, Arbitrary ref, Real typ, Show ref) =>+  proxy ref ->+  proxy typ ->+  Test+realConformTest pref ptyp =+  testGroup+    (show (typeRep ptyp) ++ " conform to " ++ show (typeRep pref) ++ " for Real instances")+    [ testProperty "toRational" $ unaryConform @ref @typ fromIntegral id toRational toRational+    ]++integralConformTest ::+  forall ref typ.+  ( Arbitrary ref,+    Typeable ref,+    Typeable typ,+    Show ref,+    Show typ,+    Integral ref,+    Integral typ,+    Bounded ref,+    NFData typ,+    NFData ref+  ) =>+  Proxy ref ->+  Proxy typ ->+  Test+integralConformTest pref ptyp =+  testGroup+    (show (typeRep ptyp) ++ " conform to " ++ show (typeRep pref) ++ " for Integral instances")+    [ divLikeTest @ref @typ "quot" fromIntegral quot quot,+      divLikeTest @ref @typ "rem" fromIntegral rem rem,+      divModLikeTest @ref @typ "quotRem" fromIntegral quotRem quotRem,+      divLikeTest @ref @typ "div" fromIntegral div div,+      divLikeTest @ref @typ "mod" fromIntegral mod mod,+      divModLikeTest @ref @typ "divMod" fromIntegral divMod divMod,+      testProperty "toInteger" $ unaryConform @ref @typ fromIntegral id toInteger toInteger+    ]++sizedBVTests :: Test+sizedBVTests =+  testGroup+    "sizedBV"+    [ testGroup+        "WordN 8 conform to Word8 for Bits instances"+        [ testProperty "(.&.)" $ \x y -> ioProperty $ wordBinConform (.&.) (.&.) x y,+          testProperty "(.|.)" $ \x y -> ioProperty $ wordBinConform (.|.) (.|.) x y,+          testProperty "xor" $ \x y -> ioProperty $ wordBinConform xor xor x y,+          testProperty "complement" $ ioProperty . wordUnaryConform complement complement,+          testProperty "shift" $ \x y -> ioProperty $ wordBinIntConform shift shift x y,+          testProperty "rotate" $ \x y -> ioProperty $ wordBinIntConform rotate rotate x y,+          testCase "zeroBits" $ (zeroBits :: WordN 8) @=? 0,+          testProperty "bit" $ ioProperty . wordUnaryNonNegIntConform bit bit,+          testProperty "setBit" $ \x y -> ioProperty $ wordBinNonNegIntConform setBit setBit x y,+          testProperty "clearBit" $ \x y -> ioProperty $ wordBinNonNegIntConform clearBit clearBit x y,+          testProperty "complementBit" $ \x y -> ioProperty $ wordBinNonNegIntConform complementBit complementBit x y,+          testProperty "testBit" $ \(x :: Word8) i -> i < 0 || testBit x i == testBit (fromIntegral x :: WordN 8) i,+          testCase "bitSizeMaybe" $ bitSizeMaybe (0 :: WordN 8) @=? Just 8,+          testCase "isSigned" $ isSigned (0 :: WordN 8) @=? False,+          testProperty "shiftL" $ \x y -> ioProperty $ wordBinNonNegIntConform shiftL shiftL x y,+          testProperty "shiftR" $ \x y -> ioProperty $ wordBinNonNegIntConform shiftR shiftR x y,+          testProperty "rotateL" $ \x y -> ioProperty $ wordBinNonNegIntConform rotateL rotateL x y,+          testProperty "rotateR" $ \x y -> ioProperty $ wordBinNonNegIntConform rotateR rotateR x y,+          testProperty "popCount" $ ioProperty . \(x :: Word8) -> popCount x @=? popCount (fromIntegral x :: WordN 8)+        ],+      finiteBitsConformTest (Proxy @Word8) (Proxy @(WordN 8)) 8,+      boundedConformTest (Proxy @Word8) (Proxy @(WordN 8)),+      enumConformTest (Proxy @Word8) (Proxy @(WordN 8)),+      realConformTest (Proxy @Word8) (Proxy @(WordN 8)),+      integralConformTest (Proxy @Word8) (Proxy @(WordN 8)),+      testGroup+        "WordN 8 conform to Word8 for Num instances"+        [ testProperty "(+)" $ \x y -> ioProperty $ wordBinConform (+) (+) x y,+          testProperty "(*)" $ \x y -> ioProperty $ wordBinConform (*) (*) x y,+          testProperty "(-)" $ \x y -> ioProperty $ wordBinConform (-) (-) x y,+          testProperty "negate" $ ioProperty . wordUnaryConform negate negate,+          testProperty "abs" $ ioProperty . wordUnaryConform abs abs,+          testProperty "signum" $ ioProperty . wordUnaryConform signum signum,+          testProperty "fromInteger" $+            ioProperty . \(x :: Integer) ->+              unWordN (fromInteger x :: WordN 8) @=? toInteger (fromInteger x :: Word8)+        ],+      testGroup+        "WordN 8 conform to Word8 for Ord instances"+        [ testProperty "(<=)" $ \(x :: Word8) y -> ioProperty $ x <= y @=? (fromIntegral x :: WordN 8) <= (fromIntegral y :: WordN 8)+        ],+      testGroup+        "IntN 8 conform to Int8 for Bits instances"+        [ testProperty "(.&.)" $ \x y -> ioProperty $ intBinConform (.&.) (.&.) x y,+          testProperty "(.|.)" $ \x y -> ioProperty $ intBinConform (.|.) (.|.) x y,+          testProperty "xor" $ \x y -> ioProperty $ intBinConform xor xor x y,+          testProperty "complement" $ ioProperty . intUnaryConform complement complement,+          testProperty "shift" $ \x y -> ioProperty $ intBinIntConform shift shift x y,+          testProperty "rotate" $ \x y -> ioProperty $ intBinIntConform rotate rotate x y,+          testCase "zeroBits" $ (zeroBits :: IntN 8) @=? 0,+          testProperty "bit" $ ioProperty . intUnaryNonNegIntConform bit bit,+          testProperty "setBit" $ \x y -> ioProperty $ intBinNonNegIntConform setBit setBit x y,+          testProperty "clearBit" $ \x y -> ioProperty $ intBinNonNegIntConform clearBit clearBit x y,+          testProperty "complementBit" $ \x y -> ioProperty $ intBinNonNegIntConform complementBit complementBit x y,+          testProperty "testBit" $ \(x :: Int8) i -> i < 0 || testBit x i == testBit (fromIntegral x :: IntN 8) i,+          testCase "bitSizeMaybe" $ bitSizeMaybe (0 :: IntN 8) @=? Just 8,+          testCase "isSigned" $ isSigned (0 :: IntN 8) @=? True,+          testProperty "shiftL" $ \x y -> ioProperty $ intBinNonNegIntConform shiftL shiftL x y,+          testProperty "shiftR" $ \x y -> ioProperty $ intBinNonNegIntConform shiftR shiftR x y,+          testProperty "rotateL" $ \x y -> ioProperty $ intBinNonNegIntConform rotateL rotateL x y,+          testProperty "rotateR" $ \x y -> ioProperty $ intBinNonNegIntConform rotateR rotateR x y,+          testProperty "popCount" $ ioProperty . \(x :: Int8) -> popCount x @=? popCount (fromIntegral x :: IntN 8)+        ],+      finiteBitsConformTest (Proxy @Int8) (Proxy @(IntN 8)) 8,+      boundedConformTest (Proxy @Int8) (Proxy @(IntN 8)),+      enumConformTest (Proxy @Int8) (Proxy @(IntN 8)),+      realConformTest (Proxy @Int8) (Proxy @(IntN 8)),+      integralConformTest (Proxy @Int8) (Proxy @(IntN 8)),+      testGroup+        "IntN 8 conform to Int8 for Num instances"+        [ testProperty "(+)" $ \x y -> ioProperty $ intBinConform (+) (+) x y,+          testProperty "(*)" $ \x y -> ioProperty $ intBinConform (*) (*) x y,+          testProperty "(-)" $ \x y -> ioProperty $ intBinConform (-) (-) x y,+          testProperty "negate" $ ioProperty . wordUnaryConform negate negate,+          testProperty "abs" $ ioProperty . wordUnaryConform abs abs,+          testProperty "signum" $ ioProperty . wordUnaryConform signum signum,+          testProperty "fromInteger" $+            ioProperty . \(x :: Integer) ->+              intN8eqint8 (fromInteger x :: IntN 8) (fromInteger x :: Int8)+        ],+      testGroup+        "IntN 8 conform to IntN for Ord instances"+        [ testProperty "(<=)" $ \(x :: Int8) y -> ioProperty $ (fromIntegral x :: IntN 8) <= (fromIntegral y :: IntN 8) @=? x <= y+        ],+      testGroup+        "WordN bvops"+        [ testProperty "sizedBVConcat" $ \(x :: Integer) (y :: Integer) ->+            ioProperty $+              sizedBVConcat (fromInteger x :: WordN 5) (fromInteger y :: WordN 7) @=? fromInteger (x * 128 + y `mod` 128),+          testProperty "sizedBVZext" $ ioProperty . \(x :: Integer) -> sizedBVZext (Proxy :: Proxy 12) (fromInteger x :: WordN 7) @=? fromInteger (x `mod` 128),+          testCase "sizedBVSext" $ do+            sizedBVSext (Proxy :: Proxy 12) (0 :: WordN 8) @=? 0+            sizedBVSext (Proxy :: Proxy 12) (1 :: WordN 8) @=? 1+            sizedBVSext (Proxy :: Proxy 12) (127 :: WordN 8) @=? 127+            sizedBVSext (Proxy :: Proxy 12) (128 :: WordN 8) @=? 3968+            sizedBVSext (Proxy :: Proxy 12) (255 :: WordN 8) @=? 4095,+          testProperty "sizedBVExt is sizedBVZext" $+            ioProperty . \(x :: Integer) ->+              sizedBVExt (Proxy :: Proxy 12) (fromInteger x :: WordN 8) @=? sizedBVZext (Proxy :: Proxy 12) (fromInteger x :: WordN 8),+          testCase "sizedBVSelect" $ do+            sizedBVSelect (Proxy :: Proxy 3) (Proxy :: Proxy 3) (0b11100 :: WordN 8) @=? 0b11+            sizedBVSelect (Proxy :: Proxy 3) (Proxy :: Proxy 3) (0b111000 :: WordN 8) @=? 0b111+            sizedBVSelect (Proxy :: Proxy 3) (Proxy :: Proxy 3) (0b101000 :: WordN 8) @=? 0b101+            sizedBVSelect (Proxy :: Proxy 3) (Proxy :: Proxy 3) (0b1010000 :: WordN 8) @=? 0b10+        ],+      testGroup+        "IntN bvops"+        [ testProperty "sizedBVConcat" $ \(x :: Integer) (y :: Integer) ->+            ioProperty $+              sizedBVConcat (fromInteger x :: IntN 5) (fromInteger y :: IntN 7) @=? fromInteger (x * 128 + y `mod` 128),+          testProperty "sizedBVZext" $ ioProperty . \(x :: Integer) -> sizedBVZext (Proxy :: Proxy 12) (fromInteger x :: IntN 7) @=? fromInteger (x `mod` 128),+          testCase "sizedBVSext" $ do+            sizedBVSext (Proxy :: Proxy 12) (0 :: WordN 8) @=? 0+            sizedBVSext (Proxy :: Proxy 12) (1 :: WordN 8) @=? 1+            sizedBVSext (Proxy :: Proxy 12) (127 :: WordN 8) @=? 127+            sizedBVSext (Proxy :: Proxy 12) (128 :: WordN 8) @=? 3968+            sizedBVSext (Proxy :: Proxy 12) (255 :: WordN 8) @=? 4095,+          testProperty "sizedBVExt is sizedBVSext" $+            ioProperty . \(x :: Integer) ->+              sizedBVExt (Proxy :: Proxy 12) (fromInteger x :: IntN 8) @=? sizedBVSext (Proxy :: Proxy 12) (fromInteger x :: IntN 8),+          testCase "sizedBVSelect" $ do+            sizedBVSelect (Proxy :: Proxy 3) (Proxy :: Proxy 3) (0b11100 :: IntN 8) @=? 0b11+            sizedBVSelect (Proxy :: Proxy 3) (Proxy :: Proxy 3) (0b111000 :: IntN 8) @=? 0b111+            sizedBVSelect (Proxy :: Proxy 3) (Proxy :: Proxy 3) (0b101000 :: IntN 8) @=? 0b101+            sizedBVSelect (Proxy :: Proxy 3) (Proxy :: Proxy 3) (0b1010000 :: IntN 8) @=? 0b10+        ],+      testGroup+        "read"+        [ testProperty "read . show" $ \(x :: IntN 8) -> read (show x) == x,+          testProperty "read . show" $ \(x :: WordN 8) -> read (show x) == x,+          testProperty "read . show" $ \(x :: IntN 9) -> read (show x) == x,+          testProperty "read . show" $ \(x :: WordN 9) -> read (show x) == x+        ],+      testGroup+        "Regression"+        [ testCase "division of min bound and minus one for signed bit vector should throw" $ do+            shouldThrow "divMod" $ divMod (minBound :: IntN 8) (-1 :: IntN 8)+            shouldThrow "div" $ div (minBound :: IntN 8) (-1 :: IntN 8)+            shouldThrow "quotRem" $ quotRem (minBound :: IntN 8) (-1 :: IntN 8)+            shouldThrow "quot" $ quot (minBound :: IntN 8) (-1 :: IntN 8),+          testCase "toInteger for IntN 1" $ do+            toInteger (0 :: IntN 1) @=? 0+            toInteger (1 :: IntN 1) @=? (-1),+          testProperty "WordN shiftL by large amount" $ \(x :: WordN 128) ->+            ioProperty $ shiftL x maxBound @=? 0,+          testProperty "IntN shiftL by large amount" $ \(x :: IntN 128) ->+            ioProperty $ shiftL x maxBound @=? 0+        ],+      testGroup+        "Serialize"+        [ testProperty "WordN 8" $+            \(x :: WordN 8) -> Right x == (decode . encode) x,+          testProperty "IntN 8" $+            \(x :: IntN 8) -> Right x == (decode . encode) x+        ]+    ]++someWordNTests :: Test+someWordNTests =+  testGroup+    "SomeWordN"+    [ testGroup+        "BV"+        [ testGroup+            "bv"+            [ testCase "bv 12 21" $+                (bv 12 21 :: SomeWordN) @?= SomeWordN (0x015 :: WordN 12)+            ]+        ]+    ]++someIntNTests :: Test+someIntNTests =+  testGroup+    "SomeIntN"+    [ testGroup+        "BV"+        [ testGroup+            "bv"+            [ testCase "bv 12 21" $+                (bv 12 21 :: SomeIntN) @?= SomeIntN (0x015 :: IntN 12)+            ]+        ]+    ]++bvTests :: Test+bvTests = testGroup "BV" [sizedBVTests, someWordNTests, someIntNTests]
+ test/Grisette/SymPrim/FPTests.hs view

file too large to diff

+ test/Grisette/SymPrim/GeneralFunTests.hs view

file too large to diff

+ test/Grisette/SymPrim/Prim/BVTests.hs view

file too large to diff

+ test/Grisette/SymPrim/Prim/BitsTests.hs view

file too large to diff

+ test/Grisette/SymPrim/Prim/BoolTests.hs view

file too large to diff

+ test/Grisette/SymPrim/Prim/ConcurrentTests.hs view

file too large to diff

+ test/Grisette/SymPrim/Prim/IntegralTests.hs view

file too large to diff

+ test/Grisette/SymPrim/Prim/ModelTests.hs view

file too large to diff

+ test/Grisette/SymPrim/Prim/NumTests.hs view

file too large to diff

+ test/Grisette/SymPrim/Prim/SerializationTests.hs view

file too large to diff

+ test/Grisette/SymPrim/Prim/TabularFunTests.hs view

file too large to diff

+ test/Grisette/SymPrim/QuantifierTests.hs view

file too large to diff

+ test/Grisette/SymPrim/SomeBVTests.hs view

file too large to diff

+ test/Grisette/SymPrim/SymGeneralFunTests.hs view

file too large to diff

+ test/Grisette/SymPrim/SymPrimConstraintTests.hs view

file too large to diff

+ test/Grisette/SymPrim/SymPrimTests.hs view

file too large to diff

+ test/Grisette/SymPrim/TabularFunTests.hs view

file too large to diff

+ test/Grisette/TestUtil/NoMerge.hs view

file too large to diff

+ test/Grisette/TestUtil/PrettyPrint.hs view

file too large to diff

test/Grisette/TestUtil/SymbolicAssertion.hs view

file too large to diff

+ test/Grisette/Unified/EvalModeTest.hs view

file too large to diff

+ test/Grisette/Unified/GetDataTest.hs view

file too large to diff

+ test/Grisette/Unified/UnifiedClassesTest.hs view

file too large to diff

+ test/Grisette/Unified/UnifiedConstructorTest.hs view

file too large to diff

test/Main.hs view

file too large to diff