grisette 0.11.0.0 → 0.12.0.0

raw patch · 146 files changed

+17009/−14136 lines, 146 filesdep ~containersdep ~doctestdep ~hashablePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: containers, doctest, hashable, parallel, transformers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +165/−110
• README.md +31/−23
• grisette.cabal +82/−74
• src/Grisette/Core.hs +8/−4
• src/Grisette/Internal/Backend/Solving.hs +155/−159
• src/Grisette/Internal/Backend/SymBiMap.hs +8/−6
• src/Grisette/Internal/Core/Control/Monad/CBMCExcept.hs +2/−4
• src/Grisette/Internal/Core/Data/Class/GenSym.hs +63/−45
• src/Grisette/Internal/Core/Data/Class/SymFiniteBits.hs +33/−13
• src/Grisette/Internal/Core/Data/Symbol.hs +26/−4
• src/Grisette/Internal/Internal/Decl/Core/Control/Monad/Union.hs +4/−2
• src/Grisette/Internal/Internal/Decl/Core/Data/Class/Mergeable.hs +3/−0
• src/Grisette/Internal/Internal/Decl/Core/Data/Class/SimpleMergeable.hs +7/−2
• src/Grisette/Internal/Internal/Decl/Core/Data/Class/SymEq.hs +1/−1
• src/Grisette/Internal/Internal/Impl/Core/Control/Monad/Union.hs +1/−1
• src/Grisette/Internal/Internal/Impl/Core/Data/Class/EvalSym.hs +4/−4
• src/Grisette/Internal/Internal/Impl/Core/Data/Class/ExtractSym.hs +4/−4
• src/Grisette/Internal/Internal/Impl/Core/Data/Class/Mergeable.hs +5/−5
• src/Grisette/Internal/Internal/Impl/Core/Data/Class/PPrint.hs +12/−5
• src/Grisette/Internal/Internal/Impl/Core/Data/Class/SimpleMergeable.hs +36/−21
• src/Grisette/Internal/Internal/Impl/Core/Data/Class/Solver.hs +2/−2
• src/Grisette/Internal/Internal/Impl/Core/Data/Class/SubstSym.hs +4/−4
• src/Grisette/Internal/Internal/Impl/Core/Data/Class/SymEq.hs +4/−4
• src/Grisette/Internal/Internal/Impl/Core/Data/Class/SymOrd.hs +4/−4
• src/Grisette/Internal/Internal/Impl/Core/Data/Class/ToCon.hs +4/−4
• src/Grisette/Internal/Internal/Impl/Core/Data/Class/ToSym.hs +4/−4
• src/Grisette/Internal/Internal/Impl/SymPrim/AllSyms.hs +4/−4
• src/Grisette/Internal/Internal/Impl/Unified/Class/UnifiedSimpleMergeable.hs +4/−4
• src/Grisette/Internal/Internal/Impl/Unified/Class/UnifiedSymEq.hs +9/−9
• src/Grisette/Internal/Internal/Impl/Unified/Class/UnifiedSymOrd.hs +9/−9
• src/Grisette/Internal/SymPrim/FunInstanceGen.hs +3/−14
• src/Grisette/Internal/SymPrim/GeneralFun.hs +124/−197
• src/Grisette/Internal/SymPrim/ModelRep.hs +3/−2
• src/Grisette/Internal/SymPrim/Prim/Internal/Caches.hs +47/−57
• src/Grisette/Internal/SymPrim/Prim/Internal/Instances/BVPEval.hs +0/−601
• src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalBitCastTerm.hs +10/−10
• src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalBitwiseTerm.hs +0/−118
• src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalDivModIntegralTerm.hs +34/−36
• src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalFP.hs +131/−230
• src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalFloatingTerm.hs +0/−1
• src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalFractionalTerm.hs +11/−12
• src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalFromIntegralTerm.hs +5/−5
• src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalIEEEFPConvertibleTerm.hs +11/−11
• src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalNumTerm.hs +7/−205
• src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalOrdTerm.hs +22/−19
• src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalRotateTerm.hs +23/−23
• src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalShiftTerm.hs +139/−49
• src/Grisette/Internal/SymPrim/Prim/Internal/Instances/SupportedPrim.hs +0/−413
• src/Grisette/Internal/SymPrim/Prim/Internal/Serialize.hs +133/−142
• src/Grisette/Internal/SymPrim/Prim/Internal/Term.hs +8407/−5550
• src/Grisette/Internal/SymPrim/Prim/Internal/Unfold.hs +13/−10
• src/Grisette/Internal/SymPrim/Prim/Model.hs +20/−22
• src/Grisette/Internal/SymPrim/Prim/Pattern.hs +132/−0
• src/Grisette/Internal/SymPrim/Prim/SomeTerm.hs +6/−8
• src/Grisette/Internal/SymPrim/Prim/Term.hs +2/−7
• src/Grisette/Internal/SymPrim/Prim/TermUtils.hs +20/−234
• src/Grisette/Internal/SymPrim/SomeBV.hs +7/−2
• src/Grisette/Internal/SymPrim/SymAlgReal.hs +4/−2
• src/Grisette/Internal/SymPrim/SymBV.hs +3/−2
• src/Grisette/Internal/SymPrim/SymBool.hs +4/−2
• src/Grisette/Internal/SymPrim/SymFP.hs +14/−11
• src/Grisette/Internal/SymPrim/SymGeneralFun.hs +4/−2
• src/Grisette/Internal/SymPrim/SymInteger.hs +4/−2
• src/Grisette/Internal/SymPrim/SymPrim.hs +8/−3
• src/Grisette/Internal/SymPrim/SymTabularFun.hs +4/−2
• src/Grisette/Internal/SymPrim/TabularFun.hs +8/−3
• src/Grisette/Internal/TH/Ctor/UnifiedConstructor.hs +1/−1
• src/Grisette/Internal/TH/Derivation/BinaryOpCommon.hs +389/−0
• src/Grisette/Internal/TH/Derivation/Common.hs +465/−0
• src/Grisette/Internal/TH/Derivation/ConvertOpCommon.hs +453/−0
• src/Grisette/Internal/TH/Derivation/Derive.hs +968/−0
• src/Grisette/Internal/TH/Derivation/DeriveAllSyms.hs +90/−0
• src/Grisette/Internal/TH/Derivation/DeriveBinary.hs +48/−0
• src/Grisette/Internal/TH/Derivation/DeriveCereal.hs +48/−0
• src/Grisette/Internal/TH/Derivation/DeriveEq.hs +79/−0
• src/Grisette/Internal/TH/Derivation/DeriveEvalSym.hs +96/−0
• src/Grisette/Internal/TH/Derivation/DeriveExtractSym.hs +101/−0
• src/Grisette/Internal/TH/Derivation/DeriveHashable.hs +92/−0
• src/Grisette/Internal/TH/Derivation/DeriveMergeable.hs +857/−0
• src/Grisette/Internal/TH/Derivation/DeriveNFData.hs +84/−0
• src/Grisette/Internal/TH/Derivation/DeriveOrd.hs +78/−0
• src/Grisette/Internal/TH/Derivation/DerivePPrint.hs +211/−0
• src/Grisette/Internal/TH/Derivation/DeriveSerial.hs +53/−0
• src/Grisette/Internal/TH/Derivation/DeriveShow.hs +197/−0
• src/Grisette/Internal/TH/Derivation/DeriveSimpleMergeable.hs +87/−0
• src/Grisette/Internal/TH/Derivation/DeriveSubstSym.hs +89/−0
• src/Grisette/Internal/TH/Derivation/DeriveSymEq.hs +85/−0
• src/Grisette/Internal/TH/Derivation/DeriveSymOrd.hs +99/−0
• src/Grisette/Internal/TH/Derivation/DeriveToCon.hs +67/−0
• src/Grisette/Internal/TH/Derivation/DeriveToSym.hs +67/−0
• src/Grisette/Internal/TH/Derivation/DeriveUnifiedSimpleMergeable.hs +114/−0
• src/Grisette/Internal/TH/Derivation/DeriveUnifiedSymEq.hs +104/−0
• src/Grisette/Internal/TH/Derivation/DeriveUnifiedSymOrd.hs +104/−0
• src/Grisette/Internal/TH/Derivation/SerializeCommon.hs +243/−0
• src/Grisette/Internal/TH/Derivation/ShowPPrintCommon.hs +57/−0
• src/Grisette/Internal/TH/Derivation/UnaryOpCommon.hs +400/−0
• src/Grisette/Internal/TH/Derivation/UnifiedOpCommon.hs +107/−0
• src/Grisette/Internal/TH/GADT/BinaryOpCommon.hs +0/−377
• src/Grisette/Internal/TH/GADT/Common.hs +0/−452
• src/Grisette/Internal/TH/GADT/ConvertOpCommon.hs +0/−469
• src/Grisette/Internal/TH/GADT/DeriveAllSyms.hs +0/−88
• src/Grisette/Internal/TH/GADT/DeriveEq.hs +0/−79
• src/Grisette/Internal/TH/GADT/DeriveEvalSym.hs +0/−94
• src/Grisette/Internal/TH/GADT/DeriveExtractSym.hs +0/−99
• src/Grisette/Internal/TH/GADT/DeriveGADT.hs +0/−735
• src/Grisette/Internal/TH/GADT/DeriveHashable.hs +0/−90
• src/Grisette/Internal/TH/GADT/DeriveMergeable.hs +0/−792
• src/Grisette/Internal/TH/GADT/DeriveNFData.hs +0/−82
• src/Grisette/Internal/TH/GADT/DeriveOrd.hs +0/−78
• src/Grisette/Internal/TH/GADT/DerivePPrint.hs +0/−195
• src/Grisette/Internal/TH/GADT/DeriveSerial.hs +0/−203
• src/Grisette/Internal/TH/GADT/DeriveShow.hs +0/−195
• src/Grisette/Internal/TH/GADT/DeriveSimpleMergeable.hs +0/−87
• src/Grisette/Internal/TH/GADT/DeriveSubstSym.hs +0/−87
• src/Grisette/Internal/TH/GADT/DeriveSymEq.hs +0/−85
• src/Grisette/Internal/TH/GADT/DeriveSymOrd.hs +0/−99
• src/Grisette/Internal/TH/GADT/DeriveToCon.hs +0/−67
• src/Grisette/Internal/TH/GADT/DeriveToSym.hs +0/−67
• src/Grisette/Internal/TH/GADT/DeriveUnifiedSimpleMergeable.hs +0/−112
• src/Grisette/Internal/TH/GADT/DeriveUnifiedSymEq.hs +0/−102
• src/Grisette/Internal/TH/GADT/DeriveUnifiedSymOrd.hs +0/−102
• src/Grisette/Internal/TH/GADT/ShowPPrintCommon.hs +0/−57
• src/Grisette/Internal/TH/GADT/UnaryOpCommon.hs +0/−371
• src/Grisette/Internal/TH/GADT/UnifiedOpCommon.hs +0/−107
• src/Grisette/Internal/Unified/Class/UnifiedFiniteBits.hs +3/−3
• src/Grisette/Internal/Unified/Util.hs +6/−0
• src/Grisette/SymPrim.hs +124/−2
• src/Grisette/TH.hs +59/−12
• test/Grisette/Backend/LoweringTests.hs +2/−2
• test/Grisette/Backend/TermRewritingGen.hs +8/−1
• test/Grisette/Backend/TermRewritingTests.hs +483/−26
• test/Grisette/Core/Data/Class/PPrintTests.hs +18/−36
• test/Grisette/Core/Data/Class/TryMergeTests.hs +1/−1
• test/Grisette/Core/TH/DerivationData.hs +57/−17
• test/Grisette/Core/TH/DerivationTest.hs +10/−1
• test/Grisette/Lib/Control/Monad/Trans/State/Common.hs +1/−2
• test/Grisette/Lib/Data/FoldableTests.hs +2/−2
• test/Grisette/Lib/Data/ListTests.hs +1/−2
• test/Grisette/Lib/Data/TraversableTests.hs +3/−3
• test/Grisette/SymPrim/FPTests.hs +7/−7
• test/Grisette/SymPrim/Prim/BVTests.hs +10/−15
• test/Grisette/SymPrim/Prim/BitsTests.hs +112/−79
• test/Grisette/SymPrim/SomeBVTests.hs +2/−2
• test/Grisette/SymPrim/SymPrimConstraintTests.hs +97/−0
• test/Grisette/Unified/UnifiedClassesTest.hs +3/−3
• test/Grisette/Unified/UnifiedConstructorTest.hs +6/−6

@@ -3,12 +3,58 @@ 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.11.0.0] - 2024-12-29+## [Unreleased] +## [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@@ -16,14 +62,16 @@   ([#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`.++- \[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`.+- \[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.@@ -32,10 +80,11 @@   ([#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+## [0.10.0.0] -- 2024-12-11  ### Added @@ -49,18 +98,20 @@   ([#265](https://github.com/lsrcz/grisette/pull/265))  ### Changed-- [Breaking] Improved the `SymFiniteBits` interface.++- \[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`,+- \[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`.+- \[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+## [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.@@ -75,24 +126,25 @@   ([#254](https://github.com/lsrcz/grisette/pull/254))  ### Changed-- [Breaking] Moved the constraints for the general and tabular functions and++- \[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))+- \[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+- \[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.+- \[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.@@ -106,19 +158,20 @@   intermediate states are not properly memoized.   ([#259](https://github.com/lsrcz/grisette/pull/259)) -## [0.8.0.0] - 2024-08-13+## [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))+  [#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))+  [#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))@@ -130,37 +183,36 @@   ([#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))+  `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))+- 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++- \[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`.+- \[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+- \[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.@@ -170,28 +222,28 @@   ([#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+## [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 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`.@@ -200,41 +252,42 @@   ([#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++- \[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.+  [#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+  [#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+- \[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+  [#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`.+- \[Breaking\] Renamed `SEq` to `SymEq`. Renamed `SOrd` to `SymOrd`.   ([#217](https://github.com/lsrcz/grisette/pull/217))-- [Breaking] Renamed `GPretty` to `PPrint`.+- \[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))+  [#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 @@ -262,14 +315,14 @@  ### Changed -- [Breaking] Equality test for `SomeBV` with different bit widths will now+- \[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.+- \[Breaking\] More intuitive CEGIS interface.   ([#201](https://github.com/lsrcz/grisette/pull/201))-- [Breaking] Changed the low-level solver interface.+- \[Breaking\] Changed the low-level solver interface.   ([#206](https://github.com/lsrcz/grisette/pull/206))-- [Breaking] Changed the CEGIS interface.+- \[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))@@ -317,32 +370,32 @@  ### Changed -- [Breaking] Removed the `UnionLike` and `UnionPrjOp` interface, added the+- \[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`.+- \[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.+- \[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+- \[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+- \[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.+- \[Breaking\] Refactored the `mrg*` constructor related template haskell code.   ([#185](https://github.com/lsrcz/grisette/pull/185))-- [Breaking] Dropped symbols with extra information.+- \[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))+- \[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.+- \[Breaking\] Refactored the project structures.   ([#194](https://github.com/lsrcz/grisette/pull/194))  ## [0.4.1.0] -- 2024-01-10@@ -383,11 +436,11 @@  ### Removed -- [Breaking] Removed the `Grisette.Lib.Mtl` module.+- \[Breaking\] Removed the `Grisette.Lib.Mtl` module.   ([#132](https://github.com/lsrcz/grisette/pull/132))-- [Breaking] Removed `SymBoolOp` and `SymIntegerOp`.+- \[Breaking\] Removed `SymBoolOp` and `SymIntegerOp`.   ([#146](https://github.com/lsrcz/grisette/pull/146))-- [Breaking] Removed `ExtractSymbolics` instance for `SymbolSet`.+- \[Breaking\] Removed `ExtractSymbolics` instance for `SymbolSet`.   ([#146](https://github.com/lsrcz/grisette/pull/146))  ### Fixed@@ -413,33 +466,33 @@  - Reorganized the files for `MonadTrans`.   ([#132](https://github.com/lsrcz/grisette/pull/132))-- [Breaking] Changed the name of `Union` constructors and patterns.+- \[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+- \[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+- \[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+- \[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+- \[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`.+- \[Breaking\] Changed the API to `MonadFresh`.   ([#156](https://github.com/lsrcz/grisette/pull/156))-- [Breaking] Renamed multiple symbolic operators.+- \[Breaking\] Renamed multiple symbolic operators.   ([#158](https://github.com/lsrcz/grisette/pull/158))-- [Breaking] Changed the solver interface.+- \[Breaking\] Changed the solver interface.   ([#159](https://github.com/lsrcz/grisette/pull/159))-- [Breaking] Changed the CEGIS solver interface.+- \[Breaking\] Changed the CEGIS solver interface.   ([#159](https://github.com/lsrcz/grisette/pull/159))  ## [0.3.1.1] -- 2023-09-29@@ -498,7 +551,7 @@ - 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 @@ -543,24 +596,26 @@ - 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.11.0.0]: https://github.com/lsrcz/grisette/compare/v0.10.0.0...HEAD+[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.9.0.0]: https://github.com/lsrcz/grisette/compare/v0.8.0.0...v0.9.0.0-[0.8.0.0]: https://github.com/lsrcz/grisette/compare/v0.7.0.0...v0.8.0.0-[0.7.0.0]: https://github.com/lsrcz/grisette/compare/v0.6.0.0...v0.7.0.0-[0.6.0.0]: https://github.com/lsrcz/grisette/compare/v0.5.0.1...v0.6.0.0-[0.5.0.1]: https://github.com/lsrcz/grisette/compare/v0.5.0.0...v0.5.0.1-[0.5.0.0]: https://github.com/lsrcz/grisette/compare/v0.4.1.0...v0.5.0.0-[0.4.1.0]: https://github.com/lsrcz/grisette/compare/v0.4.0.0...v0.4.1.0-[0.4.0.0]: https://github.com/lsrcz/grisette/compare/v0.3.1.1...v0.4.0.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.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.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.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+[unreleased]: https://github.com/lsrcz/grisette/compare/v0.12.0.0...HEAD

@@ -3,9 +3,9 @@ [![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 SMT 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).@@ -48,7 +48,7 @@ ```cabal library   ...-  build-depends: grisette >= 0.11 < 0.12+  build-depends: grisette >= 0.12 < 0.13 ```  #### Using stack@@ -59,14 +59,14 @@  ```yaml extra-deps:-  - grisette-0.11.0.0+  - grisette-0.12.0.0 ```  and in your `package.yaml` file:  ```yaml dependencies:-  - grisette >= 0.11 < 0.12+  - grisette >= 0.12 < 0.13 ```  #### Quick start template with `stack new`@@ -78,7 +78,8 @@ ```  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:@@ -131,11 +132,12 @@ for boolean and integer expressions.  We will+ - 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.+- build a *synthesizer* to find an arithmetic expression that is equivalent to a+  given expression.  ### Defining the Syntax @@ -203,9 +205,9 @@ ```  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`.+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 add2 = add (intVal "a") (intVal 2)@@ -215,6 +217,7 @@ ```  ### 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@@ -242,6 +245,7 @@ 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.@@ -264,12 +268,13 @@ different values. The counter-example is $a=0$, $b=1$, such that $a+b=1$ and $a+a=0$. -``` haskell+```haskell > solve z3 $ eval aPlusB ./= eval aPlusA Right (Model {a -> 0 :: Integer, b -> 1 :: Integer}) ```  ### Get a synthesizer+ 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.@@ -292,9 +297,11 @@  ## Documentation -- Haddock documentation at [grisette](https://hackage.haskell.org/package/grisette).+- 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.+  provided as jupyter notebooks with the+  [IHaskell](https://github.com/IHaskell/IHaskell) kernel.  ## License @@ -307,31 +314,32 @@ 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).+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+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 +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)+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

@@ -4,34 +4,34 @@ -- -- see: https://github.com/sol/hpack -name:           grisette-version:        0.11.0.0-synopsis:       Symbolic evaluation as a library-description:    Grisette is a reusable symbolic evaluation library for Haskell. By-                translating programs into constraints, Grisette can help the development of-                program reasoning tools, including verification, synthesis, and more.-                .-                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.-                .-                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-author:         Sirui Lu, Rastislav Bodík-maintainer:     Sirui Lu (siruilu@cs.washington.edu)-copyright:      2021-2024 Sirui Lu-license:        BSD3-license-file:   LICENSE-build-type:     Simple+name:               grisette+version:            0.12.0.0+synopsis:           Symbolic evaluation as a library+description:        Grisette is a reusable symbolic evaluation library for Haskell. By+                    translating programs into constraints, Grisette can help the development of+                    program reasoning tools, including verification, synthesis, and more.+                    .+                    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.+                    .+                    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+author:             Sirui Lu, Rastislav Bodík+maintainer:         Sirui Lu (siruilu@cs.washington.edu)+copyright:          2021-2024 Sirui Lu+license:            BSD3+license-file:       LICENSE+build-type:         Simple tested-with:     GHC == 8.10.7   , GHC == 9.0.2@@ -121,9 +121,7 @@       Grisette.Internal.SymPrim.IntBitwidth       Grisette.Internal.SymPrim.ModelRep       Grisette.Internal.SymPrim.Prim.Internal.Caches-      Grisette.Internal.SymPrim.Prim.Internal.Instances.BVPEval       Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalBitCastTerm-      Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalBitwiseTerm       Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalDivModIntegralTerm       Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalFloatingTerm       Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalFP@@ -134,13 +132,13 @@       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.Instances.SupportedPrim       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@@ -158,33 +156,36 @@       Grisette.Internal.TH.Ctor.Common       Grisette.Internal.TH.Ctor.SmartConstructor       Grisette.Internal.TH.Ctor.UnifiedConstructor-      Grisette.Internal.TH.GADT.BinaryOpCommon-      Grisette.Internal.TH.GADT.Common-      Grisette.Internal.TH.GADT.ConvertOpCommon-      Grisette.Internal.TH.GADT.DeriveAllSyms-      Grisette.Internal.TH.GADT.DeriveEq-      Grisette.Internal.TH.GADT.DeriveEvalSym-      Grisette.Internal.TH.GADT.DeriveExtractSym-      Grisette.Internal.TH.GADT.DeriveGADT-      Grisette.Internal.TH.GADT.DeriveHashable-      Grisette.Internal.TH.GADT.DeriveMergeable-      Grisette.Internal.TH.GADT.DeriveNFData-      Grisette.Internal.TH.GADT.DeriveOrd-      Grisette.Internal.TH.GADT.DerivePPrint-      Grisette.Internal.TH.GADT.DeriveSerial-      Grisette.Internal.TH.GADT.DeriveShow-      Grisette.Internal.TH.GADT.DeriveSimpleMergeable-      Grisette.Internal.TH.GADT.DeriveSubstSym-      Grisette.Internal.TH.GADT.DeriveSymEq-      Grisette.Internal.TH.GADT.DeriveSymOrd-      Grisette.Internal.TH.GADT.DeriveToCon-      Grisette.Internal.TH.GADT.DeriveToSym-      Grisette.Internal.TH.GADT.DeriveUnifiedSimpleMergeable-      Grisette.Internal.TH.GADT.DeriveUnifiedSymEq-      Grisette.Internal.TH.GADT.DeriveUnifiedSymOrd-      Grisette.Internal.TH.GADT.ShowPPrintCommon-      Grisette.Internal.TH.GADT.UnaryOpCommon-      Grisette.Internal.TH.GADT.UnifiedOpCommon+      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.BaseMonad@@ -305,7 +306,6 @@   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 -Wno-x-partial -Wno-unrecognised-warning-flags-  ghc-prof-options: -finfo-table-map -fdistinct-constructor-tables   build-depends:       QuickCheck >=2.14 && <2.16     , array >=0.5.4 && <0.6@@ -317,14 +317,14 @@     , bytestring >=0.10.12 && <0.13     , cereal >=0.5.8.1 && <0.6     , cereal-text >=0.1.0.2 && <0.2-    , containers >=0.4 && <0.8+    , containers >=0.5.7 && <0.9     , deepseq >=1.4.4 && <1.6     , generic-deriving >=1.14.1 && <1.15-    , hashable >=1.2.5 && <1.6+    , 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.17 && <12     , stm ==2.5.*@@ -333,7 +333,7 @@     , th-abstraction >=0.4 && <0.8     , th-compat >=0.1.2 && <0.2     , th-lift-instances >=0.1.16 && <0.2-    , transformers >=0.5.6 && <0.7+    , transformers >=0.5.6.2 && <0.7     , unordered-containers >=0.2.17 && <0.3     , vector >=0.12.1.2 && <0.14   default-language: Haskell2010@@ -341,6 +341,9 @@     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@@ -350,7 +353,6 @@   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 -Wno-x-partial -Wno-unrecognised-warning-flags -threaded -rtsopts -with-rtsopts=-N-  ghc-prof-options: -finfo-table-map -fdistinct-constructor-tables   build-depends:       QuickCheck >=2.14 && <2.16     , array >=0.5.4 && <0.6@@ -362,16 +364,16 @@     , bytestring >=0.10.12 && <0.13     , cereal >=0.5.8.1 && <0.6     , cereal-text >=0.1.0.2 && <0.2-    , containers >=0.4 && <0.8+    , containers >=0.5.7 && <0.9     , deepseq >=1.4.4 && <1.6-    , doctest >=0.18.2 && <0.24+    , doctest >=0.18.2 && <0.25     , generic-deriving >=1.14.1 && <1.15     , grisette-    , hashable >=1.2.5 && <1.6+    , 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.17 && <12     , stm ==2.5.*@@ -380,7 +382,7 @@     , th-abstraction >=0.4 && <0.8     , th-compat >=0.1.2 && <0.2     , th-lift-instances >=0.1.16 && <0.2-    , transformers >=0.5.6 && <0.7+    , transformers >=0.5.6.2 && <0.7     , unordered-containers >=0.2.17 && <0.3     , vector >=0.12.1.2 && <0.14   default-language: Haskell2010@@ -388,6 +390,9 @@     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@@ -455,6 +460,7 @@       Grisette.SymPrim.QuantifierTests       Grisette.SymPrim.SomeBVTests       Grisette.SymPrim.SymGeneralFunTests+      Grisette.SymPrim.SymPrimConstraintTests       Grisette.SymPrim.SymPrimTests       Grisette.SymPrim.TabularFunTests       Grisette.TestUtil.NoMerge@@ -467,7 +473,6 @@   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 -Wno-x-partial -Wno-unrecognised-warning-flags -threaded -rtsopts -with-rtsopts=-N -Wredundant-constraints-  ghc-prof-options: -finfo-table-map -fdistinct-constructor-tables   build-depends:       HUnit ==1.6.*     , QuickCheck >=2.14 && <2.16@@ -480,15 +485,15 @@     , bytestring >=0.10.12 && <0.13     , cereal >=0.5.8.1 && <0.6     , cereal-text >=0.1.0.2 && <0.2-    , containers >=0.4 && <0.8+    , containers >=0.5.7 && <0.9     , deepseq >=1.4.4 && <1.6     , generic-deriving >=1.14.1 && <1.15     , grisette-    , hashable >=1.2.5 && <1.6+    , 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.17 && <12     , stm ==2.5.*@@ -500,7 +505,7 @@     , th-abstraction >=0.4 && <0.8     , th-compat >=0.1.2 && <0.2     , th-lift-instances >=0.1.16 && <0.2-    , transformers >=0.5.6 && <0.7+    , transformers >=0.5.6.2 && <0.7     , unordered-containers >=0.2.17 && <0.3     , vector >=0.12.1.2 && <0.14   default-language: Haskell2010@@ -508,3 +513,6 @@     ghc-options: -O2   else     ghc-options: -O0+  if impl(ghc >= 9.2)+    ghc-prof-options: -finfo-table-map -fdistinct-constructor-tables+  else

@@ -306,6 +306,8 @@     Identifier (..),     Symbol (..),     identifier,+    AsMetadata (..),+    pattern Metadata,     withMetadata,     mapMetadata,     withLocation,@@ -556,13 +558,13 @@     --     deriving (Mergeable) via (Default X)     -- :}     ---    -- Grisette also provide 'Grisette.deriveGADT' template haskell procedure to+    -- 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-    -- deriveGADT [''X] [''Show, ''Mergeable]+    -- derive [''X] [''Show, ''Mergeable]     -- :}     --     -- Having the 'Mergeable' instance allows you to use the 'Union' type to@@ -593,7 +595,7 @@     -- >>> import Control.Monad.Except     -- >>> :{     --   data Error = Fail-    --   deriveGADT [''Error] allClasses0+    --   derive [''Error] allClasses0     -- :}     --     -- >>> mrgIf "a" (throwError Fail) (return "x") :: ExceptT Error Union SymInteger@@ -1829,7 +1831,8 @@     showsSExprWithParens,   ) import Grisette.Internal.Core.Data.Symbol-  ( Identifier (..),+  ( AsMetadata (..),+    Identifier (..),     Symbol (..),     identifier,     indexed,@@ -1840,6 +1843,7 @@     uniqueIdentifier,     withLocation,     withMetadata,+    pattern Metadata,   ) import Instances.TH.Lift () 

@@ -6,6 +6,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -89,7 +90,7 @@ 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.List.NonEmpty (NonEmpty) import Data.Proxy (Proxy (Proxy)) import qualified Data.SBV as SBV import qualified Data.SBV.Control as SBVC@@ -150,15 +151,11 @@   ) import Grisette.Internal.Core.Data.MemoUtils (htmemo) import Grisette.Internal.SymPrim.GeneralFun (substTerm)-import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalFP-  ( sbvFPBinaryTerm,-    sbvFPFMATerm,-    sbvFPRoundingBinaryTerm,-    sbvFPRoundingUnaryTerm,-    sbvFPTraitTerm,-    sbvFPUnaryTerm,+import Grisette.Internal.SymPrim.Prim.Model as PM+  ( Model,   )-import Grisette.Internal.SymPrim.Prim.Internal.Term+import Grisette.Internal.SymPrim.Prim.SomeTerm (SomeTerm (SomeTerm))+import Grisette.Internal.SymPrim.Prim.Term   ( PEvalApplyTerm (sbvApplyTerm),     PEvalBVTerm (sbvBVConcatTerm, sbvBVExtendTerm, sbvBVSelectTerm),     PEvalBitCastOrTerm (sbvBitCastOr),@@ -175,6 +172,14 @@         sbvQuotIntegralTerm,         sbvRemIntegralTerm       ),+    PEvalFPTerm+      ( sbvFPBinaryTerm,+        sbvFPFMATerm,+        sbvFPRoundingBinaryTerm,+        sbvFPRoundingUnaryTerm,+        sbvFPTraitTerm,+        sbvFPUnaryTerm+      ),     PEvalFloatingTerm (sbvFloatingUnaryTerm, sbvPowerTerm),     PEvalFractionalTerm (sbvFdivTerm, sbvRecipTerm),     PEvalFromIntegralTerm (sbvFromIntegralTerm),@@ -204,68 +209,62 @@         symSBVTerm,         withPrim       ),-    Term-      ( AbsNumTerm,-        AddNumTerm,-        AndBitsTerm,-        AndTerm,-        ApplyTerm,-        BVConcatTerm,-        BVExtendTerm,-        BVSelectTerm,-        BitCastOrTerm,-        BitCastTerm,-        ComplementBitsTerm,-        ConTerm,-        DistinctTerm,-        DivIntegralTerm,-        EqTerm,-        ExistsTerm,-        FPBinaryTerm,-        FPFMATerm,-        FPRoundingBinaryTerm,-        FPRoundingUnaryTerm,-        FPTraitTerm,-        FPUnaryTerm,-        FdivTerm,-        FloatingUnaryTerm,-        ForallTerm,-        FromFPOrTerm,-        FromIntegralTerm,-        ITETerm,-        LeOrdTerm,-        LtOrdTerm,-        ModIntegralTerm,-        MulNumTerm,-        NegNumTerm,-        NotTerm,-        OrBitsTerm,-        OrTerm,-        PowerTerm,-        QuotIntegralTerm,-        RecipTerm,-        RemIntegralTerm,-        RotateLeftTerm,-        RotateRightTerm,-        ShiftLeftTerm,-        ShiftRightTerm,-        SignumNumTerm,-        SymTerm,-        ToFPTerm,-        XorBitsTerm-      ),+    SymbolKind (AnyKind),+    Term,     TypedConstantSymbol,-    TypedSymbol,-    introSupportedPrimConstraint,+    TypedSymbol (TypedSymbol),     someTypedSymbol,     symTerm,-    withConstantSymbolSupported,-    withSymbolSupported,-  )-import Grisette.Internal.SymPrim.Prim.Model as PM-  ( Model,+    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)) import Grisette.Internal.SymPrim.SymBool (SymBool (SymBool))  -- $setup@@ -531,7 +530,7 @@         QuantifiedSymbols ->         Term x ->         m (QuantifiedStack -> SBVType x)-      goCached qs t = introSupportedPrimConstraint t $ do+      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)@@ -542,9 +541,9 @@         QuantifiedSymbols ->         Term a ->         m (QuantifiedStack -> SBVType a)-      goCachedImpl _ (ConTerm _ _ _ _ v) =+      goCachedImpl _ (ConTerm v) =         return $ const $ conSBVTerm v-      goCachedImpl qs t@(SymTerm _ _ _ _ ts) = do+      goCachedImpl qs t@(SymTerm ts) = do         if isQuantifiedSymbol ts qs           then withPrim @a $ do             let retDyn qst =@@ -571,36 +570,34 @@               modifyIORef' mapState $                 addBiMap (SomeTerm t) (toDyn g) name (someTypedSymbol ts)             return $ const g-      goCachedImpl qs t@(ForallTerm _ _ _ _ (ts :: TypedConstantSymbol t1) v) =-        withConstantSymbolSupported ts $-          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) =-        withConstantSymbolSupported ts $-          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@(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@@ -616,107 +613,104 @@         QuantifiedSymbols ->         Term a ->         m (QuantifiedStack -> SBVType a)-      goCachedIntermediate qs (NotTerm _ _ _ _ t) = do+      goCachedIntermediate qs (NotTerm t) = do         r <- goCached qs t         return $ \qst -> SBV.sNot (r qst)-      goCachedIntermediate qs (OrTerm _ _ _ _ a b) = do+      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+      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+      goCachedIntermediate qs (EqTerm (a :: Term v) b) = do         a' <- goCached qs a         b' <- goCached qs b         return $-          introSupportedPrimConstraint a $-            \qst -> sbvEq @v (a' qst) (b' qst)+          \qst -> sbvEq @v (a' qst) (b' qst)       goCachedIntermediate         qs-        (DistinctTerm _ _ _ _ (args@(arg1 :| _) :: NonEmpty (Term t0))) = do+        (DistinctTerm (args :: NonEmpty (Term t0))) = do           args' <- traverse (goCached qs) args-          return $-            introSupportedPrimConstraint arg1 $-              \qst -> sbvDistinct @t0 (fmap ($ qst) args')-      goCachedIntermediate qs (ITETerm _ _ _ _ c a b) = do+          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+      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+      goCachedIntermediate qs (NegNumTerm a) = do         a' <- goCached qs a         return $ sbvNegNumTerm @a . a'-      goCachedIntermediate qs (MulNumTerm _ _ _ _ a b) = do+      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+      goCachedIntermediate qs (AbsNumTerm a) = do         a' <- goCached qs a         return $ sbvAbsNumTerm @a . a'-      goCachedIntermediate qs (SignumNumTerm _ _ _ _ a) = do+      goCachedIntermediate qs (SignumNumTerm a) = do         a' <- goCached qs a         return $ sbvSignumNumTerm @a . a'-      goCachedIntermediate qs (LtOrdTerm _ _ _ _ (a :: Term v) b) = do+      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+      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+      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+      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+      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+      goCachedIntermediate qs (ComplementBitsTerm a) = do         a' <- goCached qs a         return $ sbvComplementBitsTerm @a . a'-      goCachedIntermediate qs (ShiftLeftTerm _ _ _ _ a b) = do+      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+      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+      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+      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+      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+      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+        (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))) =+        (BVConcatTerm (a :: Term (bv l)) (b :: Term (bv r))) =           do             a' <- goCached qs a             b' <- goCached qs b@@ -725,80 +719,80 @@                 sbvBVConcatTerm @bv (Proxy @l) (Proxy @r) (a' qst) (b' qst)       goCachedIntermediate         qs-        (BVExtendTerm _ _ _ _ signed (pr :: p r) (a :: Term (bv l))) =+        (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))) =+        (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+      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+      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+      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+      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) = do+      goCachedIntermediate qs (FPTraitTerm trait (a :: Term (fp eb sb))) = do         a' <- goCached qs a-        return $ sbvFPTraitTerm trait . a'-      goCachedIntermediate qs (FdivTerm _ _ _ _ a b) = do+        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+      goCachedIntermediate qs (RecipTerm a) = do         a <- goCached qs a         return $ sbvRecipTerm @a . a-      goCachedIntermediate qs (FloatingUnaryTerm _ _ _ _ op a) = do+      goCachedIntermediate qs (FloatingUnaryTerm op a) = do         a <- goCached qs a         return $ sbvFloatingUnaryTerm @a op . a-      goCachedIntermediate qs (PowerTerm _ _ _ _ a b) = do+      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) = do+      goCachedIntermediate qs (FPUnaryTerm op (a :: Term (fp eb sb))) = do         a <- goCached qs a-        return $ sbvFPUnaryTerm op . a-      goCachedIntermediate qs (FPBinaryTerm _ _ _ _ op a b) = do+        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 op (a qst) (b qst)-      goCachedIntermediate qs (FPRoundingUnaryTerm _ _ _ _ op round a) = do+        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 op (round qst) (a qst)-      goCachedIntermediate qs (FPRoundingBinaryTerm _ _ _ _ op round a b) = do+        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 op (round qst) (a qst) (b qst)-      goCachedIntermediate qs (FPFMATerm _ _ _ _ round a b c) = do+        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 (round qst) (a qst) (b qst) (c qst)-      goCachedIntermediate qs (FromIntegralTerm _ _ _ _ (b :: Term b)) = do+        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+      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+      goCachedIntermediate qs (ToFPTerm mode (arg :: Term b) _ _) = do         mode <- goCached qs mode         arg <- goCached qs arg         return $ \qst -> sbvToFPTerm @b (mode qst) (arg qst)@@ -806,7 +800,7 @@       goCachedIntermediate _ SymTerm {} = error "Should not happen"       goCachedIntermediate _ ForallTerm {} = error "Should not happen"       goCachedIntermediate _ ExistsTerm {} = error "Should not happen"-  r <- introSupportedPrimConstraint t' $ goCached emptyQuantifiedSymbols t'+  r <- goCached emptyQuantifiedSymbols t'   m <- liftIO $ readIORef mapState   constraint <- liftIO $ readIORef accumulatedDummyConstraints   return (m, r, constraint)@@ -859,9 +853,11 @@     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 knd r)) ->-        withSymbolSupported s $-          insertValue s (parseSMTModelResult 0 cv :: r) m+      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 "

@@ -1,5 +1,7 @@ {-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Strict #-} @@ -43,7 +45,7 @@     TypedSymbol (unTypedSymbol),     castSomeTypedSymbol,     typedConstantSymbol,-    withConstantSymbolSupported,+    pattern SupportedConstantTypedSymbol,   )  -- | A bidirectional map between symbolic Grisette terms and sbv terms.@@ -80,11 +82,11 @@  attachQuantifiedSymbolInfo ::   (SExpr -> SExpr) -> TypedConstantSymbol a -> TypedConstantSymbol a-attachQuantifiedSymbolInfo info tsym =-  withConstantSymbolSupported tsym $-    typedConstantSymbol $-      mapIdentifier (mapMetadata info) $-        unTypedSymbol tsym+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 ::

@@ -395,16 +395,14 @@  instance   {-# OVERLAPPABLE #-}-  ( GenSymSimple spec (m (CBMCEither a b))-  ) =>+  (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 (m (CBMCEither e a)) (m (CBMCEither e a))) =>   GenSymSimple (CBMCExceptT e m a) (CBMCExceptT e m a)   where   simpleFresh (CBMCExceptT v) = CBMCExceptT <$> simpleFresh v

@@ -92,6 +92,7 @@ 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@@ -112,7 +113,7 @@     unionBase,   ) import Grisette.Internal.Core.Data.Class.Mergeable-  ( Mergeable (rootStrategy),+  ( Mergeable (rootStrategy, sortIndices),     Mergeable1 (liftRootStrategy),     Mergeable2 (liftRootStrategy2),     MergingStrategy (SimpleStrategy),@@ -456,8 +457,7 @@     m (Union a)   default fresh ::     (GenSymSimple spec a) =>-    ( MonadFresh m-    ) =>+    (MonadFresh m) =>     spec ->     m (Union a)   fresh spec = mrgSingle <$> simpleFresh spec@@ -491,8 +491,7 @@   -- >>> runFresh (simpleFresh (SimpleListSpec 2 ())) "a" :: [SymBool]   -- [a@0,a@1]   simpleFresh ::-    ( MonadFresh m-    ) =>+    (MonadFresh m) =>     spec ->     m a @@ -507,8 +506,7 @@  class GenSymNoSpec a where   freshNoSpec ::-    ( MonadFresh m-    ) =>+    (MonadFresh m) =>     m (Union (a c))  instance GenSymNoSpec U1 where@@ -530,8 +528,7 @@   where   freshNoSpec ::     forall m c.-    ( MonadFresh m-    ) =>+    (MonadFresh m) =>     m (Union ((a :+: b) c))   freshNoSpec = do     cond :: bool <- simpleFresh ()@@ -545,8 +542,7 @@   where   freshNoSpec ::     forall m c.-    ( MonadFresh m-    ) =>+    (MonadFresh m) =>     m (Union ((a :*: b) c))   freshNoSpec = do     l :: Union (a c) <- freshNoSpec@@ -617,8 +613,7 @@  class GenSymSameShape a where   genSymSameShapeFresh ::-    ( MonadFresh m-    ) =>+    (MonadFresh m) =>     a c ->     m (a c) @@ -669,6 +664,51 @@   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@@@ -686,20 +726,14 @@   ) =>   [a] ->   m (Union 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"+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-  ) =>+  (Mergeable a) =>   [a] ->   Identifier ->   Union a@@ -722,20 +756,14 @@   ) =>   [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"+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-  ) =>+  (SimpleMergeable a) =>   [a] ->   Identifier ->   a@@ -760,20 +788,14 @@   ) =>   [Union a] ->   m (Union 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"+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-  ) =>+  (Mergeable a) =>   [Union a] ->   Identifier ->   Union a@@ -1584,16 +1606,14 @@  instance   {-# OVERLAPPABLE #-}-  ( GenSymSimple spec (m (Maybe a))-  ) =>+  (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 (m (Maybe a)) (m (Maybe a))) =>   GenSymSimple (MaybeT m a) (MaybeT m a)   where   simpleFresh (MaybeT v) = MaybeT <$> simpleFresh v@@ -1622,16 +1642,14 @@  instance   {-# OVERLAPPABLE #-}-  ( GenSymSimple spec (m (Either a b))-  ) =>+  (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 (m (Either e a)) (m (Either e a))) =>   GenSymSimple (ExceptT e m a) (ExceptT e m a)   where   simpleFresh (ExceptT v) = ExceptT <$> simpleFresh v

@@ -39,7 +39,7 @@ import Data.Word (Word16, Word32, Word64, Word8) import GHC.TypeLits (KnownNat, type (<=)) import Grisette.Internal.Core.Data.Class.BitVector-  ( BV (bv, bvSelect),+  ( BV (bv, bvConcat, bvSelect),   ) import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp (symIte)) import Grisette.Internal.Core.Data.Class.SymEq (SymEq ((.==)))@@ -52,6 +52,7 @@   ) 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@@ -152,10 +153,12 @@   symFromBits bits     | length bits /= finiteBitSize (undefined :: SymWordN n) =         error "symFromBits: length mismatch"-    | otherwise = foldl1 (.|.) lst+    | otherwise = case foldl1 bvConcat $ SomeBV <$> reverse lst of+        SomeBV r -> unsafeCoerce r+        _ -> error "symFromBits: length mismatch"     where-      lst :: [SymIntN n]-      lst = (\(pos, b) -> symIte b (setBit 0 pos) 0) <$> zip [0 ..] bits+      lst :: [SymIntN 1]+      lst = (\b -> symIte b 1 0) <$> bits  instance (KnownNat n, 1 <= n) => SymFiniteBits (SymWordN n) where   symTestBit v = symTestBit (SomeBV v)@@ -163,10 +166,12 @@   symFromBits bits     | length bits /= finiteBitSize (undefined :: SymWordN n) =         error "symFromBits: length mismatch"-    | otherwise = foldl1 (.|.) lst+    | otherwise = case foldl1 bvConcat $ SomeBV <$> reverse lst of+        SomeBV r -> unsafeCoerce r+        _ -> error "symFromBits: length mismatch"     where-      lst :: [SymWordN n]-      lst = (\(pos, b) -> symIte b (setBit 0 pos) 0) <$> zip [0 ..] bits+      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.@@ -183,13 +188,28 @@  -- | Count the number of set bits in a symbolic value. symPopCount :: (Num a, ITEOp a, SymFiniteBits a) => a -> a--- Node: v - v + is a trick to assign the correct bit-width to the result.-symPopCount v = v - v + sum ((\b -> symIte b 1 0) <$> symBitBlast v)+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: v - v + is a trick to assign the correct bit-width to the result.-symCountLeadingZeros v = v - v + go bits rs+-- 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 ..]@@ -199,8 +219,8 @@  -- | Count the number of trailing zeros in a symbolic value. symCountTrailingZeros :: (Num a, ITEOp a, SymFiniteBits a) => a -> a--- Node: v - v + is a trick to assign the correct bit-width to the result.-symCountTrailingZeros v = v - v + go bits rs+-- 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 ..]

@@ -6,10 +6,12 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}  -- |@@ -32,6 +34,8 @@     indexed,     symbolIdentifier,     mapIdentifier,+    AsMetadata (..),+    pattern Metadata,   ) where @@ -113,6 +117,23 @@ 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.@@ -129,16 +150,17 @@ -- -- The user may need to use unique identifiers or additional metadata to -- avoid unintentional identifier collision.-withMetadata :: T.Text -> SExpr -> Identifier-withMetadata = Identifier+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 :: (SExpr -> SExpr) -> Identifier -> Identifier-mapMetadata f (Identifier i m) = Identifier i (f m)+mapMetadata ::+  (AsMetadata a) => (SExpr -> a) -> Identifier -> Identifier+mapMetadata f (Identifier i m) = Identifier i (asMetadata $ f m)  identifierCount :: IORef Int identifierCount = unsafePerformIO $ newIORef 0

@@ -30,16 +30,17 @@  import Data.String (IsString (fromString)) import Grisette.Internal.Core.Data.Class.PlainUnion-  ( PlainUnion (ifView, singleView),+  ( PlainUnion (ifView, singleView, toGuardedList),   ) import Grisette.Internal.Core.Data.Class.Solvable   ( Solvable (con, conView, sym),     pattern Con,   ) import Grisette.Internal.Internal.Decl.Core.Data.Class.Mergeable-  ( Mergeable (rootStrategy),+  ( Mergeable (rootStrategy, sortIndices),     Mergeable1 (liftRootStrategy),     MergingStrategy (SimpleStrategy),+    resolveStrategy,     rootStrategy1,   ) import Grisette.Internal.Internal.Decl.Core.Data.Class.SimpleMergeable@@ -229,6 +230,7 @@ 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

@@ -205,6 +205,9 @@   -- | 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)) =>

@@ -68,7 +68,8 @@ import Grisette.Internal.Internal.Decl.Core.Data.Class.TryMerge   ( TryMerge (tryMergeWithStrategy),   )-import Grisette.Internal.SymPrim.SymBool (SymBool)+import Grisette.Internal.SymPrim.Prim.Internal.Term (SupportedPrim (pevalITETerm))+import Grisette.Internal.SymPrim.SymBool (SymBool (SymBool)) import Grisette.Internal.Utils.Derive (Arity0, Arity1)  -- $setup@@ -301,5 +302,9 @@ {-# INLINE mrgIf #-}  instance SimpleMergeable SymBool where-  mrgIte = symIte+  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 #-}

@@ -100,7 +100,7 @@ -- >>> a .== b -- (= a b) -- >>> a ./= b--- (distinct a b)+-- (! (= a b)) -- -- __Note:__ This type class can be derived for algebraic data types. -- You may need the @DerivingVia@ and @DerivingStrategies@ extensions.

@@ -414,7 +414,7 @@   abs = tryMerge . unionUnaryOp abs   signum = tryMerge . unionUnaryOp signum -instance (ITEOp a, Mergeable a) => ITEOp (Union a) where+instance (Mergeable a) => ITEOp (Union a) where   symIte = mrgIf  instance (LogicalOp a, Mergeable a) => LogicalOp (Union a) where

@@ -100,7 +100,7 @@ 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.GADT.DeriveGADT (deriveGADT)+import Grisette.Internal.TH.Derivation.Derive (derive)  #define CONCRETE_EVALUATESYM(type) \ instance EvalSym type where \@@ -184,7 +184,7 @@   evalSym fillDefault model (SymFP t) =     SymFP $ evalTerm fillDefault model HS.empty t -deriveGADT+derive   [ ''(),     ''AssertionError,     ''VerificationConditions,@@ -192,7 +192,7 @@   ]   [''EvalSym] -deriveGADT+derive   [ ''Either,     ''(,),     ''(,,),@@ -211,7 +211,7 @@   ]   [''EvalSym, ''EvalSym1, ''EvalSym2] -deriveGADT+derive   [ ''[],     ''Maybe,     ''Identity,

@@ -106,7 +106,7 @@ 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.GADT.DeriveGADT (deriveGADT)+import Grisette.Internal.TH.Derivation.Derive (derive)  -- $setup -- >>> import Grisette.Core@@ -212,7 +212,7 @@       Left HRefl -> SymbolSet <$> extractTerm HS.empty t       Right HRefl -> SymbolSet <$> extractTerm HS.empty t -deriveGADT+derive   [ ''(),     ''AssertionError,     ''VerificationConditions,@@ -220,7 +220,7 @@   ]   [''ExtractSym] -deriveGADT+derive   [ ''Either,     ''(,),     ''(,,),@@ -239,7 +239,7 @@   ]   [''ExtractSym, ''ExtractSym1, ''ExtractSym2] -deriveGADT+derive   [ ''[],     ''Maybe,     ''Identity,

@@ -118,7 +118,7 @@ import Grisette.Internal.SymPrim.SymInteger (SymInteger) import Grisette.Internal.SymPrim.SymTabularFun (type (=~>)) import Grisette.Internal.SymPrim.TabularFun (type (=->))-import Grisette.Internal.TH.GADT.DeriveGADT (deriveGADT)+import Grisette.Internal.TH.Derivation.Derive (derive) import Unsafe.Coerce (unsafeCoerce)  #define CONCRETE_ORD_MERGEABLE(type) \@@ -276,13 +276,13 @@ instance Mergeable () where   rootStrategy = SimpleStrategy $ \_ t _ -> t -deriveGADT+derive   [ ''Either,     ''(,)   ]   [''Mergeable, ''Mergeable1, ''Mergeable2] -deriveGADT+derive   [ ''(,,),     ''(,,,),     ''(,,,,),@@ -299,7 +299,7 @@   ]   [''Mergeable, ''Mergeable1, ''Mergeable2, ''Mergeable3] -deriveGADT+derive   [ ''Maybe,     ''Identity,     ''Monoid.Dual,@@ -317,7 +317,7 @@   ]   [''Mergeable, ''Mergeable1] -deriveGADT+derive   [ ''AssertionError,     ''VerificationConditions,     ''NotRepresentableFPError,

@@ -86,11 +86,12 @@     ValidFP,   ) import Grisette.Internal.SymPrim.GeneralFun (type (-->))-import Grisette.Internal.SymPrim.Prim.Internal.Term ()+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),@@ -111,7 +112,7 @@ import Grisette.Internal.SymPrim.SymInteger (SymInteger (SymInteger)) import Grisette.Internal.SymPrim.SymTabularFun (type (=~>) (SymTabularFun)) import Grisette.Internal.SymPrim.TabularFun (type (=->))-import Grisette.Internal.TH.GADT.DeriveGADT (deriveGADT)+import Grisette.Internal.TH.Derivation.Derive (derive)  #define FORMAT_SIMPLE(type) \ instance PPrint type where pformatPrec = viaShowsPrec showsPrec@@ -174,6 +175,12 @@ 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 \@@ -201,7 +208,7 @@ instance (ValidFP eb sb) => PPrint (SymFP eb sb) where   pformat (SymFP t) = prettyPrintTerm t -deriveGADT+derive   [ ''(),     ''AssertionError,     ''VerificationConditions,@@ -209,7 +216,7 @@   ]   [''PPrint] -deriveGADT+derive   [ ''Either,     ''(,),     ''(,,),@@ -228,7 +235,7 @@   ]   [''PPrint, ''PPrint1, ''PPrint2] -deriveGADT+derive   [ ''Maybe,     ''Monoid.Dual,     ''Monoid.First,

@@ -42,6 +42,7 @@ 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)@@ -59,7 +60,6 @@ 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.ITEOp (ITEOp (symIte)) import Grisette.Internal.Core.Data.Class.Mergeable   ( Mergeable (rootStrategy),     Mergeable1 (liftRootStrategy),@@ -77,24 +77,28 @@   ) import Grisette.Internal.Internal.Impl.Core.Data.Class.TryMerge () import Grisette.Internal.SymPrim.FP (ValidFP)-import Grisette.Internal.SymPrim.GeneralFun (type (-->))-import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal)+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,-    SymWordN,+  ( SymIntN (SymIntN),+    SymWordN (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.TH.GADT.DeriveGADT (deriveGADT)+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 -deriveGADT+derive   [ ''(,),     ''(,,),     ''(,,,),@@ -112,7 +116,7 @@   ]   [''SimpleMergeable, ''SimpleMergeable1, ''SimpleMergeable2] -deriveGADT+derive   [ ''Identity,     ''Monoid.Dual,     ''Monoid.Sum,@@ -121,7 +125,7 @@   ]   [''SimpleMergeable, ''SimpleMergeable1] -deriveGADT+derive   [''(), ''AssertionError]   [''SimpleMergeable] @@ -532,17 +536,17 @@  #define SIMPLE_MERGEABLE_SIMPLE(symtype) \ instance SimpleMergeable symtype where \-  mrgIte = symIte; \+  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 = symIte; \+  mrgIte (SymBool c) (symtype t) (symtype f) = symtype $ pevalITETerm c t f; \   {-# INLINE mrgIte #-} -#define SIMPLE_MERGEABLE_FUN(cop, op) \+#define SIMPLE_MERGEABLE_FUN(cop, op, cons) \ instance SimpleMergeable (op sa sb) where \-  mrgIte = symIte; \+  mrgIte (SymBool c) (cons t) (cons f) = cons $ pevalITETerm c t f; \   {-# INLINE mrgIte #-}  #if 1@@ -551,14 +555,25 @@ SIMPLE_MERGEABLE_SIMPLE(SymAlgReal) SIMPLE_MERGEABLE_BV(SymIntN) SIMPLE_MERGEABLE_BV(SymWordN)-SIMPLE_MERGEABLE_FUN((=->), (=~>))-SIMPLE_MERGEABLE_FUN((-->), (-~>))+SIMPLE_MERGEABLE_FUN((=->), (=~>), SymTabularFun)+SIMPLE_MERGEABLE_FUN((-->), (-~>), SymGeneralFun) #endif  instance SimpleMergeable (a --> b) where-  mrgIte = symIte+  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 = symIte+  mrgIte (SymBool c) (SymFP t) (SymFP f) = SymFP $ pevalITETerm c t f   {-# INLINE mrgIte #-}

@@ -36,7 +36,7 @@ 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.GADT.DeriveGADT (deriveGADT)+import Grisette.Internal.TH.Derivation.Derive (derive)  -- $setup -- >>> import Grisette@@ -44,7 +44,7 @@ -- >>> import Grisette.SymPrim -- >>> import Grisette.Backend -deriveGADT+derive   [''SolvingFailure]   [ ''Show,     ''Eq,

@@ -99,7 +99,7 @@ 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.GADT.DeriveGADT (deriveGADT)+import Grisette.Internal.TH.Derivation.Derive (derive)  #define CONCRETE_SUBSTITUTESYM(type) \ instance SubstSym type where \@@ -181,7 +181,7 @@ instance (ValidFP eb sb) => SubstSym (SymFP eb sb) where   substSym sym v (SymFP t) = SymFP $ substTerm sym (underlyingTerm v) HS.empty t -deriveGADT+derive   [ ''(),     ''AssertionError,     ''VerificationConditions,@@ -189,7 +189,7 @@   ]   [''SubstSym] -deriveGADT+derive   [ ''Either,     ''(,),     ''(,,),@@ -208,7 +208,7 @@   ]   [''SubstSym, ''SubstSym1, ''SubstSym2] -deriveGADT+derive   [ ''[],     ''Maybe,     ''Identity,

@@ -92,7 +92,7 @@     SymFPRoundingMode (SymFPRoundingMode),   ) import Grisette.Internal.SymPrim.SymInteger (SymInteger (SymInteger))-import Grisette.Internal.TH.GADT.DeriveGADT (deriveGADT)+import Grisette.Internal.TH.Derivation.Derive (derive)  #define CONCRETE_SEQ(type) \ instance SymEq type where \@@ -183,7 +183,7 @@   (SymFP l) .== (SymFP r) = SymBool $ pevalEqTerm l r   {-# INLINE (.==) #-} -deriveGADT+derive   [ ''(),     ''AssertionError,     ''VerificationConditions,@@ -191,7 +191,7 @@   ]   [''SymEq] -deriveGADT+derive   [ ''Either,     ''(,),     ''(,,),@@ -210,7 +210,7 @@   ]   [''SymEq, ''SymEq1, ''SymEq2] -deriveGADT+derive   [ ''[],     ''Maybe,     ''Identity,

@@ -103,7 +103,7 @@     SymFPRoundingMode (SymFPRoundingMode),   ) import Grisette.Internal.SymPrim.SymInteger (SymInteger (SymInteger))-import Grisette.Internal.TH.GADT.DeriveGADT (deriveGADT)+import Grisette.Internal.TH.Derivation.Derive (derive)  #define CONCRETE_SORD(type) \ instance SymOrd type where \@@ -286,7 +286,7 @@     y1 <- y     f x1 y1 -deriveGADT+derive   [ ''(),     ''AssertionError,     ''VerificationConditions,@@ -294,7 +294,7 @@   ]   [''SymOrd] -deriveGADT+derive   [ ''Either,     ''(,),     ''(,,),@@ -313,7 +313,7 @@   ]   [''SymOrd, ''SymOrd1, ''SymOrd2] -deriveGADT+derive   [ ''Maybe,     ''Identity,     ''Monoid.Dual,

@@ -107,7 +107,7 @@ import Grisette.Internal.SymPrim.SymInteger (SymInteger) import Grisette.Internal.SymPrim.SymTabularFun (type (=~>) (SymTabularFun)) import Grisette.Internal.SymPrim.TabularFun (type (=->))-import Grisette.Internal.TH.GADT.DeriveGADT (deriveGADT)+import Grisette.Internal.TH.Derivation.Derive (derive)  -- $setup -- >>> import Grisette.Core@@ -247,7 +247,7 @@       _ -> Nothing   toCon _ = Nothing -deriveGADT+derive   [ ''Either,     ''(,),     ''(,,),@@ -266,7 +266,7 @@   ]   [''ToCon, ''ToCon1, ''ToCon2] -deriveGADT+derive   [ ''[],     ''Maybe,     ''Monoid.Dual,@@ -282,7 +282,7 @@   ]   [''ToCon, ''ToCon1] -deriveGADT+derive   [ ''(),     ''AssertionError,     ''VerificationConditions,

@@ -112,7 +112,7 @@ import Grisette.Internal.SymPrim.SymInteger (SymInteger) import Grisette.Internal.SymPrim.SymTabularFun (type (=~>)) import Grisette.Internal.SymPrim.TabularFun (type (=->))-import Grisette.Internal.TH.GADT.DeriveGADT (deriveGADT)+import Grisette.Internal.TH.Derivation.Derive (derive)  -- $setup -- >>> import Grisette.SymPrim@@ -258,7 +258,7 @@   liftToSym l f = l . f . toSym   {-# INLINE liftToSym #-} -deriveGADT+derive   [ ''Either,     ''(,),     ''(,,),@@ -277,7 +277,7 @@   ]   [''ToSym, ''ToSym1, ''ToSym2] -deriveGADT+derive   [ ''[],     ''Maybe,     ''Monoid.Dual,@@ -293,7 +293,7 @@   ]   [''ToSym, ''ToSym1] -deriveGADT+derive   [ ''(),     ''AssertionError,     ''VerificationConditions,

@@ -60,7 +60,7 @@ 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.GADT.DeriveGADT (deriveGADT)+import Grisette.Internal.TH.Derivation.Derive (derive)  -- $setup -- >>> import Grisette.Core@@ -68,7 +68,7 @@ -- >>> import Grisette.Backend -- >>> import Data.Proxy -deriveGADT+derive   [ ''Either,     ''(,),     ''(,,),@@ -86,7 +86,7 @@     ''(,,,,,,,,,,,,,,)   ]   [''AllSyms, ''AllSyms1, ''AllSyms2]-deriveGADT+derive   [ ''[],     ''Maybe,     ''Identity,@@ -96,7 +96,7 @@     ''WriterStrict.WriterT   ]   [''AllSyms, ''AllSyms1]-deriveGADT+derive   [ ''(),     ''AssertionError,     ''VerificationConditions

@@ -69,7 +69,7 @@     UnifiedSimpleMergeable1 (withBaseSimpleMergeable1),     UnifiedSimpleMergeable2 (withBaseSimpleMergeable2),   )-import Grisette.Internal.TH.GADT.DeriveGADT (deriveGADT)+import Grisette.Internal.TH.Derivation.Derive (derive) import Grisette.Internal.Unified.BaseMonad (BaseMonad) import Grisette.Internal.Unified.EvalModeTag (IsConMode) import Grisette.Internal.Unified.UnifiedBool (UnifiedBool (GetBool))@@ -256,7 +256,7 @@   withBaseSimpleMergeable2 r = r   {-# INLINE withBaseSimpleMergeable2 #-} -deriveGADT+derive   [ ''(,),     ''(,,),     ''(,,,),@@ -277,11 +277,11 @@     ''UnifiedSimpleMergeable2   ] -deriveGADT+derive   [''Identity]   [''UnifiedSimpleMergeable, ''UnifiedSimpleMergeable1] -deriveGADT+derive   [''(), ''AssertionError]   [''UnifiedSimpleMergeable] 

@@ -66,10 +66,10 @@   ) import Grisette.Internal.SymPrim.BV (IntN, WordN) import Grisette.Internal.SymPrim.FP (FP, FPRoundingMode)-import Grisette.Internal.TH.GADT.Common+import Grisette.Internal.TH.Derivation.Common   ( DeriveConfig (bitSizePositions, fpBitSizePositions),   )-import Grisette.Internal.TH.GADT.DeriveGADT (deriveGADT, deriveGADTWith)+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)@@ -229,13 +229,13 @@   withBaseSymEq r = withBaseSymEq @'S @v r   {-# INLINE withBaseSymEq #-} -deriveGADT+derive   [ ''Either,     ''(,)   ]   [''UnifiedSymEq, ''UnifiedSymEq1, ''UnifiedSymEq2] -deriveGADT+derive   [ ''[],     ''Maybe,     ''Identity,@@ -246,7 +246,7 @@   ]   [''UnifiedSymEq, ''UnifiedSymEq1] -deriveGADT+derive   [ ''Bool,     ''Integer,     ''Char,@@ -284,25 +284,25 @@   [''UnifiedSymEq]  #if MIN_VERSION_base(4,16,0)-deriveGADT+derive   [ ''(,,),     ''(,,,)   ]   [''UnifiedSymEq, ''UnifiedSymEq1, ''UnifiedSymEq2] #else-deriveGADT+derive   [ ''(,,),     ''(,,,)   ]   [''UnifiedSymEq] #endif -deriveGADTWith+deriveWith   (mempty {bitSizePositions = [0]})   [''WordN, ''IntN]   [''UnifiedSymEq] -deriveGADTWith+deriveWith   (mempty {fpBitSizePositions = [(0, 1)]})   [''FP]   [''UnifiedSymEq]

@@ -85,10 +85,10 @@   ) import Grisette.Internal.SymPrim.BV (IntN, WordN) import Grisette.Internal.SymPrim.FP (FP, FPRoundingMode)-import Grisette.Internal.TH.GADT.Common+import Grisette.Internal.TH.Derivation.Common   ( DeriveConfig (bitSizePositions, fpBitSizePositions),   )-import Grisette.Internal.TH.GADT.DeriveGADT (deriveGADT, deriveGADTWith)+import Grisette.Internal.TH.Derivation.Derive (derive, deriveWith) import Grisette.Internal.Unified.BaseMonad (BaseMonad) import Grisette.Internal.Unified.EvalModeTag   ( EvalModeTag (S),@@ -363,13 +363,13 @@   withBaseSymOrd r = withBaseSymOrd @'S @v r   {-# INLINE withBaseSymOrd #-} -deriveGADT+derive   [ ''Either,     ''(,)   ]   [''UnifiedSymOrd, ''UnifiedSymOrd1, ''UnifiedSymOrd2] -deriveGADT+derive   [ ''[],     ''Maybe,     ''Identity,@@ -380,7 +380,7 @@   ]   [''UnifiedSymOrd, ''UnifiedSymOrd1] -deriveGADT+derive   [ ''Bool,     ''Integer,     ''Char,@@ -417,25 +417,25 @@   [''UnifiedSymOrd]  #if MIN_VERSION_base(4,16,0)-deriveGADT+derive   [ ''(,,),     ''(,,,)   ]   [''UnifiedSymOrd, ''UnifiedSymOrd1, ''UnifiedSymOrd2] #else-deriveGADT+derive   [ ''(,,),     ''(,,,)   ]   [''UnifiedSymOrd] #endif -deriveGADTWith+deriveWith   (mempty {bitSizePositions = [0]})   [''WordN, ''IntN]   [''UnifiedSymOrd] -deriveGADTWith+deriveWith   (mempty {fpBitSizePositions = [(0, 1)]})   [''FP]   [''UnifiedSymOrd]

@@ -22,7 +22,6 @@   ) where -import Data.Hashable (Hashable) import qualified Data.SBV as SBV import Grisette.Internal.SymPrim.Prim.Internal.Term   ( IsSymbolKind,@@ -73,7 +72,7 @@   ( plainTVInferred,     plainTVSpecified,   )-import Type.Reflection (TypeRep, Typeable, typeRep, type (:~~:) (HRefl))+import Type.Reflection (TypeRep, typeRep, type (:~~:) (HRefl))  instanceWithOverlapDescD ::   Maybe Overlap -> Q Cxt -> Q Type -> [DecsQ] -> DecsQ@@ -219,17 +218,7 @@           |]        constraints =-        fmap concat-          . traverse-            ( \ty ->-                sequence-                  [ [t|SupportedNonFuncPrim $ty|],-                    [t|Eq $ty|],-                    [t|Show $ty|],-                    [t|Hashable $ty|],-                    [t|Typeable $ty|]-                  ]-            )+        fmap concat . traverse (\ty -> sequence [[t|SupportedNonFuncPrim $ty|]])       funType =         foldl1 (\fty ty -> [t|$(varT funTypeName) $ty $fty|]) . reverse       withPrims :: [Q Type] -> Q Exp@@ -265,5 +254,5 @@             funNamePrefix             funTypeName             n-          | n <- [2 .. numArg]+        | n <- [2 .. numArg]         ]

@@ -37,16 +37,14 @@ where  #if MIN_VERSION_base(4,20,0)-import Data.Foldable (Foldable (toList)) #else-import Data.Foldable (Foldable (foldl', toList))+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.List.NonEmpty (NonEmpty ((:|))) import Data.Maybe (fromJust) import qualified Data.SBV as SBV import qualified Data.SBV.Dynamic as SBVD@@ -59,14 +57,7 @@   ( Symbol (IndexedSymbol),   ) import Grisette.Internal.SymPrim.FunInstanceGen (supportedPrimFunUpTo)-import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalFP-  ( pevalFPBinaryTerm,-    pevalFPFMATerm,-    pevalFPRoundingBinaryTerm,-    pevalFPRoundingUnaryTerm,-    pevalFPTraitTerm,-    pevalFPUnaryTerm,-  )+import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalFP () import Grisette.Internal.SymPrim.Prim.Internal.PartialEval (totalize2) import Grisette.Internal.SymPrim.Prim.Internal.Term   ( IsSymbolKind,@@ -87,6 +78,14 @@       ( pevalDivIntegralTerm,         pevalModIntegralTerm       ),+    PEvalFPTerm+      ( pevalFPBinaryTerm,+        pevalFPFMATerm,+        pevalFPRoundingBinaryTerm,+        pevalFPRoundingUnaryTerm,+        pevalFPTraitTerm,+        pevalFPUnaryTerm+      ),     PEvalFloatingTerm (pevalFloatingUnaryTerm, pevalPowerTerm),     PEvalFractionalTerm (pevalFdivTerm, pevalRecipTerm),     PEvalFromIntegralTerm (pevalFromIntegralTerm),@@ -117,56 +116,7 @@     SupportedPrimConstraint (PrimConstraint),     SymRep (SymType),     SymbolKind (AnyKind),-    Term-      ( AbsNumTerm,-        AddNumTerm,-        AndBitsTerm,-        AndTerm,-        ApplyTerm,-        BVConcatTerm,-        BVExtendTerm,-        BVSelectTerm,-        BitCastOrTerm,-        BitCastTerm,-        ComplementBitsTerm,-        ConTerm,-        DistinctTerm,-        DivIntegralTerm,-        EqTerm,-        ExistsTerm,-        FPBinaryTerm,-        FPFMATerm,-        FPRoundingBinaryTerm,-        FPRoundingUnaryTerm,-        FPTraitTerm,-        FPUnaryTerm,-        FdivTerm,-        FloatingUnaryTerm,-        ForallTerm,-        FromFPOrTerm,-        FromIntegralTerm,-        ITETerm,-        LeOrdTerm,-        LtOrdTerm,-        ModIntegralTerm,-        MulNumTerm,-        NegNumTerm,-        NotTerm,-        OrBitsTerm,-        OrTerm,-        PowerTerm,-        QuotIntegralTerm,-        RecipTerm,-        RemIntegralTerm,-        RotateLeftTerm,-        RotateRightTerm,-        ShiftLeftTerm,-        ShiftRightTerm,-        SignumNumTerm,-        SymTerm,-        ToFPTerm,-        XorBitsTerm-      ),+    Term,     TypedAnySymbol,     TypedConstantSymbol,     TypedSymbol,@@ -175,7 +125,6 @@     eqHeteroSymbol,     existsTerm,     forallTerm,-    introSupportedPrimConstraint,     partitionCVArg,     pevalAndTerm,     pevalEqTerm,@@ -191,9 +140,57 @@     translateTypeError,     typedAnySymbol,     typedConstantSymbol,-    withConstantSymbolSupported,-    withSymbolSupported,+    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@@ -242,9 +239,9 @@     goTyped = go . someTerm      go :: SomeTerm -> HS.HashSet SomeTypedAnySymbol-    go (SomeTerm (SymTerm _ _ _ _ (sym :: TypedAnySymbol a))) =+    go (SomeTerm (SymTerm (sym :: TypedAnySymbol a))) =       HS.singleton $ someTypedSymbol sym-    go (SomeTerm (ConTerm _ _ _ _ cv :: Term v)) =+    go (SomeTerm (ConTerm cv :: Term v)) =       case (primTypeRep :: TypeRep v) of         App (App gf _) _ ->           case eqTypeRep (typeRep @(-->)) gf of@@ -258,78 +255,11 @@                     $ go (SomeTerm tm)             Nothing -> HS.empty         _ -> HS.empty-    go (SomeTerm (ForallTerm _ _ _ _ sym arg)) =-      withConstantSymbolSupported sym $-        HS.insert (someTypedSymbol $ fromJust $ castTypedSymbol sym) $-          goUnary arg-    go (SomeTerm (ExistsTerm _ _ _ _ sym arg)) =-      withConstantSymbolSupported sym $-        HS.insert (someTypedSymbol $ fromJust $ castTypedSymbol sym) $-          goUnary arg-    go (SomeTerm (NotTerm _ _ _ _ arg)) = goUnary arg-    go (SomeTerm (OrTerm _ _ _ _ arg1 arg2)) = goBinary arg1 arg2-    go (SomeTerm (AndTerm _ _ _ _ arg1 arg2)) = goBinary arg1 arg2-    go (SomeTerm (EqTerm _ _ _ _ arg1 arg2)) = goBinary arg1 arg2-    go (SomeTerm (DistinctTerm _ _ _ _ args)) =-      mconcat <$> map goTyped $ toList args-    go (SomeTerm (ITETerm _ _ _ _ cond arg1 arg2)) = goTernary cond arg1 arg2-    go (SomeTerm (AddNumTerm _ _ _ _ arg1 arg2)) = goBinary arg1 arg2-    go (SomeTerm (NegNumTerm _ _ _ _ arg)) = goUnary arg-    go (SomeTerm (MulNumTerm _ _ _ _ arg1 arg2)) = goBinary arg1 arg2-    go (SomeTerm (AbsNumTerm _ _ _ _ arg)) = goUnary arg-    go (SomeTerm (SignumNumTerm _ _ _ _ arg)) = goUnary arg-    go (SomeTerm (LtOrdTerm _ _ _ _ arg1 arg2)) = goBinary arg1 arg2-    go (SomeTerm (LeOrdTerm _ _ _ _ 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 n)) = goBinary arg n-    go (SomeTerm (ShiftRightTerm _ _ _ _ arg n)) = goBinary arg n-    go (SomeTerm (RotateLeftTerm _ _ _ _ arg n)) = goBinary arg n-    go (SomeTerm (RotateRightTerm _ _ _ _ arg n)) = goBinary arg n-    go (SomeTerm (BitCastTerm _ _ _ _ arg)) = goUnary arg-    go (SomeTerm (BitCastOrTerm _ _ _ _ d arg)) = goBinary d arg-    go (SomeTerm (BVConcatTerm _ _ _ _ arg1 arg2)) = goBinary arg1 arg2-    go (SomeTerm (BVSelectTerm _ _ _ _ _ _ arg)) = goUnary arg-    go (SomeTerm (BVExtendTerm _ _ _ _ _ _ arg)) = goUnary arg-    go (SomeTerm (ApplyTerm _ _ _ _ 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 (FPTraitTerm _ _ _ _ _ arg)) = goUnary arg-    go (SomeTerm (FdivTerm _ _ _ _ arg1 arg2)) = goBinary arg1 arg2-    go (SomeTerm (RecipTerm _ _ _ _ arg)) = goUnary arg-    go (SomeTerm (FloatingUnaryTerm _ _ _ _ _ arg)) = goUnary arg-    go (SomeTerm (PowerTerm _ _ _ _ arg1 arg2)) = goBinary arg1 arg2-    go (SomeTerm (FPUnaryTerm _ _ _ _ _ arg)) = goUnary arg-    go (SomeTerm (FPBinaryTerm _ _ _ _ _ arg1 arg2)) = goBinary arg1 arg2-    go (SomeTerm (FPRoundingUnaryTerm _ _ _ _ _ _ arg)) = goUnary arg-    go (SomeTerm (FPRoundingBinaryTerm _ _ _ _ _ _ arg1 arg2)) = goBinary arg1 arg2-    go (SomeTerm (FPFMATerm _ _ _ _ mode arg1 arg2 arg3)) =-      mconcat-        [ goTyped mode,-          goTyped arg1,-          goTyped arg2,-          goTyped arg3-        ]-    go (SomeTerm (FromIntegralTerm _ _ _ _ arg)) = goUnary arg-    go (SomeTerm (FromFPOrTerm _ _ _ _ d mode arg)) = goTernary d mode arg-    go (SomeTerm (ToFPTerm _ _ _ _ mode arg _ _)) = goBinary mode arg-    goUnary :: Term a -> HS.HashSet SomeTypedAnySymbol-    goUnary = goTyped-    goBinary ::-      Term a ->-      Term b ->-      HS.HashSet SomeTypedAnySymbol-    goBinary a b = goTyped a <> goTyped b-    goTernary ::-      Term a ->-      Term b ->-      Term c ->-      HS.HashSet SomeTypedAnySymbol-    goTernary a b c = goTyped a <> goTyped b <> goTyped c+    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.@@ -412,9 +342,9 @@   Term b pevalGeneralFunApplyTerm = totalize2 doPevalApplyTerm applyTerm   where-    doPevalApplyTerm (ConTerm _ _ _ _ (GeneralFun arg tm)) v =+    doPevalApplyTerm (ConTerm (GeneralFun arg tm)) v =       Just $ substTerm arg v HS.empty tm-    doPevalApplyTerm (ITETerm _ _ _ _ c l r) v =+    doPevalApplyTerm (ITETerm c l r) v =       return $ pevalITETerm c (pevalApplyTerm l v) (pevalApplyTerm r v)     doPevalApplyTerm _ _ = Nothing @@ -479,7 +409,7 @@       HS.HashSet SomeTypedConstantSymbol ->       SomeTerm ->       SomeTerm-    goSome _ bs c@(SomeTerm (ConTerm _ _ _ _ cv :: Term x)) =+    goSome _ bs c@(SomeTerm (ConTerm cv :: Term x)) =       case (primTypeRep :: TypeRep x) of         App (App gf _) _ ->           case eqTypeRep gf (typeRep @(-->)) of@@ -495,118 +425,115 @@                  in SomeTerm $ conTerm $ GeneralFun sym (go newmemo tm)             Nothing -> c         _ -> c-    goSome _ bs c@(SomeTerm ((SymTerm _ _ _ _ sym) :: Term a)) =+    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)) =+    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)) =+    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)) =+    goSome memo _ (SomeTerm (NotTerm arg)) =       goUnary memo pevalNotTerm arg-    goSome memo _ (SomeTerm (OrTerm _ _ _ _ arg1 arg2)) =+    goSome memo _ (SomeTerm (OrTerm arg1 arg2)) =       goBinary memo pevalOrTerm arg1 arg2-    goSome memo _ (SomeTerm (AndTerm _ _ _ _ arg1 arg2)) =+    goSome memo _ (SomeTerm (AndTerm arg1 arg2)) =       goBinary memo pevalAndTerm arg1 arg2-    goSome memo _ (SomeTerm (EqTerm _ _ _ _ arg1 arg2)) =-      introSupportedPrimConstraint arg1 $-        goBinary memo pevalEqTerm arg1 arg2-    goSome memo _ (SomeTerm (DistinctTerm _ _ _ _ args@(arg1 :| _))) =-      introSupportedPrimConstraint arg1 $-        SomeTerm $-          pevalDistinctTerm (fmap (go memo) args)-    goSome memo _ (SomeTerm (ITETerm _ _ _ _ cond 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)) =+    goSome memo _ (SomeTerm (AddNumTerm arg1 arg2)) =       goBinary memo pevalAddNumTerm arg1 arg2-    goSome memo _ (SomeTerm (NegNumTerm _ _ _ _ arg)) =+    goSome memo _ (SomeTerm (NegNumTerm arg)) =       goUnary memo pevalNegNumTerm arg-    goSome memo _ (SomeTerm (MulNumTerm _ _ _ _ arg1 arg2)) =+    goSome memo _ (SomeTerm (MulNumTerm arg1 arg2)) =       goBinary memo pevalMulNumTerm arg1 arg2-    goSome memo _ (SomeTerm (AbsNumTerm _ _ _ _ arg)) =+    goSome memo _ (SomeTerm (AbsNumTerm arg)) =       goUnary memo pevalAbsNumTerm arg-    goSome memo _ (SomeTerm (SignumNumTerm _ _ _ _ arg)) =+    goSome memo _ (SomeTerm (SignumNumTerm arg)) =       goUnary memo pevalSignumNumTerm arg-    goSome memo _ (SomeTerm (LtOrdTerm _ _ _ _ arg1 arg2)) =+    goSome memo _ (SomeTerm (LtOrdTerm arg1 arg2)) =       goBinary memo pevalLtOrdTerm arg1 arg2-    goSome memo _ (SomeTerm (LeOrdTerm _ _ _ _ arg1 arg2)) =+    goSome memo _ (SomeTerm (LeOrdTerm arg1 arg2)) =       goBinary memo pevalLeOrdTerm arg1 arg2-    goSome memo _ (SomeTerm (AndBitsTerm _ _ _ _ arg1 arg2)) =+    goSome memo _ (SomeTerm (AndBitsTerm arg1 arg2)) =       goBinary memo pevalAndBitsTerm arg1 arg2-    goSome memo _ (SomeTerm (OrBitsTerm _ _ _ _ arg1 arg2)) =+    goSome memo _ (SomeTerm (OrBitsTerm arg1 arg2)) =       goBinary memo pevalOrBitsTerm arg1 arg2-    goSome memo _ (SomeTerm (XorBitsTerm _ _ _ _ arg1 arg2)) =+    goSome memo _ (SomeTerm (XorBitsTerm arg1 arg2)) =       goBinary memo pevalXorBitsTerm arg1 arg2-    goSome memo _ (SomeTerm (ComplementBitsTerm _ _ _ _ arg)) =+    goSome memo _ (SomeTerm (ComplementBitsTerm arg)) =       goUnary memo pevalComplementBitsTerm arg-    goSome memo _ (SomeTerm (ShiftLeftTerm _ _ _ _ arg n)) =+    goSome memo _ (SomeTerm (ShiftLeftTerm arg n)) =       goBinary memo pevalShiftLeftTerm arg n-    goSome memo _ (SomeTerm (RotateLeftTerm _ _ _ _ arg n)) =+    goSome memo _ (SomeTerm (RotateLeftTerm arg n)) =       goBinary memo pevalRotateLeftTerm arg n-    goSome memo _ (SomeTerm (ShiftRightTerm _ _ _ _ arg n)) =+    goSome memo _ (SomeTerm (ShiftRightTerm arg n)) =       goBinary memo pevalShiftRightTerm arg n-    goSome memo _ (SomeTerm (RotateRightTerm _ _ _ _ arg n)) =+    goSome memo _ (SomeTerm (RotateRightTerm arg n)) =       goBinary memo pevalRotateRightTerm arg n-    goSome memo _ (SomeTerm (BitCastTerm _ _ _ _ (arg :: Term a) :: Term r)) =+    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)) =+    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)) =+    goSome memo _ (SomeTerm (BVConcatTerm arg1 arg2)) =       goBinary memo pevalBVConcatTerm arg1 arg2-    goSome memo _ (SomeTerm (BVSelectTerm _ _ _ _ ix w arg)) =+    goSome memo _ (SomeTerm (BVSelectTerm ix w arg)) =       goUnary memo (pevalBVSelectTerm ix w) arg-    goSome memo _ (SomeTerm (BVExtendTerm _ _ _ _ n signed arg)) =+    goSome memo _ (SomeTerm (BVExtendTerm n signed arg)) =       goUnary memo (pevalBVExtendTerm n signed) arg-    goSome memo _ (SomeTerm (ApplyTerm _ _ _ _ f arg)) =+    goSome memo _ (SomeTerm (ApplyTerm f arg)) =       goBinary memo pevalApplyTerm f arg-    goSome memo _ (SomeTerm (DivIntegralTerm _ _ _ _ arg1 arg2)) =+    goSome memo _ (SomeTerm (DivIntegralTerm arg1 arg2)) =       goBinary memo pevalDivIntegralTerm arg1 arg2-    goSome memo _ (SomeTerm (ModIntegralTerm _ _ _ _ arg1 arg2)) =+    goSome memo _ (SomeTerm (ModIntegralTerm arg1 arg2)) =       goBinary memo pevalModIntegralTerm arg1 arg2-    goSome memo _ (SomeTerm (QuotIntegralTerm _ _ _ _ arg1 arg2)) =+    goSome memo _ (SomeTerm (QuotIntegralTerm arg1 arg2)) =       goBinary memo pevalQuotIntegralTerm arg1 arg2-    goSome memo _ (SomeTerm (RemIntegralTerm _ _ _ _ arg1 arg2)) =+    goSome memo _ (SomeTerm (RemIntegralTerm arg1 arg2)) =       goBinary memo pevalRemIntegralTerm arg1 arg2-    goSome memo _ (SomeTerm (FPTraitTerm _ _ _ _ trait arg)) =+    goSome memo _ (SomeTerm (FPTraitTerm trait arg)) =       goUnary memo (pevalFPTraitTerm trait) arg-    goSome memo _ (SomeTerm (FdivTerm _ _ _ _ arg1 arg2)) =+    goSome memo _ (SomeTerm (FdivTerm arg1 arg2)) =       goBinary memo pevalFdivTerm arg1 arg2-    goSome memo _ (SomeTerm (RecipTerm _ _ _ _ arg)) =+    goSome memo _ (SomeTerm (RecipTerm arg)) =       goUnary memo pevalRecipTerm arg-    goSome memo _ (SomeTerm (FloatingUnaryTerm _ _ _ _ op arg)) =+    goSome memo _ (SomeTerm (FloatingUnaryTerm op arg)) =       goUnary memo (pevalFloatingUnaryTerm op) arg-    goSome memo _ (SomeTerm (PowerTerm _ _ _ _ arg1 arg2)) =+    goSome memo _ (SomeTerm (PowerTerm arg1 arg2)) =       goBinary memo pevalPowerTerm arg1 arg2-    goSome memo _ (SomeTerm (FPUnaryTerm _ _ _ _ op arg)) =+    goSome memo _ (SomeTerm (FPUnaryTerm op arg)) =       goUnary memo (pevalFPUnaryTerm op) arg-    goSome memo _ (SomeTerm (FPBinaryTerm _ _ _ _ op arg1 arg2)) =+    goSome memo _ (SomeTerm (FPBinaryTerm op arg1 arg2)) =       goBinary memo (pevalFPBinaryTerm op) arg1 arg2-    goSome memo _ (SomeTerm (FPRoundingUnaryTerm _ _ _ _ op mode arg)) =+    goSome memo _ (SomeTerm (FPRoundingUnaryTerm op mode arg)) =       goUnary memo (pevalFPRoundingUnaryTerm op mode) arg-    goSome memo _ (SomeTerm (FPRoundingBinaryTerm _ _ _ _ op mode arg1 arg2)) =+    goSome memo _ (SomeTerm (FPRoundingBinaryTerm op mode arg1 arg2)) =       goBinary memo (pevalFPRoundingBinaryTerm op mode) arg1 arg2-    goSome memo _ (SomeTerm (FPFMATerm _ _ _ _ mode arg1 arg2 arg3)) =+    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)) =+    goSome memo _ (SomeTerm (FromIntegralTerm (arg :: Term a) :: Term b)) =       goUnary memo (pevalFromIntegralTerm @a @b) arg-    goSome memo _ (SomeTerm (FromFPOrTerm _ _ _ _ d mode 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))) =+      (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)@@ -622,20 +549,20 @@   HS.HashSet SomeTypedConstantSymbol ->   Term b ->   Term b-substTerm sym a =+substTerm sym@SupportedTypedSymbol a =   generalSubstSomeTerm     ( \t ->         if eqHeteroSymbol sym t           then unsafeCoerce a-          else withSymbolSupported t $ symTerm t+          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 (ta :: TypedConstantSymbol a) a),+        ConTerm (GeneralFun tb b)         ) ->           conTerm $             GeneralFun argSymbol $

@@ -1,5 +1,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}  -- | -- Module      :   Grisette.Internal.SymPrim.ModelRep@@ -18,7 +19,7 @@ import Grisette.Internal.SymPrim.Prim.Model (Model) import Grisette.Internal.SymPrim.Prim.Term   ( LinkedRep (underlyingTerm),-    Term (SymTerm),+    pattern SymTerm,   )  -- $setup@@ -40,5 +41,5 @@ instance ModelRep (ModelSymPair ct st) Model where   buildModel (sym := val) =     case underlyingTerm sym of-      SymTerm _ _ _ _ symbol -> insertValue symbol val emptyModel+      SymTerm symbol -> insertValue symbol val emptyModel       _ -> error "buildModel: should only use symbolic constants"

@@ -21,8 +21,9 @@ module Grisette.Internal.SymPrim.Prim.Internal.Caches   ( SomeStableName (..),     Id,-    Ident,+    StableIdent,     Digest,+    CachedInfo (..),     Interned (..),     intern,     haveCache,@@ -73,37 +74,48 @@ type Id = Word32  -- | The identity of a term.-type Ident = StableName Any+type StableIdent = StableName Any  -- | A digest of a term. type Digest = Word32 -newtype Cache t = Cache {getCache :: A.Array Int (CacheState t)}+-- | 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 (),-      _nextId :: M.IOVector Id,-      _currentThread :: HashTable (Description t) (Id, Weak Ident)+      _currentThread :: HashTable (Description t) (Id, Weak StableIdent)     } ->     CacheState t  finalizeCacheState :: CacheState t -> IO ()-finalizeCacheState (CacheState _ _ s) = do+finalizeCacheState (CacheState _ s) = do   m <- readIORef s   traverse_ (\(_, w) -> finalize w) m  finalizeCache :: Cache t -> IO ()-finalizeCache (Cache a) = mapM_ finalizeCacheState (A.elems a)+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 :: WeakThreadId -> Digest -> Id -> Ident -> Uninterned t -> t+  identify :: CachedInfo -> Uninterned t -> t   threadId :: t -> WeakThreadId   descriptionDigest :: Description t -> Digest @@ -128,11 +140,13 @@     element =       CacheState         <$> newMVar ()-        <*> M.replicate 1 0         <*> newIORef HM.empty     result = do       elements <- replicateM (fromIntegral cacheWidth) element-      return $ Cache $ A.listArray (0, fromIntegral cacheWidth - 1) elements+      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@@ -177,8 +191,8 @@       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+          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@@ -206,21 +220,23 @@   let !dt = describe bt :: Description t       !hdt = descriptionDigest dt       !r = hdt `mod` cacheWidth-      CacheState sem nextId s = getCache cache A.! (fromIntegral r)+      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-      newId0 <- M.unsafeRead nextId 0-      M.unsafeWrite nextId 0 (newId0 + 1)+      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 :: Ident+      let anyNewIdent = unsafeCoerce newIdent :: StableIdent       identRef <-         mkWeakStableNameRefWithFinalizer anyNewIdent $           reclaimTerm wtid fingerprint (fromIntegral r) dt-      let !t = identify (weakThreadId tid) hdt newId anyNewIdent bt+      let !t = identify (CachedInfo (weakThreadId tid) hdt newId anyNewIdent) bt       writeIORef s $ HM.insert dt (newId, identRef) current       putMVar sem ()       return t@@ -228,21 +244,26 @@       t1 <- deRefWeak oldIdentRef       case t1 of         Nothing -> do-          newId0 <- M.unsafeRead nextId 0-          M.unsafeWrite nextId 0 (newId0 + 1)+          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 :: Ident+          let anyNewIdent = unsafeCoerce newIdent :: StableIdent           identRef <-             mkWeakStableNameRefWithFinalizer anyNewIdent $               reclaimTerm wtid fingerprint (fromIntegral r) dt-          let !term = identify (weakThreadId tid) hdt newId anyNewIdent bt+          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 (weakThreadId tid) hdt oldId t1 bt+          return $! identify (CachedInfo (weakThreadId tid) hdt oldId t1) bt {-# NOINLINE intern #-}  -- | Check if the current thread has a cache.@@ -253,10 +274,10 @@   return $ HM.member tid caches  cacheStateSize :: CacheState t -> IO Int-cacheStateSize (CacheState _ _ s) = HM.size <$> readIORef s+cacheStateSize (CacheState _ s) = HM.size <$> readIORef s  cacheStateLiveSize :: CacheState t -> IO Int-cacheStateLiveSize (CacheState sem _ s) = do+cacheStateLiveSize (CacheState sem s) = do   takeMVar sem   v <- fmap snd . HM.toList <$> readIORef s   r <-@@ -270,30 +291,11 @@   putMVar sem ()   return r -{--dumpCacheState :: CacheState t -> IO ()-dumpCacheState (CacheState sem s) = do-  takeMVar sem-  v <- HM.toList <$> readIORef s-  mapM_-    ( \(k, (i, v)) -> do-        v1 <- deRefWeak v-        case v1 of-          Nothing -> print (k, i, "dead")-          Just r -> print (k, i, r)-    )-    v-  putMVar sem ()--dumpCache :: Cache t -> IO ()-dumpCache (Cache a) = mapM_ dumpCacheState (A.elems a)--}- cacheSize :: Cache t -> IO Int-cacheSize (Cache a) = sum <$> mapM cacheStateSize (A.elems a)+cacheSize (Cache a _ _) = sum <$> mapM cacheStateSize (A.elems a)  cacheLiveSize :: Cache t -> IO Int-cacheLiveSize (Cache a) = sum <$> mapM cacheStateLiveSize (A.elems a)+cacheLiveSize (Cache a _ _) = sum <$> mapM cacheStateLiveSize (A.elems a)  -- | Get the size of the current thread's cache. threadCacheSize :: WeakThreadId -> IO Int@@ -314,15 +316,3 @@       cache <- readIORef cref       sum <$> mapM cacheLiveSize (HM.elems cache)     Nothing -> return 0--{---- | Dump the current thread's cache.-dumpThreadCache :: WeakThreadId -> IO ()-dumpThreadCache tid = do-  caches <- readIORef termCacheCell-  case HM.lookup tid caches of-    Just (_, cref) -> do-      cache <- readIORef cref-      mapM_ dumpCache (HM.elems cache)-    Nothing -> return ()--}

@@ -1,601 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}-{-# HLINT ignore "Eta reduce" #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE QuantifiedConstraints #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}---- |--- Module      :   Grisette.Internal.SymPrim.Prim.Internal.Instances.BVPEval--- 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.BVPEval () where--import Data.Kind (Type)-import Data.Maybe (isJust)-import Data.Proxy (Proxy (Proxy))-import qualified Data.SBV as SBV-import Data.Typeable (Typeable, type (:~:) (Refl))-import GHC.TypeNats (KnownNat, Nat, natVal, sameNat, type (+), type (-), type (<=))-import Grisette.Internal.Core.Data.Class.BitVector-  ( SizedBV-      ( sizedBVConcat,-        sizedBVFromIntegral,-        sizedBVSelect,-        sizedBVSext,-        sizedBVZext-      ),-  )-import Grisette.Internal.SymPrim.BV (IntN, WordN)-import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalBitCastTerm (doPevalBitCast)-import Grisette.Internal.SymPrim.Prim.Internal.Instances.SupportedPrim-  ( bvIsNonZeroFromGEq1,-  )-import Grisette.Internal.SymPrim.Prim.Internal.Term-  ( PEvalBVTerm-      ( pevalBVConcatTerm,-        pevalBVExtendTerm,-        pevalBVSelectTerm,-        sbvBVConcatTerm,-        sbvBVExtendTerm,-        sbvBVSelectTerm-      ),-    PEvalBitCastTerm (pevalBitCastTerm, sbvBitCast),-    SupportedPrim,-    Term-      ( BVConcatTerm,-        BVExtendTerm,-        BVSelectTerm,-        BitCastTerm,-        ConTerm-      ),-    bitCastTerm,-    bvConcatTerm,-    bvExtendTerm,-    bvSelectTerm,-    conTerm,-    pattern DynTerm,-  )-import Grisette.Internal.SymPrim.Prim.Internal.Unfold-  ( binaryUnfoldOnce,-    unaryUnfoldOnce,-  )-import Grisette.Internal.SymPrim.Prim.TermUtils (castTerm)-import Grisette.Internal.Utils.Parameterized-  ( LeqProof (LeqProof),-    NatRepr,-    SomeNatRepr (SomeNatRepr),-    SomePositiveNatRepr (SomePositiveNatRepr),-    addNat,-    mkNatRepr,-    mkPositiveNatRepr,-    natRepr,-    unsafeAxiom,-    unsafeKnownProof,-    unsafeLeqProof,-    withKnownNat,-    withKnownProof,-  )--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)--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-  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)--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--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 _ _ = 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--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

@@ -30,17 +30,18 @@   ) import Grisette.Internal.SymPrim.BV (IntN, WordN) import Grisette.Internal.SymPrim.FP (FP, ValidFP, withValidFPProofs)-import Grisette.Internal.SymPrim.Prim.Internal.Instances.SupportedPrim () import Grisette.Internal.SymPrim.Prim.Internal.Term   ( PEvalBitCastOrTerm (pevalBitCastOrTerm, sbvBitCastOr),     PEvalBitCastTerm (pevalBitCastTerm, sbvBitCast),     SupportedPrim,-    Term (BitCastTerm, ConTerm),+    Term,     bitCastOrTerm,     bitCastTerm,     conTerm,-    introSupportedPrimConstraint,+    pattern BitCastTerm,+    pattern ConTerm,     pattern DynTerm,+    pattern SupportedTerm,   ) import Grisette.Internal.SymPrim.Prim.Internal.Unfold   ( binaryUnfoldOnce,@@ -49,14 +50,14 @@  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 (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 (ConTerm v) = Just $ conTerm $ bitCast v doPevalBitCast t = doPevalBitCastSameType t  pevalBitCastGeneral ::@@ -71,7 +72,7 @@   Term b ->   Term a ->   Maybe (Term b)-doPevalBitCastOr (ConTerm _ _ _ _ d) (ConTerm _ _ _ _ v) =+doPevalBitCastOr (ConTerm d) (ConTerm v) =   Just $ conTerm $ bitCastOr d v doPevalBitCastOr _ _ = Nothing @@ -81,9 +82,8 @@   Term b ->   Term a ->   Term b-pevalBitCastOr d a =-  introSupportedPrimConstraint d $-    binaryUnfoldOnce doPevalBitCastOr bitCastOrTerm d a+pevalBitCastOr d@SupportedTerm =+  binaryUnfoldOnce doPevalBitCastOr bitCastOrTerm d  instance PEvalBitCastTerm Bool (IntN 1) where   pevalBitCastTerm = pevalBitCastGeneral

@@ -1,118 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}--{-# HLINT ignore "Eta reduce" #-}---- |--- Module      :   Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalBitwiseTerm--- 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.PEvalBitwiseTerm () where--import Data.Bits (Bits (complement, xor, zeroBits, (.&.), (.|.)))-import GHC.TypeLits (KnownNat, type (<=))-import Grisette.Internal.SymPrim.BV (IntN, WordN)-import Grisette.Internal.SymPrim.Prim.Internal.Instances.SupportedPrim ()-import Grisette.Internal.SymPrim.Prim.Internal.Term-  ( PEvalBitwiseTerm-      ( pevalAndBitsTerm,-        pevalComplementBitsTerm,-        pevalOrBitsTerm,-        pevalXorBitsTerm,-        withSbvBitwiseTermConstraint-      ),-    SupportedPrim (withPrim),-    Term (ComplementBitsTerm, ConTerm),-    andBitsTerm,-    complementBitsTerm,-    conTerm,-    orBitsTerm,-    xorBitsTerm,-  )-import Grisette.Internal.SymPrim.Prim.Internal.Unfold-  ( binaryUnfoldOnce,-    unaryUnfoldOnce,-  )--pevalDefaultAndBitsTerm ::-  (Bits a, SupportedPrim a, PEvalBitwiseTerm a) => Term a -> Term a -> Term a-pevalDefaultAndBitsTerm = binaryUnfoldOnce doPevalAndBitsTerm andBitsTerm-  where-    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--pevalDefaultOrBitsTerm ::-  (Bits a, SupportedPrim a, PEvalBitwiseTerm a) => Term a -> Term a -> Term a-pevalDefaultOrBitsTerm = binaryUnfoldOnce doPevalOrBitsTerm orBitsTerm-  where-    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--pevalDefaultXorBitsTerm ::-  (PEvalBitwiseTerm a, SupportedPrim a, Bits a) => Term a -> Term a -> Term a-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 (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--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 _ = 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

@@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# HLINT ignore "Eta reduce" #-} {-# LANGUAGE TypeApplications #-}@@ -27,7 +28,6 @@  import GHC.TypeNats (KnownNat, type (<=)) import Grisette.Internal.SymPrim.BV (IntN, WordN)-import Grisette.Internal.SymPrim.Prim.Internal.Instances.SupportedPrim () import Grisette.Internal.SymPrim.Prim.Internal.Term   ( PEvalDivModIntegralTerm       ( pevalDivIntegralTerm,@@ -37,28 +37,28 @@         withSbvDivModIntegralTermConstraint       ),     SupportedPrim (withPrim),-    Term (ConTerm),+    Term,     conTerm,     divIntegralTerm,-    introSupportedPrimConstraint,     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 r =-  introSupportedPrimConstraint l $-    binaryUnfoldOnce doPevalDefaultDivIntegralTerm divIntegralTerm l r+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)+doPevalDefaultDivIntegralTerm (ConTerm a) (ConTerm b)   | b /= 0 = Just $ conTerm $ a `div` b-doPevalDefaultDivIntegralTerm a (ConTerm _ _ _ _ 1) = Just a+doPevalDefaultDivIntegralTerm a (ConTerm 1) = Just a doPevalDefaultDivIntegralTerm _ _ = Nothing  -- | Default partial evaluation of division operation for bounded integral@@ -68,80 +68,78 @@   Term a ->   Term a ->   Term a-pevalDefaultDivBoundedIntegralTerm l r =-  introSupportedPrimConstraint l $-    binaryUnfoldOnce doPevalDefaultDivBoundedIntegralTerm divIntegralTerm l r+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)+doPevalDefaultDivBoundedIntegralTerm (ConTerm a) (ConTerm b)   | b /= 0 && (b /= -1 || a /= minBound) = Just $ conTerm $ a `div` b-doPevalDefaultDivBoundedIntegralTerm a (ConTerm _ _ _ _ 1) = Just a+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 r =-  introSupportedPrimConstraint l $-    binaryUnfoldOnce doPevalDefaultModIntegralTerm modIntegralTerm l r+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)+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 _ (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 r =-  introSupportedPrimConstraint l $-    binaryUnfoldOnce doPevalDefaultQuotIntegralTerm quotIntegralTerm l r+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)+doPevalDefaultQuotIntegralTerm (ConTerm a) (ConTerm b)   | b /= 0 = Just $ conTerm $ a `quot` b-doPevalDefaultQuotIntegralTerm a (ConTerm _ _ _ _ 1) = Just a+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 r =-  introSupportedPrimConstraint l $-    binaryUnfoldOnce doPevalDefaultQuotBoundedIntegralTerm quotIntegralTerm l r+  (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)+doPevalDefaultQuotBoundedIntegralTerm (ConTerm a) (ConTerm b)   | b /= 0 && (b /= -1 || a /= minBound) = Just $ conTerm $ a `quot` b-doPevalDefaultQuotBoundedIntegralTerm a (ConTerm _ _ _ _ 1) = Just a+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 r =-  introSupportedPrimConstraint l $-    binaryUnfoldOnce doPevalDefaultRemIntegralTerm remIntegralTerm l r+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)+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 _ (ConTerm 1) = Just $ conTerm 0+doPevalDefaultRemIntegralTerm _ (ConTerm (-1)) = Just $ conTerm 0 doPevalDefaultRemIntegralTerm _ _ = Nothing  instance PEvalDivModIntegralTerm Integer where

@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PatternSynonyms #-}  -- | -- Module      :   Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalFP@@ -8,21 +9,7 @@ -- Maintainer  :   siruilu@cs.washington.edu -- Stability   :   Experimental -- Portability :   GHC only-module Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalFP-  ( pevalFPTraitTerm,-    sbvFPTraitTerm,-    pevalFPUnaryTerm,-    sbvFPUnaryTerm,-    pevalFPBinaryTerm,-    sbvFPBinaryTerm,-    pevalFPRoundingUnaryTerm,-    sbvFPRoundingUnaryTerm,-    pevalFPRoundingBinaryTerm,-    sbvFPRoundingBinaryTerm,-    pevalFPFMATerm,-    sbvFPFMATerm,-  )-where+module Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalFP () where  import qualified Data.SBV as SBV import Grisette.Internal.Core.Data.Class.IEEEFP@@ -43,7 +30,7 @@         fpSub       ),   )-import Grisette.Internal.SymPrim.FP (FP, FPRoundingMode, ValidFP)+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),@@ -63,8 +50,20 @@         FPIsZero       ),     FPUnaryOp (FPAbs, FPNeg),-    SupportedPrim,-    Term (ConTerm),+    PEvalFPTerm+      ( pevalFPBinaryTerm,+        pevalFPFMATerm,+        pevalFPRoundingBinaryTerm,+        pevalFPRoundingUnaryTerm,+        pevalFPTraitTerm,+        pevalFPUnaryTerm,+        sbvFPBinaryTerm,+        sbvFPFMATerm,+        sbvFPRoundingBinaryTerm,+        sbvFPRoundingUnaryTerm,+        sbvFPTraitTerm,+        sbvFPUnaryTerm+      ),     conTerm,     fpBinaryTerm,     fpFMATerm,@@ -72,120 +71,129 @@     fpRoundingUnaryTerm,     fpTraitTerm,     fpUnaryTerm,+    pattern ConTerm,   ) import Grisette.Internal.SymPrim.Prim.Internal.Unfold (unaryUnfoldOnce) --- | Partially evaluate a floating-point trait term.-pevalFPTraitTerm ::-  (ValidFP eb sb, SupportedPrim (FP eb sb)) =>-  FPTrait ->-  Term (FP eb sb) ->-  Term Bool-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+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 #-} --- Workaround for https://github.com/GaloisInc/libBF-hs/pull/32, which affects--- the correctness of the Ord instance for 'Data.SBV.FloatingPoint'.-goodFpIsPositive ::-  (ValidFP eb sb) =>-  SBV.SFloatingPoint eb sb ->-  SBV.SBool-goodFpIsPositive x =-  SBV.sNot (SBV.fpIsNaN x) SBV..&& SBV.fpIsPositive x-{-# INLINE goodFpIsPositive #-}+  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 -goodFpIsNegative ::-  (ValidFP eb sb) =>-  SBV.SFloatingPoint eb sb ->-  SBV.SBool-goodFpIsNegative x = SBV.sNot (SBV.fpIsNaN x) SBV..&& SBV.fpIsNegative x-{-# INLINE goodFpIsNegative #-}+  sbvFPUnaryTerm FPAbs = SBV.fpAbs+  sbvFPUnaryTerm FPNeg = SBV.fpNeg+  {-# INLINE sbvFPUnaryTerm #-} --- | Lowering an floating-point trait term to sbv.-sbvFPTraitTerm ::-  (ValidFP eb sb) =>-  FPTrait ->-  SBV.SFloatingPoint eb sb ->-  SBV.SBool-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+  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 #-} --- | Partially evaluate a floating-point unary term.-pevalFPUnaryTerm ::-  (ValidFP eb sb, SupportedPrim (FP eb sb)) =>-  FPUnaryOp ->-  Term (FP eb sb) ->-  Term (FP eb sb)-pevalFPUnaryTerm = fpUnaryTerm-{-# INLINE pevalFPUnaryTerm #-}+  sbvFPRoundingUnaryTerm FPSqrt = SBV.fpSqrt+  sbvFPRoundingUnaryTerm FPRoundToIntegral = SBV.fpRoundToIntegral+  {-# INLINE sbvFPRoundingUnaryTerm #-} --- | Lowering an floating-point unary term to sbv.-sbvFPUnaryTerm ::-  (ValidFP eb sb) =>-  FPUnaryOp ->-  SBV.SFloatingPoint eb sb ->-  SBV.SFloatingPoint eb sb-sbvFPUnaryTerm FPAbs = SBV.fpAbs-sbvFPUnaryTerm FPNeg = SBV.fpNeg-{-# INLINE sbvFPUnaryTerm #-}+  sbvFPRoundingBinaryTerm FPAdd = SBV.fpAdd+  sbvFPRoundingBinaryTerm FPSub = SBV.fpSub+  sbvFPRoundingBinaryTerm FPMul = SBV.fpMul+  sbvFPRoundingBinaryTerm FPDiv = SBV.fpDiv+  {-# INLINE sbvFPRoundingBinaryTerm #-} --- | Partially evaluate a floating-point binary term.-pevalFPBinaryTerm ::-  (ValidFP eb sb, SupportedPrim (FP eb sb)) =>-  FPBinaryOp ->-  Term (FP eb sb) ->-  Term (FP eb sb) ->-  Term (FP eb sb)-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 #-}+  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 ->@@ -196,111 +204,4 @@     (SBV.fpIsZero x SBV..&& SBV.fpIsZero y)     (SBV.fpIsNegativeZero x)     (x SBV..< y)---- | Lowering an floating-point binary term to sbv.-sbvFPBinaryTerm ::-  (ValidFP eb sb) =>-  FPBinaryOp ->-  SBV.SFloatingPoint eb sb ->-  SBV.SFloatingPoint eb sb ->-  SBV.SFloatingPoint eb sb-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 #-}---- | Partially evaluate a floating-point rounding unary term.-pevalFPRoundingUnaryTerm ::-  (ValidFP eb sb, SupportedPrim (FP eb sb)) =>-  FPRoundingUnaryOp ->-  Term FPRoundingMode ->-  Term (FP eb sb) ->-  Term (FP eb sb)-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 #-}---- | Lowering an floating-point rounding unary term to sbv.-sbvFPRoundingUnaryTerm ::-  (ValidFP eb sb) =>-  FPRoundingUnaryOp ->-  SBV.SRoundingMode ->-  SBV.SFloatingPoint eb sb ->-  SBV.SFloatingPoint eb sb-sbvFPRoundingUnaryTerm FPSqrt = SBV.fpSqrt-sbvFPRoundingUnaryTerm FPRoundToIntegral = SBV.fpRoundToIntegral-{-# INLINE sbvFPRoundingUnaryTerm #-}---- | Partially evaluate a floating-point rounding binary term.-pevalFPRoundingBinaryTerm ::-  (ValidFP eb sb, SupportedPrim (FP eb sb)) =>-  FPRoundingBinaryOp ->-  Term FPRoundingMode ->-  Term (FP eb sb) ->-  Term (FP eb sb) ->-  Term (FP eb sb)-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 #-}---- | Lowering an floating-point rounding binary term to sbv.-sbvFPRoundingBinaryTerm ::-  (ValidFP eb sb) =>-  FPRoundingBinaryOp ->-  SBV.SRoundingMode ->-  SBV.SFloatingPoint eb sb ->-  SBV.SFloatingPoint eb sb ->-  SBV.SFloatingPoint eb sb-sbvFPRoundingBinaryTerm FPAdd = SBV.fpAdd-sbvFPRoundingBinaryTerm FPSub = SBV.fpSub-sbvFPRoundingBinaryTerm FPMul = SBV.fpMul-sbvFPRoundingBinaryTerm FPDiv = SBV.fpDiv-{-# INLINE sbvFPRoundingBinaryTerm #-}---- | Partially evaluate a floating-point fused multiply-add term.-pevalFPFMATerm ::-  (ValidFP eb sb, SupportedPrim (FP eb sb)) =>-  Term FPRoundingMode ->-  Term (FP eb sb) ->-  Term (FP eb sb) ->-  Term (FP eb sb) ->-  Term (FP eb sb)-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 #-}---- | Lowering an floating-point fused multiply-add term to sbv.-sbvFPFMATerm ::-  (ValidFP eb sb) =>-  SBV.SRoundingMode ->-  SBV.SFloatingPoint eb sb ->-  SBV.SFloatingPoint eb sb ->-  SBV.SFloatingPoint eb sb ->-  SBV.SFloatingPoint eb sb-sbvFPFMATerm = SBV.fpFMA-{-# INLINE sbvFPFMATerm #-}+{-# INLINE sbvCmpHandleNegZero #-}

@@ -16,7 +16,6 @@  import Grisette.Internal.SymPrim.AlgReal (AlgReal) import Grisette.Internal.SymPrim.FP (FP, ValidFP)-import Grisette.Internal.SymPrim.Prim.Internal.Instances.SupportedPrim () import Grisette.Internal.SymPrim.Prim.Internal.Term   ( FloatingUnaryOp (FloatingAcosh, FloatingAsinh, FloatingAtanh, FloatingSqrt),     PEvalFloatingTerm

@@ -1,3 +1,4 @@+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-}@@ -17,7 +18,6 @@  import Grisette.Internal.SymPrim.AlgReal (AlgReal) import Grisette.Internal.SymPrim.FP (FP, ValidFP)-import Grisette.Internal.SymPrim.Prim.Internal.Instances.SupportedPrim () import Grisette.Internal.SymPrim.Prim.Internal.Term   ( PEvalFractionalTerm       ( pevalFdivTerm,@@ -25,11 +25,12 @@         withSbvFractionalTermConstraint       ),     SupportedPrim (withPrim),-    Term (ConTerm),+    Term,     conTerm,     fdivTerm,-    introSupportedPrimConstraint,     recipTerm,+    pattern ConTerm,+    pattern SupportedTerm,   ) import Grisette.Internal.SymPrim.Prim.Internal.Unfold   ( binaryUnfoldOnce,@@ -45,26 +46,24 @@  pevalDefaultFdivTerm ::   (PEvalFractionalTerm a, Eq a) => Term a -> Term a -> Term a-pevalDefaultFdivTerm l r =-  introSupportedPrimConstraint l $-    binaryUnfoldOnce doPevalDefaultFdivTerm fdivTerm l r+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)+doPevalDefaultFdivTerm (ConTerm a) (ConTerm b)   | b /= 0 = Just $ conTerm $ a / b-doPevalDefaultFdivTerm a (ConTerm _ _ _ _ 1) = Just a+doPevalDefaultFdivTerm a (ConTerm 1) = Just a doPevalDefaultFdivTerm _ _ = Nothing  pevalDefaultRecipTerm ::   (PEvalFractionalTerm a, Eq a) => Term a -> Term a-pevalDefaultRecipTerm l =-  introSupportedPrimConstraint l $-    unaryUnfoldOnce doPevalDefaultRecipTerm recipTerm l+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 (ConTerm n) | n /= 0 = Just $ conTerm $ recip n doPevalDefaultRecipTerm _ = Nothing  instance PEvalFractionalTerm AlgReal where

@@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-}@@ -24,16 +25,15 @@ 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.Instances.SupportedPrim-  ( bvIsNonZeroFromGEq1,-  ) import Grisette.Internal.SymPrim.Prim.Internal.Term   ( PEvalFromIntegralTerm (pevalFromIntegralTerm, sbvFromIntegralTerm),     SupportedNonFuncPrim (withNonFuncPrim),     SupportedPrim,-    Term (ConTerm),+    Term,+    bvIsNonZeroFromGEq1,     conTerm,     fromIntegralTerm,+    pattern ConTerm,   ) import Grisette.Internal.SymPrim.Prim.Internal.Unfold (unaryUnfoldOnce) @@ -42,7 +42,7 @@ pevalFromIntegralTermGeneric =   unaryUnfoldOnce doPEvalFromIntegralTerm fromIntegralTerm   where-    doPEvalFromIntegralTerm (ConTerm _ _ _ _ a) = Just $ conTerm $ fromIntegral a+    doPEvalFromIntegralTerm (ConTerm a) = Just $ conTerm $ fromIntegral a     doPEvalFromIntegralTerm _ = Nothing  instance PEvalFromIntegralTerm Integer Integer where

@@ -4,6 +4,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE KindSignatures #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-}@@ -50,9 +51,6 @@     FPRoundingMode (RNA, RNE, RTN, RTP, RTZ),     ValidFP,   )-import Grisette.Internal.SymPrim.Prim.Internal.Instances.SupportedPrim-  ( bvIsNonZeroFromGEq1,-  ) import Grisette.Internal.SymPrim.Prim.Internal.Term   ( PEvalIEEEFPConvertibleTerm       ( pevalFromFPOrTerm,@@ -62,10 +60,12 @@       ),     SBVRep (SBVType),     SupportedPrim (conSBVTerm),-    Term (ConTerm),+    Term,+    bvIsNonZeroFromGEq1,     conTerm,     fromFPOrTerm,     toFPTerm,+    pattern ConTerm,   ) import Grisette.Internal.SymPrim.Prim.Internal.Unfold (binaryUnfoldOnce) @@ -143,9 +143,9 @@   Term FPRoundingMode ->   Term (FP eb sb) ->   Term a-generalPevalFromFPOrTerm (ConTerm _ _ _ _ d) (ConTerm _ _ _ _ rd) (ConTerm _ _ _ _ f) =+generalPevalFromFPOrTerm (ConTerm d) (ConTerm rd) (ConTerm f) =   conTerm $ fromFPOr d rd f-generalPevalFromFPOrTerm d _ (ConTerm _ _ _ _ f) | fpIsNaN f || fpIsInfinite f = d+generalPevalFromFPOrTerm d _ (ConTerm f) | fpIsNaN f || fpIsInfinite f = d generalPevalFromFPOrTerm d rd f = fromFPOrTerm d rd f  algRealPevalFromFPOrTerm ::@@ -157,9 +157,9 @@   Term FPRoundingMode ->   Term (FP eb sb) ->   Term AlgReal-algRealPevalFromFPOrTerm (ConTerm _ _ _ _ d) _ (ConTerm _ _ _ _ f) =+algRealPevalFromFPOrTerm (ConTerm d) _ (ConTerm f) =   conTerm $ fromFPOr d RNE f-algRealPevalFromFPOrTerm d _ (ConTerm _ _ _ _ f) | fpIsNaN f || fpIsInfinite f = d+algRealPevalFromFPOrTerm d _ (ConTerm f) | fpIsNaN f || fpIsInfinite f = d algRealPevalFromFPOrTerm d _ f = fromFPOrTerm d (conTerm RNE) f  generalDoPevalToFPTerm ::@@ -170,7 +170,7 @@   Term FPRoundingMode ->   Term a ->   Maybe (Term (FP eb sb))-generalDoPevalToFPTerm (ConTerm _ _ _ _ rd) (ConTerm _ _ _ _ f) =+generalDoPevalToFPTerm (ConTerm rd) (ConTerm f) =   Just $ conTerm $ toFP rd f generalDoPevalToFPTerm _ _ = Nothing @@ -192,9 +192,9 @@   Term FPRoundingMode ->   Term (FP eb1 sb1) ->   Maybe (Term (FP eb sb))-fpDoPevalToFPTerm (ConTerm _ _ _ _ rd) (ConTerm _ _ _ _ f) =+fpDoPevalToFPTerm (ConTerm rd) (ConTerm f) =   Just $ conTerm $ toFP rd f-fpDoPevalToFPTerm _ (ConTerm _ _ _ _ f)+fpDoPevalToFPTerm _ (ConTerm f)   | fpIsNaN f = Just $ conTerm fpNaN   | fpIsPositiveInfinite f = Just $ conTerm fpPositiveInfinite   | fpIsNegativeInfinite f = Just $ conTerm fpNegativeInfinite

@@ -4,7 +4,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# HLINT ignore "Eta reduce" #-} {-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} @@ -16,20 +15,10 @@ -- Maintainer  :   siruilu@cs.washington.edu -- Stability   :   Experimental -- Portability :   GHC only-module Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalNumTerm-  ( pevalDefaultAddNumTerm,-    pevalDefaultNegNumTerm,-  )-where+module Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalNumTerm () where -import Control.Monad (msum)-import Data.Bits (Bits)-import Data.SBV (Bits (isSigned))-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.Instances.SupportedPrim () import Grisette.Internal.SymPrim.Prim.Internal.Term   ( PEvalNumTerm       ( pevalAbsNumTerm,@@ -40,194 +29,23 @@         withSbvNumTermConstraint       ),     SupportedPrim (withPrim),-    Term (AbsNumTerm, AddNumTerm, ConTerm, MulNumTerm, NegNumTerm),     absNumTerm,     addNumTerm,-    conTerm,-    introSupportedPrimConstraint,+    doPevalNoOverflowAbsNumTerm,+    doPevalNoOverflowSignumNumTerm,     mulNumTerm,     negNumTerm,-    pevalSubNumTerm,+    pevalDefaultAddNumTerm,+    pevalDefaultMulNumTerm,+    pevalDefaultNegNumTerm,     signumNumTerm,   ) import Grisette.Internal.SymPrim.Prim.Internal.Unfold-  ( binaryUnfoldOnce,-    generalBinaryUnfolded,+  ( generalBinaryUnfolded,     generalUnaryUnfolded,     unaryUnfoldOnce,   ) --- | Default partial evaluation of addition of numerical terms.-pevalDefaultAddNumTerm :: (PEvalNumTerm a, Eq a) => Term a -> Term a -> Term a-pevalDefaultAddNumTerm l r =-  introSupportedPrimConstraint l $-    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 =-  introSupportedPrimConstraint l $-    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-pevalDefaultMulNumTerm :: (PEvalNumTerm a, Eq a) => Term a -> Term a -> Term a-pevalDefaultMulNumTerm l r =-  introSupportedPrimConstraint l $-    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-pevalBitsAbsNumTerm :: (PEvalNumTerm a, Bits a) => Term a -> Term a-pevalBitsAbsNumTerm l =-  introSupportedPrimConstraint l $-    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-    ]--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--pevalGeneralSignumNumTerm :: (PEvalNumTerm a) => Term a -> Term a-pevalGeneralSignumNumTerm l =-  introSupportedPrimConstraint l $-    unaryUnfoldOnce doPevalGeneralSignumNumTerm signumNumTerm l--doPevalGeneralSignumNumTerm :: (PEvalNumTerm a) => Term a -> Maybe (Term a)-doPevalGeneralSignumNumTerm (ConTerm _ _ _ _ a) = Just $ conTerm $ signum a-doPevalGeneralSignumNumTerm _ = Nothing--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 PEvalNumTerm Integer where   pevalAddNumTerm = pevalDefaultAddNumTerm   pevalNegNumTerm = pevalDefaultNegNumTerm@@ -236,22 +54,6 @@   pevalSignumNumTerm =     unaryUnfoldOnce doPevalNoOverflowSignumNumTerm signumNumTerm   withSbvNumTermConstraint r = r--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  instance (ValidFP eb sb) => PEvalNumTerm (FP eb sb) where   pevalAddNumTerm = generalBinaryUnfolded (+) addNumTerm

@@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-}@@ -44,11 +45,13 @@         withSbvOrdTermConstraint       ),     SupportedPrim (conSBVTerm, withPrim),-    Term (AddNumTerm, ConTerm),+    Term,     conTerm,     leOrdTerm,     ltOrdTerm,     pevalSubNumTerm,+    pattern AddNumTerm,+    pattern ConTerm,   ) import Grisette.Internal.SymPrim.Prim.Internal.Unfold (binaryUnfoldOnce) @@ -58,7 +61,7 @@  doPevalGeneralLtOrdTerm ::   (PEvalOrdTerm a, Ord a) => Term a -> Term a -> Maybe (Term Bool)-doPevalGeneralLtOrdTerm (ConTerm _ _ _ _ a) (ConTerm _ _ _ _ b) = Just $ conTerm $ a < b+doPevalGeneralLtOrdTerm (ConTerm a) (ConTerm b) = Just $ conTerm $ a < b doPevalGeneralLtOrdTerm _ _ = Nothing  -- | General partially evaluation of less than or equal to operation.@@ -67,7 +70,7 @@  doPevalGeneralLeOrdTerm ::   (PEvalOrdTerm a, Ord a) => Term a -> Term a -> Maybe (Term Bool)-doPevalGeneralLeOrdTerm (ConTerm _ _ _ _ a) (ConTerm _ _ _ _ b) = Just $ conTerm $ a <= b+doPevalGeneralLeOrdTerm (ConTerm a) (ConTerm b) = Just $ conTerm $ a <= b doPevalGeneralLeOrdTerm _ _ = Nothing  instance PEvalOrdTerm Integer where@@ -77,18 +80,18 @@         msum           [ doPevalGeneralLtOrdTerm l r,             case (l, r) of-              (ConTerm _ _ _ _ l, AddNumTerm _ _ _ _ (ConTerm _ _ _ _ j) k) ->+              (ConTerm l, AddNumTerm (ConTerm j) k) ->                 Just $ pevalLtOrdTerm (conTerm $ l - j) k-              (AddNumTerm _ _ _ _ (ConTerm _ _ _ _ i) j, ConTerm _ _ _ _ k) ->+              (AddNumTerm (ConTerm i) j, ConTerm k) ->                 Just $ pevalLtOrdTerm j (conTerm $ k - i)-              ((AddNumTerm _ _ _ _ (ConTerm _ _ _ _ j) k), l) ->+              ((AddNumTerm (ConTerm j) k), l) ->                 Just $                   pevalLtOrdTerm                     (conTerm j)                     (pevalSubNumTerm l k)-              (j, (AddNumTerm _ _ _ _ (ConTerm _ _ _ _ k) l)) ->+              (j, (AddNumTerm (ConTerm k) l)) ->                 Just $ pevalLtOrdTerm (conTerm $ -k) (pevalSubNumTerm l j)-              (l, ConTerm _ _ _ _ r) ->+              (l, ConTerm r) ->                 Just $ pevalLtOrdTerm (conTerm $ -r) (pevalNegNumTerm l)               _ -> Nothing           ]@@ -98,15 +101,15 @@         msum           [ doPevalGeneralLeOrdTerm l r,             case (l, r) of-              (ConTerm _ _ _ _ l, AddNumTerm _ _ _ _ (ConTerm _ _ _ _ j) k) ->+              (ConTerm l, AddNumTerm (ConTerm j) k) ->                 Just $ pevalLeOrdTerm (conTerm $ l - j) k-              (AddNumTerm _ _ _ _ (ConTerm _ _ _ _ i) j, ConTerm _ _ _ _ k) ->+              (AddNumTerm (ConTerm i) j, ConTerm k) ->                 Just $ pevalLeOrdTerm j (conTerm $ k - i)-              (AddNumTerm _ _ _ _ (ConTerm _ _ _ _ j) k, l) ->+              (AddNumTerm (ConTerm j) k, l) ->                 Just $ pevalLeOrdTerm (conTerm j) (pevalSubNumTerm l k)-              (j, AddNumTerm _ _ _ _ (ConTerm _ _ _ _ k) l) ->+              (j, AddNumTerm (ConTerm k) l) ->                 Just $ pevalLeOrdTerm (conTerm $ -k) (pevalSubNumTerm l j)-              (l, ConTerm _ _ _ _ r) ->+              (l, ConTerm r) ->                 Just $ pevalLeOrdTerm (conTerm $ -r) (pevalNegNumTerm l)               _ -> Nothing           ]@@ -136,9 +139,9 @@   [ ( conSBVTerm @FPRoundingMode a,       conSBVTerm @FPRoundingMode b     )-    | a <- allFPRoundingMode,-      b <- allFPRoundingMode,-      a < b+  | a <- allFPRoundingMode,+    b <- allFPRoundingMode,+    a < b   ]  fpRoundingModeLeTable :: [(SBV.SRoundingMode, SBV.SRoundingMode)]@@ -146,9 +149,9 @@   [ ( conSBVTerm @FPRoundingMode a,       conSBVTerm @FPRoundingMode b     )-    | a <- allFPRoundingMode,-      b <- allFPRoundingMode,-      a <= b+  | a <- allFPRoundingMode,+    b <- allFPRoundingMode,+    a <= b   ]  sbvTableLookup ::

@@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}@@ -26,7 +27,6 @@ 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.Instances.SupportedPrim (bvIsNonZeroFromGEq1) import Grisette.Internal.SymPrim.Prim.Internal.Term   ( PEvalRotateTerm       ( pevalRotateLeftTerm,@@ -36,11 +36,13 @@         withSbvRotateTermConstraint       ),     SupportedNonFuncPrim (withNonFuncPrim),-    Term (ConTerm),+    Term,+    bvIsNonZeroFromGEq1,     conTerm,-    introSupportedPrimConstraint,     rotateLeftTerm,     rotateRightTerm,+    pattern ConTerm,+    pattern SupportedTerm,   ) import Grisette.Internal.SymPrim.Prim.Internal.Unfold (unaryUnfoldOnce) @@ -51,12 +53,11 @@   Term a ->   Term a ->   Term a-pevalFiniteBitsSymRotateRotateLeftTerm t n =-  introSupportedPrimConstraint t $-    unaryUnfoldOnce-      (`doPevalFiniteBitsSymRotateRotateLeftTerm` n)-      (`rotateLeftTerm` n)-      t+pevalFiniteBitsSymRotateRotateLeftTerm t@SupportedTerm n =+  unaryUnfoldOnce+    (`doPevalFiniteBitsSymRotateRotateLeftTerm` n)+    (`rotateLeftTerm` n)+    t  doPevalFiniteBitsSymRotateRotateLeftTerm ::   forall a.@@ -64,12 +65,12 @@   Term a ->   Term a ->   Maybe (Term a)-doPevalFiniteBitsSymRotateRotateLeftTerm (ConTerm _ _ _ _ a) (ConTerm _ _ _ _ n)+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)+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)+doPevalFiniteBitsSymRotateRotateLeftTerm x (ConTerm n)   | n >= 0 && (fromIntegral n :: Integer) >= fromIntegral bs =       Just $         pevalFiniteBitsSymRotateRotateLeftTerm@@ -86,12 +87,11 @@   Term a ->   Term a ->   Term a-pevalFiniteBitsSymRotateRotateRightTerm t n =-  introSupportedPrimConstraint t $-    unaryUnfoldOnce-      (`doPevalFiniteBitsSymRotateRotateRightTerm` n)-      (`rotateRightTerm` n)-      t+pevalFiniteBitsSymRotateRotateRightTerm t@SupportedTerm n =+  unaryUnfoldOnce+    (`doPevalFiniteBitsSymRotateRotateRightTerm` n)+    (`rotateRightTerm` n)+    t  doPevalFiniteBitsSymRotateRotateRightTerm ::   forall a.@@ -99,7 +99,7 @@   Term a ->   Term a ->   Maybe (Term a)-doPevalFiniteBitsSymRotateRotateRightTerm (ConTerm _ _ _ _ a) (ConTerm _ _ _ _ n)+doPevalFiniteBitsSymRotateRotateRightTerm (ConTerm a) (ConTerm n)   | n >= 0 =       Just . conTerm $         rotateR@@ -108,10 +108,10 @@               (fromIntegral n :: Integer)                 `mod` fromIntegral (finiteBitSize n)           )-doPevalFiniteBitsSymRotateRotateRightTerm x (ConTerm _ _ _ _ 0) = Just x--- doPevalFiniteBitsSymRotateRotateRightTerm (RotateRightTerm _ x (ConTerm _ _ _ _ n)) (ConTerm _ _ _ _ n1)+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)+doPevalFiniteBitsSymRotateRotateRightTerm x (ConTerm n)   | n >= 0 && (fromIntegral n :: Integer) >= fromIntegral bs =       Just $         pevalFiniteBitsSymRotateRotateRightTerm

@@ -1,5 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}@@ -22,91 +24,179 @@  import Data.Bits (Bits (isSigned, shiftR, zeroBits), FiniteBits (finiteBitSize)) import Data.Proxy (Proxy (Proxy))-import GHC.TypeLits (KnownNat, type (<=))+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.Instances.SupportedPrim (bvIsNonZeroFromGEq1) import Grisette.Internal.SymPrim.Prim.Internal.Term-  ( PEvalShiftTerm (pevalShiftLeftTerm, pevalShiftRightTerm, withSbvShiftTermConstraint),+  ( PEvalBVTerm (pevalBVConcatTerm, pevalBVExtendTerm),+    PEvalShiftTerm+      ( pevalShiftLeftTerm,+        pevalShiftRightTerm,+        withSbvShiftTermConstraint+      ),     SupportedNonFuncPrim (withNonFuncPrim),     SupportedPrim,-    Term (ConTerm),+    Term,+    bvIsNonZeroFromGEq1,     conTerm,-    introSupportedPrimConstraint,     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 a.-  (Integral a, SymShift a, FiniteBits a, PEvalShiftTerm a) =>-  Term a ->-  Term a ->-  Term a-pevalFiniteBitsSymShiftShiftLeftTerm t n =-  introSupportedPrimConstraint t $-    unaryUnfoldOnce-      (`doPevalFiniteBitsSymShiftShiftLeftTerm` n)-      (`shiftLeftTerm` n)-      t+  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 a.-  (Integral a, SymShift a, FiniteBits a, SupportedPrim a) =>-  Term a ->-  Term a ->-  Maybe (Term a)-doPevalFiniteBitsSymShiftShiftLeftTerm (ConTerm _ _ _ _ a) (ConTerm _ _ _ _ n)+  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+doPevalFiniteBitsSymShiftShiftLeftTerm x (ConTerm 0) = Just x -- TODO: Need to handle the overflow case.--- doPevalShiftLeftTerm (ShiftLeftTerm _ x (ConTerm _ _ _ _ n)) (ConTerm _ _ _ _ n1)+-- 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) =+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 a.-  (Integral a, SymShift a, FiniteBits a, PEvalShiftTerm a) =>-  Term a ->-  Term a ->-  Term a-pevalFiniteBitsSymShiftShiftRightTerm t n =-  introSupportedPrimConstraint t $-    unaryUnfoldOnce-      (`doPevalFiniteBitsSymShiftShiftRightTerm` n)-      (`shiftRightTerm` n)-      t+  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 a.-  (Integral a, SymShift a, FiniteBits a, SupportedPrim a) =>-  Term a ->-  Term a ->-  Maybe (Term a)-doPevalFiniteBitsSymShiftShiftRightTerm (ConTerm _ _ _ _ a) (ConTerm _ _ _ _ n)+  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)+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)+doPevalFiniteBitsSymShiftShiftRightTerm x (ConTerm 0) = Just x+-- doPevalFiniteBitsSymShiftShiftRightTerm (ShiftRightTerm _ x (ConTerm  n)) (ConTerm  n1) --   | n >= 0 && n1 >= 0 = Just $ pevalFiniteBitsSymShiftShiftRightTerm x (conTerm $ n + n1)-doPevalFiniteBitsSymShiftShiftRightTerm _ (ConTerm _ _ _ _ n)-  | not (isSigned n)-      && (fromIntegral n :: Integer) >= fromIntegral (finiteBitSize n) =+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

@@ -1,413 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE InstanceSigs #-}-{-# HLINT ignore "Eta reduce" #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}---- |--- Module      :   Grisette.Internal.SymPrim.Prim.Internal.Instances.SupportedPrim--- 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.SupportedPrim-  ( bvIsNonZeroFromGEq1,-  )-where--import Data.Coerce (coerce)-import Data.Hashable (Hashable (hashWithSalt))-import Data.List.NonEmpty (NonEmpty ((:|)), toList)-import Data.Proxy (Proxy (Proxy))-import Data.SBV (BVIsNonZero)-import qualified Data.SBV as SBV-import Data.Type.Equality ((:~:) (Refl), type (:~~:) (HRefl))-import GHC.TypeNats (KnownNat, type (<=))-import Grisette.Internal.Core.Data.Class.IEEEFP-  ( fpIsNegativeZero,-    fpIsPositiveZero,-  )-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.Term-  ( IsSymbolKind (decideSymbolKind),-    NonFuncSBVRep (NonFuncSBVBaseType),-    SBVRep-      ( SBVType-      ),-    SupportedNonFuncPrim-      ( conNonFuncSBVTerm,-        symNonFuncSBVTerm,-        withNonFuncPrim-      ),-    SupportedPrim-      ( castTypedSymbol,-        conSBVTerm,-        defaultValue,-        funcDummyConstraint,-        hashConWithSalt,-        parseSMTModelResult,-        pevalDistinctTerm,-        pevalEqTerm,-        pevalITETerm,-        pformatCon,-        sameCon,-        sbvDistinct,-        sbvEq,-        sbvIte,-        symSBVName,-        symSBVTerm,-        withPrim-      ),-    SupportedPrimConstraint-      ( PrimConstraint-      ),-    Term (ConTerm),-    TypedSymbol (unTypedSymbol),-    conTerm,-    distinctTerm,-    eqTerm,-    parseScalarSMTModelResult,-    pevalDefaultEqTerm,-    pevalITEBasicTerm,-    pevalNotTerm,-    sbvFresh,-    typedAnySymbol,-    typedConstantSymbol,-  )-import Grisette.Internal.Utils.Parameterized (unsafeAxiom)--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---- 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 = pevalITEBasicTerm-  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 = pevalITEBasicTerm-  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.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

@@ -57,9 +57,7 @@   ) import Grisette.Internal.SymPrim.GeneralFun (type (-->) (GeneralFun)) import Grisette.Internal.SymPrim.Prim.Internal.Caches (Id)-import Grisette.Internal.SymPrim.Prim.Internal.Instances.BVPEval () import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalBitCastTerm ()-import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalBitwiseTerm () import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalDivModIntegralTerm () import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalFloatingTerm () import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalFractionalTerm ()@@ -69,7 +67,6 @@ 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.Instances.SupportedPrim () import Grisette.Internal.SymPrim.Prim.Internal.Term   ( FPBinaryOp,     FPRoundingBinaryOp,@@ -93,56 +90,7 @@     SomeTypedSymbol (SomeTypedSymbol),     SupportedNonFuncPrim,     SupportedPrim (primTypeRep, withPrim),-    Term-      ( AbsNumTerm,-        AddNumTerm,-        AndBitsTerm,-        AndTerm,-        ApplyTerm,-        BVConcatTerm,-        BVExtendTerm,-        BVSelectTerm,-        BitCastOrTerm,-        BitCastTerm,-        ComplementBitsTerm,-        ConTerm,-        DistinctTerm,-        DivIntegralTerm,-        EqTerm,-        ExistsTerm,-        FPBinaryTerm,-        FPFMATerm,-        FPRoundingBinaryTerm,-        FPRoundingUnaryTerm,-        FPTraitTerm,-        FPUnaryTerm,-        FdivTerm,-        FloatingUnaryTerm,-        ForallTerm,-        FromFPOrTerm,-        FromIntegralTerm,-        ITETerm,-        LeOrdTerm,-        LtOrdTerm,-        ModIntegralTerm,-        MulNumTerm,-        NegNumTerm,-        NotTerm,-        OrBitsTerm,-        OrTerm,-        PowerTerm,-        QuotIntegralTerm,-        RecipTerm,-        RemIntegralTerm,-        RotateLeftTerm,-        RotateRightTerm,-        ShiftLeftTerm,-        ShiftRightTerm,-        SignumNumTerm,-        SymTerm,-        ToFPTerm,-        XorBitsTerm-      ),+    Term,     TypedAnySymbol,     TypedConstantSymbol,     TypedSymbol (TypedSymbol),@@ -173,7 +121,6 @@     fpUnaryTerm,     fromFPOrTerm,     fromIntegralTerm,-    introSupportedPrimConstraint,     iteTerm,     leOrdTerm,     ltOrdTerm,@@ -196,8 +143,56 @@     symTerm,     termId,     toFPTerm,-    withSupportedPrimTypeable,     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),@@ -900,11 +895,10 @@   f $ t :| fmap (unsafeCastTerm t) ts   where     unsafeCastTerm :: Term a -> SomeTerm -> Term a-    unsafeCastTerm t (SomeTerm b) =-      introSupportedPrimConstraint t $-        case castTerm b of-          Just r -> r-          Nothing -> error "asSameTypeNonEmptyTermList: type mismatch"+    unsafeCastTerm _ (SomeTerm b) =+      case castTerm b of+        Just r -> r+        Nothing -> error "asSameTypeNonEmptyTermList: type mismatch"  asNumTypeTerm ::   (HasCallStack) =>@@ -1043,11 +1037,10 @@  asSameType ::   (HasCallStack) => Term a -> SomeTerm -> (Term a -> r) -> r-asSameType (t1 :: Term a) (SomeTerm (t2 :: Term b)) f =-  introSupportedPrimConstraint t1 $-    case eqTypeRep (primTypeRep @a) (primTypeRep @b) of-      Just HRefl -> f t2-      Nothing -> error "asSameType: type mismatch"+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@@ -1302,39 +1295,37 @@   Term a ->   KnownType ->   SomeTerm-constructFromIntegralTerm' ta retType =+constructFromIntegralTerm' ta@SupportedTerm retType =   case witnessKnownType retType of     KnownTypeWitness (_ :: Proxy b) -> do       let tb = primTypeRep @b-      introSupportedPrimConstraint ta $-        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+      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 =-      introSupportedPrimConstraint ta $-        error $-          "constructFromIntegralTerm: unsupported type: "-            <> show (primTypeRep @a)-            <> show retType+      error $+        "constructFromIntegralTerm: unsupported type: "+          <> show (primTypeRep @a)+          <> show retType  constructFromIntegralTerm ::   (HasCallStack) => SomeTerm -> KnownType -> SomeTerm@@ -1356,7 +1347,7 @@     err = error $ "constructFromIntegralTerm: unsupported type: " <> show tra  knownTypeTermId :: Term a -> (KnownType, Id)-knownTypeTermId t = introSupportedPrimConstraint t (knownType t, termId t)+knownTypeTermId t@SupportedTerm = (knownType t, termId t)  statefulDeserializeSomeTerm ::   (MonadGet m) =>@@ -1659,7 +1650,7 @@     then return ()     else do       case tm of-        ConTerm _ _ _ _ (v :: v) -> do+        ConTerm (v :: v) -> do           serialize ktTmId           putWord8 conTermTag           let kt = knownType (Proxy @v)@@ -1672,100 +1663,100 @@                 Nothing ->                   error                     "serializeSingleSomeTerm: should not happen: type mismatch"-        SymTerm _ _ _ _ (v :: TypedAnySymbol v) -> do+        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+        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+        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 ->+        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 ->+        ShiftLeftTerm t1 t2 ->           serializeBinary ktTmId shiftLeftTermTag t1 t2-        ShiftRightTerm _ _ _ _ t1 t2 ->+        ShiftRightTerm t1 t2 ->           serializeBinary ktTmId shiftRightTermTag t1 t2-        RotateLeftTerm _ _ _ _ t1 t2 ->+        RotateLeftTerm t1 t2 ->           serializeBinary ktTmId rotateLeftTermTag t1 t2-        RotateRightTerm _ _ _ _ t1 t2 ->+        RotateRightTerm t1 t2 ->           serializeBinary ktTmId rotateRightTermTag t1 t2-        BitCastTerm _ _ _ _ t -> do+        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+        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+        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 ->+        ApplyTerm f ts -> serializeBinary ktTmId applyTermTag f ts+        DivIntegralTerm t1 t2 ->           serializeBinary ktTmId divIntegralTermTag t1 t2-        ModIntegralTerm _ _ _ _ t1 t2 ->+        ModIntegralTerm t1 t2 ->           serializeBinary ktTmId modIntegralTermTag t1 t2-        QuotIntegralTerm _ _ _ _ t1 t2 ->+        QuotIntegralTerm t1 t2 ->           serializeBinary ktTmId quotIntegralTermTag t1 t2-        RemIntegralTerm _ _ _ _ t1 t2 ->+        RemIntegralTerm t1 t2 ->           serializeBinary ktTmId remIntegralTermTag t1 t2-        FPTraitTerm _ _ _ _ trait t -> do+        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+        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+        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+        FPBinaryTerm op t1 t2 -> do           serializeSingleSomeTerm $ someTerm t1           serializeSingleSomeTerm $ someTerm t2           serialize ktTmId@@ -1773,7 +1764,7 @@           serialize op           serialize $ knownTypeTermId t1           serialize $ knownTypeTermId t2-        FPRoundingUnaryTerm _ _ _ _ op rd t -> do+        FPRoundingUnaryTerm op rd t -> do           serializeSingleSomeTerm $ someTerm rd           serializeSingleSomeTerm $ someTerm t           serialize ktTmId@@ -1781,7 +1772,7 @@           serialize op           serialize $ knownTypeTermId rd           serialize $ knownTypeTermId t-        FPRoundingBinaryTerm _ _ _ _ op rd t1 t2 -> do+        FPRoundingBinaryTerm op rd t1 t2 -> do           serializeSingleSomeTerm $ someTerm rd           serializeSingleSomeTerm $ someTerm t1           serializeSingleSomeTerm $ someTerm t2@@ -1791,7 +1782,7 @@           serialize $ knownTypeTermId rd           serialize $ knownTypeTermId t1           serialize $ knownTypeTermId t2-        FPFMATerm _ _ _ _ rd t1 t2 t3 -> do+        FPFMATerm rd t1 t2 t3 -> do           serializeSingleSomeTerm $ someTerm rd           serializeSingleSomeTerm $ someTerm t1           serializeSingleSomeTerm $ someTerm t2@@ -1802,16 +1793,16 @@           serialize $ knownTypeTermId t1           serialize $ knownTypeTermId t2           serialize $ knownTypeTermId t3-        FromIntegralTerm _ _ _ _ t -> do+        FromIntegralTerm t -> do           serializeSingleSomeTerm $ someTerm t           serialize ktTmId           serialize fromIntegralTermTag           let kt = knownType (Proxy @t)           serializeKnownType kt           serialize $ knownTypeTermId t-        FromFPOrTerm _ _ _ _ d rd t ->+        FromFPOrTerm d rd t ->           serializeTernary ktTmId fromFPOrTermTag d rd t-        ToFPTerm _ _ _ _ rd t eb sb -> do+        ToFPTerm rd t eb sb -> do           serializeSingleSomeTerm $ someTerm rd           serializeSingleSomeTerm $ someTerm t           serialize ktTmId@@ -1879,7 +1870,7 @@   serialize = serializeSomeTerm . someTerm   deserialize = do     SomeTerm tm <- deserialize-    withSupportedPrimTypeable @a $ case castTerm tm of+    case castTerm tm of       Just r -> return r       Nothing -> fail "deserialize Term: type mismatch"