grisette 0.8.0.0 → 0.9.0.0

raw patch · 112 files changed

+12994/−5316 lines, 112 filesdep +atomic-primopsdep +binarydep +bytesdep −hashtablesdep −interndep ~sbvdep ~unordered-containersPVP ok

version bump matches the API change (PVP)

Dependencies added: atomic-primops, binary, bytes, cereal, cereal-text, vector

Dependencies removed: hashtables, intern

Dependency ranges changed: sbv, unordered-containers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +50/−1
• README.md +1/−1
• grisette.cabal +35/−16
• src/Grisette/Core.hs +38/−8
• src/Grisette/Internal/Backend/QuantifiedStack.hs +14/−1
• src/Grisette/Internal/Backend/Solving.hs +348/−342
• src/Grisette/Internal/Backend/SymBiMap.hs +44/−32
• src/Grisette/Internal/Core/Control/Monad/Union.hs +26/−2
• src/Grisette/Internal/Core/Data/Class/CEGISSolver.hs +54/−12
• src/Grisette/Internal/Core/Data/Class/EvalSym.hs +8/−5
• src/Grisette/Internal/Core/Data/Class/ExtractSym.hs +10/−7
• src/Grisette/Internal/Core/Data/Class/Function.hs +8/−0
• src/Grisette/Internal/Core/Data/Class/GenSym.hs +33/−15
• src/Grisette/Internal/Core/Data/Class/ITEOp.hs +23/−5
• src/Grisette/Internal/Core/Data/Class/Mergeable.hs +16/−10
• src/Grisette/Internal/Core/Data/Class/ModelOps.hs +6/−6
• src/Grisette/Internal/Core/Data/Class/PPrint.hs +27/−7
• src/Grisette/Internal/Core/Data/Class/SimpleMergeable.hs +5/−7
• src/Grisette/Internal/Core/Data/Class/Solvable.hs +8/−7
• src/Grisette/Internal/Core/Data/Class/Solver.hs +25/−8
• src/Grisette/Internal/Core/Data/Class/SubstSym.hs +39/−13
• src/Grisette/Internal/Core/Data/Class/SymEq.hs +5/−0
• src/Grisette/Internal/Core/Data/Class/SymOrd.hs +7/−0
• src/Grisette/Internal/Core/Data/Class/ToCon.hs +39/−16
• src/Grisette/Internal/Core/Data/Class/ToSym.hs +20/−1
• src/Grisette/Internal/Core/Data/MemoUtils.hs +154/−11
• src/Grisette/Internal/Core/Data/SExpr.hs +88/−0
• src/Grisette/Internal/Core/Data/Symbol.hs +73/−123
• src/Grisette/Internal/Core/Data/UnionBase.hs +34/−6
• src/Grisette/Internal/SymPrim/AlgReal.hs +36/−2
• src/Grisette/Internal/SymPrim/AllSyms.hs +5/−0
• src/Grisette/Internal/SymPrim/BV.hs +37/−1
• src/Grisette/Internal/SymPrim/FP.hs +79/−3
• src/Grisette/Internal/SymPrim/FunInstanceGen.hs +27/−11
• src/Grisette/Internal/SymPrim/GeneralFun.hs +225/−109
• src/Grisette/Internal/SymPrim/ModelRep.hs +2/−2
• src/Grisette/Internal/SymPrim/Prim/Internal/Caches.hs +299/−29
• src/Grisette/Internal/SymPrim/Prim/Internal/Instances/BVPEval.hs +55/−38
• src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalBitCastTerm.hs +18/−12
• src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalBitwiseTerm.hs +16/−15
• src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalDivModIntegralTerm.hs +48/−38
• src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalFP.hs +13/−9
• src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalFractionalTerm.hs +14/−10
• src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalFromIntegralTerm.hs +8/−2
• src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalIEEEFPConvertibleTerm.hs +19/−12
• src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalNumTerm.hs +73/−61
• src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalOrdTerm.hs +16/−16
• src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalRotateTerm.hs +26/−17
• src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalShiftTerm.hs +20/−17
• src/Grisette/Internal/SymPrim/Prim/Internal/Instances/SupportedPrim.hs +71/−41
• src/Grisette/Internal/SymPrim/Prim/Internal/Serialize.hs +2205/−0
• src/Grisette/Internal/SymPrim/Prim/Internal/Term.hs +5536/−3174
• src/Grisette/Internal/SymPrim/Prim/Internal/Unfold.hs +10/−10
• src/Grisette/Internal/SymPrim/Prim/Internal/Utils.hs +149/−0
• src/Grisette/Internal/SymPrim/Prim/Model.hs +53/−23
• src/Grisette/Internal/SymPrim/Prim/ModelValue.hs +0/−55
• src/Grisette/Internal/SymPrim/Prim/SomeTerm.hs +25/−8
• src/Grisette/Internal/SymPrim/Prim/Term.hs +1/−0
• src/Grisette/Internal/SymPrim/Prim/TermUtils.hs +141/−164
• src/Grisette/Internal/SymPrim/Quantifier.hs +2/−3
• src/Grisette/Internal/SymPrim/SomeBV.hs +44/−1
• src/Grisette/Internal/SymPrim/SymAlgReal.hs +18/−2
• src/Grisette/Internal/SymPrim/SymBV.hs +30/−2
• src/Grisette/Internal/SymPrim/SymBool.hs +19/−3
• src/Grisette/Internal/SymPrim/SymFP.hs +20/−4
• src/Grisette/Internal/SymPrim/SymGeneralFun.hs +56/−41
• src/Grisette/Internal/SymPrim/SymInteger.hs +18/−2
• src/Grisette/Internal/SymPrim/SymTabularFun.hs +58/−41
• src/Grisette/Internal/SymPrim/TabularFun.hs +26/−6
• src/Grisette/Internal/TH/DerivePredefined.hs +9/−32
• src/Grisette/Internal/Utils/Parameterized.hs +50/−1
• src/Grisette/SymPrim.hs +4/−0
• src/Grisette/Unified.hs +48/−4
• src/Grisette/Unified/Internal/BaseConstraint.hs +2/−0
• src/Grisette/Unified/Internal/Class/UnifiedSymEq.hs +9/−0
• src/Grisette/Unified/Internal/Class/UnifiedSymOrd.hs +9/−0
• src/Grisette/Unified/Internal/EvalMode.hs +230/−21
• src/Grisette/Unified/Internal/MonadWithMode.hs +0/−33
• src/Grisette/Unified/Internal/Theories.hs +28/−0
• src/Grisette/Unified/Internal/UnifiedData.hs +2/−0
• src/Grisette/Unified/Internal/UnifiedFun.hs +359/−0
• src/Grisette/Unified/Internal/Util.hs +1/−0
• src/Grisette/Unified/Lib/Control/Monad.hs +21/−6
• src/Grisette/Unified/Lib/Data/Foldable.hs +44/−17
• test/Grisette/Backend/CEGISTests.hs +46/−2
• test/Grisette/Backend/LoweringTests.hs +56/−48
• test/Grisette/Backend/TermRewritingGen.hs +29/−71
• test/Grisette/Backend/TermRewritingTests.hs +37/−5
• test/Grisette/Core/Data/Class/EvalSymTests.hs +14/−4
• test/Grisette/Core/Data/Class/ExtractSymTests.hs +9/−2
• test/Grisette/Core/Data/Class/GenSymTests.hs +10/−7
• test/Grisette/Core/Data/Class/SafeSymRotateTests.hs +4/−5
• test/Grisette/Core/Data/Class/SafeSymShiftTests.hs +4/−5
• test/Grisette/Core/Data/Class/SymRotateTests.hs +2/−3
• test/Grisette/Core/Data/Class/SymShiftTests.hs +2/−3
• test/Grisette/Core/Data/Class/TestValues.hs +3/−3
• test/Grisette/SymPrim/BVTests.hs +8/−0
• test/Grisette/SymPrim/FPTests.hs +10/−1
• test/Grisette/SymPrim/GeneralFunTests.hs +70/−6
• test/Grisette/SymPrim/Prim/BVTests.hs +137/−133
• test/Grisette/SymPrim/Prim/BitsTests.hs +2/−2
• test/Grisette/SymPrim/Prim/BoolTests.hs +201/−201
• test/Grisette/SymPrim/Prim/ConcurrentTests.hs +50/−0
• test/Grisette/SymPrim/Prim/IntegralTests.hs +5/−4
• test/Grisette/SymPrim/Prim/ModelTests.hs +1/−1
• test/Grisette/SymPrim/Prim/SerializationTests.hs +499/−0
• test/Grisette/SymPrim/SomeBVTests.hs +18/−2
• test/Grisette/SymPrim/SymPrimTests.hs +8/−2
• test/Grisette/Unified/EvalModeTest.hs +174/−33
• test/Grisette/Unified/UnifiedClassesTest.hs +13/−5
• test/Grisette/Unified/UnifiedConstructorTest.hs +3/−3
• test/Main.hs +7/−5

@@ -6,6 +6,54 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). +## [0.9.0.0] - 2024-11-07++### Added+- Added missing instances for concrete general and tabular functions.+  ([#249](https://github.com/lsrcz/grisette/pull/249))+- Added eval mode constraint on demand.+  ([#250](https://github.com/lsrcz/grisette/pull/250))+- Added support for uninterpreted functions in unified interfaces.+  ([#250](https://github.com/lsrcz/grisette/pull/250))+- Added instances for concrete `Ratio` type.+  ([#251](https://github.com/lsrcz/grisette/pull/251))+- Added serialization for the core constructs.+  ([#253](https://github.com/lsrcz/grisette/pull/253))+- Added partial evaluation for distinct.+  ([#254](https://github.com/lsrcz/grisette/pull/254))++### Changed+- [Breaking] Moved the constraints for the general and tabular functions and+  simplified their instances declaration.+  ([#249](https://github.com/lsrcz/grisette/pull/249))+- [Breaking] Renamed `EvalMode` to `EvalModeAll`, renamed `MonadWithMode` to +  `MonadEvalModeAll`.+  ([#250](https://github.com/lsrcz/grisette/pull/250))+- Improved parallel symbolic evaluation performance.+  ([#252](https://github.com/lsrcz/grisette/pull/252))+- [Breaking] Changed the metadata for identifiers from existential arguments to+  s-expressions. ([#253](https://github.com/lsrcz/grisette/pull/253))+- [Breaking] Changed the solving/cegis results from maintaining the exception+  themselves to maintaining a textual representation of them.+  ([#253](https://github.com/lsrcz/grisette/pull/253))+- [Breaking] Changed the 'VerifierResult' type for CEGIS to allow it report that+  the verifier cannot find a counter example.+  ([#257](https://github.com/lsrcz/grisette/pull/257))++### Fixed+- Fixed memory leak within the term cache.+  ([#252](https://github.com/lsrcz/grisette/pull/252))+- Fixed printing of bv terms.+  ([#255](https://github.com/lsrcz/grisette/pull/255))+- Fixed solverGenericCEGIS and make it also return the last failing cex.+  ([#256](https://github.com/lsrcz/grisette/pull/256))+- `solverGenericCEGIS` will only rerun possible verifiers now. This will improve+  overall verification performance.+  ([#258](https://github.com/lsrcz/grisette/pull/258))+- Fixed a **critical** bug in the lowering/evalSym/extractSym where the+  intermediate states are not properly memoized.+  ([#259](https://github.com/lsrcz/grisette/pull/259))+ ## [0.8.0.0] - 2024-08-13  ### Added@@ -449,7 +497,8 @@  - Initial release for Grisette. -[Unreleased]: https://github.com/lsrcz/grisette/compare/v0.8.0.0...HEAD+[Unreleased]: https://github.com/lsrcz/grisette/compare/v0.9.0.0...HEAD+[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

@@ -49,7 +49,7 @@ ```cabal library   ...-  build-depends: grisette >= 0.8 < 0.9+  build-depends: grisette >= 0.9 < 0.10 ```  #### Quick start template with `stack new`

@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.36.1.+-- This file has been generated from package.yaml by hpack version 0.37.0. -- -- see: https://github.com/sol/hpack  name:           grisette-version:        0.8.0.0+version:        0.9.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@@ -108,6 +108,7 @@       Grisette.Internal.Core.Data.Class.ToSym       Grisette.Internal.Core.Data.Class.TryMerge       Grisette.Internal.Core.Data.MemoUtils+      Grisette.Internal.Core.Data.SExpr       Grisette.Internal.Core.Data.Symbol       Grisette.Internal.Core.Data.UnionBase       Grisette.Internal.SymPrim.AlgReal@@ -134,11 +135,11 @@       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.ModelValue       Grisette.Internal.SymPrim.Prim.SomeTerm       Grisette.Internal.SymPrim.Prim.Term       Grisette.Internal.SymPrim.Prim.TermUtils@@ -207,13 +208,14 @@       Grisette.Unified.Internal.EvalMode       Grisette.Unified.Internal.EvalModeTag       Grisette.Unified.Internal.FPFPConversion-      Grisette.Unified.Internal.MonadWithMode+      Grisette.Unified.Internal.Theories       Grisette.Unified.Internal.UnifiedAlgReal       Grisette.Unified.Internal.UnifiedBool       Grisette.Unified.Internal.UnifiedBV       Grisette.Unified.Internal.UnifiedConstraint       Grisette.Unified.Internal.UnifiedData       Grisette.Unified.Internal.UnifiedFP+      Grisette.Unified.Internal.UnifiedFun       Grisette.Unified.Internal.UnifiedInteger       Grisette.Unified.Internal.Util       Grisette.Unified.Lib.Control.Applicative@@ -226,24 +228,28 @@   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     , async >=2.2.2 && <2.3+    , atomic-primops >=0.8.3 && <0.9     , base >=4.14 && <5+    , binary >=0.8.8.0 && <0.9+    , bytes >=0.17.1 && <0.18     , bytestring >=0.10.12 && <0.13+    , cereal >=0.5.8.1 && <0.6+    , cereal-text >=0.1.0.2 && <0.2     , containers >=0.4 && <0.8     , deepseq >=1.4.4 && <1.6     , generic-deriving >=1.14.1 && <1.15     , hashable >=1.2.3 && <1.6-    , hashtables >=1.2.3.4 && <1.4-    , intern >=0.9.2 && <0.10     , 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     , prettyprinter >=1.5.0 && <1.8-    , sbv >=8.17 && <11+    , sbv >=8.17 && <12     , stm ==2.5.*     , template-haskell >=2.16 && <2.23     , text >=1.2.4.1 && <2.2@@ -251,7 +257,8 @@     , th-compat >=0.1.2 && <0.2     , th-lift-instances >=0.1.16 && <0.2     , transformers >=0.5.6 && <0.7-    , unordered-containers >=0.2.11 && <0.3+    , unordered-containers >=0.2.17 && <0.3+    , vector >=0.12.1.2 && <0.14   default-language: Haskell2010   if flag(optimize)     ghc-options: -O2@@ -266,26 +273,30 @@   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     , async >=2.2.2 && <2.3+    , atomic-primops >=0.8.3 && <0.9     , base >=4.14 && <5+    , binary >=0.8.8.0 && <0.9+    , bytes >=0.17.1 && <0.18     , bytestring >=0.10.12 && <0.13+    , cereal >=0.5.8.1 && <0.6+    , cereal-text >=0.1.0.2 && <0.2     , containers >=0.4 && <0.8     , deepseq >=1.4.4 && <1.6     , doctest >=0.18.2 && <0.23     , generic-deriving >=1.14.1 && <1.15     , grisette     , hashable >=1.2.3 && <1.6-    , hashtables >=1.2.3.4 && <1.4-    , intern >=0.9.2 && <0.10     , 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     , prettyprinter >=1.5.0 && <1.8-    , sbv >=8.17 && <11+    , sbv >=8.17 && <12     , stm ==2.5.*     , template-haskell >=2.16 && <2.23     , text >=1.2.4.1 && <2.2@@ -293,7 +304,8 @@     , th-compat >=0.1.2 && <0.2     , th-lift-instances >=0.1.16 && <0.2     , transformers >=0.5.6 && <0.7-    , unordered-containers >=0.2.11 && <0.3+    , unordered-containers >=0.2.17 && <0.3+    , vector >=0.12.1.2 && <0.14   default-language: Haskell2010   if flag(optimize)     ghc-options: -O2@@ -355,9 +367,11 @@       Grisette.SymPrim.Prim.BitsTests       Grisette.SymPrim.Prim.BoolTests       Grisette.SymPrim.Prim.BVTests+      Grisette.SymPrim.Prim.ConcurrentTests       Grisette.SymPrim.Prim.IntegralTests       Grisette.SymPrim.Prim.ModelTests       Grisette.SymPrim.Prim.NumTests+      Grisette.SymPrim.Prim.SerializationTests       Grisette.SymPrim.Prim.TabularFunTests       Grisette.SymPrim.QuantifierTests       Grisette.SymPrim.SomeBVTests@@ -374,26 +388,30 @@   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     , array >=0.5.4 && <0.6     , async >=2.2.2 && <2.3+    , atomic-primops >=0.8.3 && <0.9     , base >=4.14 && <5+    , binary >=0.8.8.0 && <0.9+    , bytes >=0.17.1 && <0.18     , bytestring >=0.10.12 && <0.13+    , cereal >=0.5.8.1 && <0.6+    , cereal-text >=0.1.0.2 && <0.2     , containers >=0.4 && <0.8     , deepseq >=1.4.4 && <1.6     , generic-deriving >=1.14.1 && <1.15     , grisette     , hashable >=1.2.3 && <1.6-    , hashtables >=1.2.3.4 && <1.4-    , intern >=0.9.2 && <0.10     , 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     , prettyprinter >=1.5.0 && <1.8-    , sbv >=8.17 && <11+    , sbv >=8.17 && <12     , stm ==2.5.*     , template-haskell >=2.16 && <2.23     , test-framework >=0.8.2 && <0.9@@ -404,7 +422,8 @@     , th-compat >=0.1.2 && <0.2     , th-lift-instances >=0.1.16 && <0.2     , transformers >=0.5.6 && <0.7-    , unordered-containers >=0.2.11 && <0.3+    , unordered-containers >=0.2.17 && <0.3+    , vector >=0.12.1.2 && <0.14   default-language: Haskell2010   if flag(optimize)     ghc-options: -O2

@@ -300,16 +300,20 @@     --     -- >>> "a" :: Symbol     -- a+    SExpr (..),+    showsSExprWithParens,+    fileLocation,     Identifier (..),     Symbol (..),     identifier,-    withInfo,-    withLoc,+    withMetadata,+    mapMetadata,+    withLocation,     uniqueIdentifier,     simple,     indexed,     symbolIdentifier,-    modifyIdentifier,+    mapIdentifier,      -- ** Creation and extraction of solvable values     Solvable (..),@@ -1047,7 +1051,7 @@     -- >>> res     -- ExceptT {If (|| a (! b)) (If a (Left Error1) (Left Error2)) (Right c)}     -- >>> solveExcept z3 (\case Left _ -> con False; Right x -> x) res-    -- Right (Model {a -> False :: Bool, b -> True :: Bool, c -> True :: Bool})+    -- Right (Model {a -> false :: Bool, b -> true :: Bool, c -> true :: Bool})     --     -- The solver call in the above example means that we want the solver to     -- find the conditions under which no error is thrown, and the result is@@ -1314,11 +1318,21 @@     -- * Utilities #utils#      -- ** Memoization+    stableMemo,+    stableMemo2,+    stableMemo3,+    stableMup,+    stableMemoFix,+    weakStableMemo,+    weakStableMemo2,+    weakStableMemo3,+    weakStableMup,+    weakStableMemoFix,     htmemo,     htmemo2,     htmemo3,-    htmup,     htmemoFix,+    htmup,      -- ** Generic deriving of classes @@ -1769,18 +1783,34 @@     htmemo3,     htmemoFix,     htmup,+    stableMemo,+    stableMemo2,+    stableMemo3,+    stableMemoFix,+    stableMup,+    weakStableMemo,+    weakStableMemo2,+    weakStableMemo3,+    weakStableMemoFix,+    weakStableMup,   )+import Grisette.Internal.Core.Data.SExpr+  ( SExpr (..),+    fileLocation,+    showsSExprWithParens,+  ) import Grisette.Internal.Core.Data.Symbol   ( Identifier (..),     Symbol (..),     identifier,     indexed,-    modifyIdentifier,+    mapIdentifier,+    mapMetadata,     simple,     symbolIdentifier,     uniqueIdentifier,-    withInfo,-    withLoc,+    withLocation,+    withMetadata,   ) import Instances.TH.Lift () 

@@ -1,4 +1,10 @@ {-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Strict #-}  -- | -- Module      :   Grisette.Internal.Backend.QuantifiedStack@@ -21,8 +27,9 @@ where  import Data.Dynamic (Dynamic)-import qualified Data.HashMap.Lazy as M+import qualified Data.HashMap.Strict as M import qualified Data.HashSet as S+import Data.Hashable (Hashable (hashWithSalt)) import GHC.Stack (HasCallStack) import Grisette.Internal.SymPrim.Prim.Internal.Term   ( IsSymbolKind,@@ -65,6 +72,12 @@ -- | A stack of quantified symbols. newtype QuantifiedStack = QuantifiedStack   {_stack :: M.HashMap SomeTypedConstantSymbol Dynamic}++instance Eq QuantifiedStack where+  QuantifiedStack s1 == QuantifiedStack s2 = M.keysSet s1 == M.keysSet s2++instance Hashable QuantifiedStack where+  hashWithSalt s (QuantifiedStack t) = hashWithSalt s (M.keys t)  -- | An empty stack of quantified symbols. emptyQuantifiedStack :: QuantifiedStack

@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-}@@ -8,6 +9,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Strict #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}@@ -65,22 +67,29 @@     tryTakeTMVar,   ) import Control.Concurrent.STM.TChan (TChan, newTChan, readTChan, writeTChan)-import Control.Exception (handle, throwTo)-import Control.Monad (when)+import Control.Exception+  ( Exception (displayException),+    SomeException,+    handle,+    throwTo,+  ) import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Monad.RWS (RWST (runRWST)) import Control.Monad.Reader   ( MonadReader (ask),     MonadTrans (lift),     ReaderT (runReaderT),     ask,-    local,   ) import Control.Monad.STM (STM)-import Control.Monad.State (MonadState (get, put), StateT, evalStateT, modify)-import Control.Monad.Writer (tell)+import Control.Monad.State.Strict+  ( MonadState (get, put),+    StateT,+    evalStateT,+  ) import Data.Dynamic (fromDyn, toDyn)-import Data.List.NonEmpty (NonEmpty)+import qualified Data.HashSet as HS+import Data.IORef (modifyIORef', newIORef, readIORef, writeIORef)+import Data.List.NonEmpty (NonEmpty ((:|))) import Data.Proxy (Proxy (Proxy)) import qualified Data.SBV as SBV import qualified Data.SBV.Control as SBVC@@ -88,6 +97,7 @@ import qualified Data.SBV.Internals as SBVI import qualified Data.SBV.Trans as SBVT import qualified Data.SBV.Trans.Control as SBVTC+import qualified Data.Text as T import GHC.IO.Exception (ExitCode (ExitSuccess)) import GHC.Stack (HasCallStack) import Grisette.Internal.Backend.QuantifiedStack@@ -138,6 +148,7 @@       ),     SolvingFailure (SolvingError, Terminated, Unk, Unsat),   )+import Grisette.Internal.Core.Data.MemoUtils (htmemo) import Grisette.Internal.SymPrim.GeneralFun (substTerm) import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalFP   ( sbvFPBinaryTerm,@@ -185,7 +196,6 @@     SupportedPrim       ( conSBVTerm,         funcDummyConstraint,-        isFuncType,         parseSMTModelResult,         sbvDistinct,         sbvEq,@@ -203,7 +213,6 @@         BVConcatTerm,         BVExtendTerm,         BVSelectTerm,-        BinaryTerm,         BitCastOrTerm,         BitCastTerm,         ComplementBitsTerm,@@ -242,16 +251,15 @@         ShiftRightTerm,         SignumNumTerm,         SymTerm,-        TernaryTerm,         ToFPTerm,-        UnaryTerm,         XorBitsTerm       ),     TypedConstantSymbol,-    TypedSymbol (TypedSymbol),+    TypedSymbol,     introSupportedPrimConstraint,     someTypedSymbol,     symTerm,+    withConstantSymbolSupported,     withSymbolSupported,   ) import Grisette.Internal.SymPrim.Prim.Model as PM@@ -376,9 +384,8 @@ instance (MonadIO m) => MonadicSolver (SBVIncrementalT m) where   monadicSolverAssert (SymBool formula) = do     symBiMap <- get-    config <- ask     (newSymBiMap, lowered, dummyConstraint) <--      lowerSinglePrimCached config formula symBiMap+      lowerSinglePrimCached formula symBiMap     lift $ lift $ SBV.constrain dummyConstraint     lift $ lift $ SBV.constrain (lowered emptyQuantifiedStack)     put newSymBiMap@@ -419,11 +426,13 @@     sbvSolverHandleOutChan <- atomically newTChan     sbvSolverHandleStatus <- newTMVarIO SBVSolverNormal     sbvSolverHandleMonad <- async $ do-      let handler e =+      let handler (e :: SomeException) =             liftIO $               atomically $ do                 setTerminated sbvSolverHandleStatus-                writeTChan sbvSolverHandleOutChan (Left (SolvingError e))+                writeTChan+                  sbvSolverHandleOutChan+                  (Left (SolvingError $ T.pack $ displayException e))       handle handler $ runSBVIncremental config $ do         let loop = do               nextFormula <-@@ -447,7 +456,7 @@     return $ SBVSolverHandle {..}  instance Solver SBVSolverHandle where-  solverRunCommand f handle@(SBVSolverHandle _ status inChan _) command = do+  solverRunCommand f handle@(SBVSolverHandle _ status inChan _) !command = do     st <- liftIO $ atomically $ takeTMVar status     case st of       SBVSolverNormal -> do@@ -481,341 +490,335 @@     throwTo (asyncThreadId thread) ExitSuccess     wait thread -newtype TermAll = TermAll SBV.SBool--instance Semigroup TermAll where-  TermAll a <> TermAll b = TermAll (a SBV..&& b)--instance Monoid TermAll where-  mempty = TermAll SBV.sTrue+sbvForall,+  sbvExists ::+    forall t.+    (SupportedNonFuncPrim t) =>+    TypedConstantSymbol t ->+    (QuantifiedStack -> SBV.SBool) ->+    QuantifiedStack ->+    SBV.SBool+#if MIN_VERSION_sbv(10,1,0)+sbvForall sb r qst = withNonFuncPrim @t $+  SBV.quantifiedBool $+    \(SBV.Forall (a :: SBVType t)) ->+      r $ addQuantified sb (toDyn a) qst+sbvExists sb r qst = withNonFuncPrim @t $+  SBV.quantifiedBool $+    \(SBV.Exists (a :: SBVType t)) ->+      r $ addQuantified sb (toDyn a) qst+#else+sbvForall =+  error "Quantifiers are only available when you build with SBV 10.1.0 or later"+sbvExists =+  error "Quantifiers are only available when you build with SBV 10.1.0 or later"+#endif  -- | Lower a single primitive term to SBV. With an explicitly provided -- 'SymBiMap' cache. lowerSinglePrimCached ::-  forall a m.+  forall t m.   (HasCallStack, SBVFreshMonad m) =>-  GrisetteSMTConfig ->-  Term a ->+  Term t ->   SymBiMap ->-  m (SymBiMap, QuantifiedStack -> SBVType a, SBV.SBool)-lowerSinglePrimCached config t m = do-  -- (_, newm, dummy) <- declareAllUFuncsImpl config t HS.empty m-  (r, finalm, TermAll dummy) <--    runRWST (lowerSinglePrimCached' config t) emptyQuantifiedSymbols m-  return (finalm, r, dummy)+  m (SymBiMap, QuantifiedStack -> SBVType t, SBV.SBool)+lowerSinglePrimCached t' m' = do+  mapState <- liftIO $ newIORef m'+  accumulatedDummyConstraints <- liftIO $ newIORef SBV.sTrue+  -- quantifiedSymbols <- liftIO $ newIORef emptyQuantifiedSymbols+  let goCached ::+        forall x.+        QuantifiedSymbols ->+        Term x ->+        m (QuantifiedStack -> SBVType x)+      goCached qs t = introSupportedPrimConstraint t $ do+        mp <- liftIO $ readIORef mapState+        case lookupTerm (SomeTerm t) mp of+          Just x -> return (\qst -> withPrim @x $ fromDyn (x qst) undefined)+          Nothing -> goCachedImpl qs t+      goCachedImpl ::+        forall a.+        (SupportedPrim a) =>+        QuantifiedSymbols ->+        Term a ->+        m (QuantifiedStack -> SBVType a)+      goCachedImpl _ (ConTerm _ _ _ _ v) =+        return $ const $ conSBVTerm v+      goCachedImpl qs t@(SymTerm _ _ _ _ ts) = do+        if isQuantifiedSymbol ts qs+          then withPrim @a $ do+            let retDyn qst =+                  case lookupQuantified (someTypedSymbol ts) qst of+                    Just v -> v+                    Nothing ->+                      error "BUG: Symbol not found in the quantified stack"+            liftIO $+              modifyIORef' mapState $+                \m -> addBiMapIntermediate (SomeTerm t) retDyn m+            return $+              \x ->+                fromDyn+                  (retDyn x)+                  (error "BUG: Symbol not found in the quantified stack")+          else withPrim @a $ do+            m <- liftIO $ readIORef mapState+            let name = symSBVName ts (sizeBiMap m)+            g <- symSBVTerm @a name+            liftIO $+              modifyIORef' accumulatedDummyConstraints $+                \c -> c SBV..&& funcDummyConstraint @a g+            liftIO $+              modifyIORef' mapState $+                addBiMap (SomeTerm t) (toDyn g) name (someTypedSymbol ts)+            return $ const g+      goCachedImpl qs t@(ForallTerm _ _ _ _ (ts :: TypedConstantSymbol t1) v) =+        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 =+        withPrim @a $ do+          r <- goCachedIntermediate qs t+          let memoed = htmemo r+              {-# NOINLINE memoed #-}+          liftIO $+            modifyIORef' mapState $+              addBiMapIntermediate (SomeTerm t) (toDyn . memoed)+          return memoed+      goCachedIntermediate ::+        forall a.+        (SupportedPrim a) =>+        QuantifiedSymbols ->+        Term a ->+        m (QuantifiedStack -> SBVType a)+      goCachedIntermediate qs (NotTerm _ _ _ _ t) = do+        r <- goCached qs t+        return $ \qst -> SBV.sNot (r qst)+      goCachedIntermediate qs (OrTerm _ _ _ _ a b) = do+        a' <- goCached qs a+        b' <- goCached qs b+        return $ \qst -> a' qst SBV..|| b' qst+      goCachedIntermediate qs (AndTerm _ _ _ _ a b) = do+        a' <- goCached qs a+        b' <- goCached qs b+        return $ \qst -> a' qst SBV..&& b' qst+      goCachedIntermediate qs (EqTerm _ _ _ _ (a :: Term v) b) = do+        a' <- goCached qs a+        b' <- goCached qs b+        return $+          introSupportedPrimConstraint a $+            \qst -> sbvEq @v (a' qst) (b' qst)+      goCachedIntermediate+        qs+        (DistinctTerm _ _ _ _ (args@(arg1 :| _) :: 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+        c' <- goCached qs c+        a' <- goCached qs a+        b' <- goCached qs b+        return $ \qst -> sbvIte @a (c' qst) (a' qst) (b' qst)+      goCachedIntermediate qs (AddNumTerm _ _ _ _ a b) = do+        a' <- goCached qs a+        b' <- goCached qs b+        return $ \qst -> sbvAddNumTerm @a (a' qst) (b' qst)+      goCachedIntermediate qs (NegNumTerm _ _ _ _ a) = do+        a' <- goCached qs a+        return $ sbvNegNumTerm @a . a'+      goCachedIntermediate qs (MulNumTerm _ _ _ _ a b) = do+        a' <- goCached qs a+        b' <- goCached qs b+        return $ \qst -> sbvMulNumTerm @a (a' qst) (b' qst)+      goCachedIntermediate qs (AbsNumTerm _ _ _ _ a) = do+        a' <- goCached qs a+        return $ sbvAbsNumTerm @a . a'+      goCachedIntermediate qs (SignumNumTerm _ _ _ _ a) = do+        a' <- goCached qs a+        return $ sbvSignumNumTerm @a . a'+      goCachedIntermediate qs (LtOrdTerm _ _ _ _ (a :: Term v) b) = do+        a' <- goCached qs a+        b' <- goCached qs b+        return $ \qst -> sbvLtOrdTerm @v (a' qst) (b' qst)+      goCachedIntermediate qs (LeOrdTerm _ _ _ _ (a :: Term v) b) = do+        a' <- goCached qs a+        b' <- goCached qs b+        return $ \qst -> sbvLeOrdTerm @v (a' qst) (b' qst)+      goCachedIntermediate qs (AndBitsTerm _ _ _ _ a b) = do+        a' <- goCached qs a+        b' <- goCached qs b+        return $ \qst -> sbvAndBitsTerm @a (a' qst) (b' qst)+      goCachedIntermediate qs (OrBitsTerm _ _ _ _ a b) = do+        a' <- goCached qs a+        b' <- goCached qs b+        return $ \qst -> sbvOrBitsTerm @a (a' qst) (b' qst)+      goCachedIntermediate qs (XorBitsTerm _ _ _ _ a b) = do+        a' <- goCached qs a+        b' <- goCached qs b+        return $ \qst -> sbvXorBitsTerm @a (a' qst) (b' qst)+      goCachedIntermediate qs (ComplementBitsTerm _ _ _ _ a) = do+        a' <- goCached qs a+        return $ sbvComplementBitsTerm @a . a'+      goCachedIntermediate qs (ShiftLeftTerm _ _ _ _ a b) = do+        a' <- goCached qs a+        b' <- goCached qs b+        return $ \qst -> sbvShiftLeftTerm @a (a' qst) (b' qst)+      goCachedIntermediate qs (ShiftRightTerm _ _ _ _ a b) = do+        a' <- goCached qs a+        b' <- goCached qs b+        return $ \qst -> sbvShiftRightTerm @a (a' qst) (b' qst)+      goCachedIntermediate qs (RotateLeftTerm _ _ _ _ a b) = do+        a' <- goCached qs a+        b' <- goCached qs b+        return $ \qst -> sbvRotateLeftTerm @a (a' qst) (b' qst)+      goCachedIntermediate qs (RotateRightTerm _ _ _ _ a b) = do+        a' <- goCached qs a+        b' <- goCached qs b+        return $ \qst -> sbvRotateRightTerm @a (a' qst) (b' qst)+      goCachedIntermediate qs (ApplyTerm _ _ _ _ (f :: Term f) a) = do+        l1 <- goCached qs f+        l2 <- goCached qs a+        return $ \qst -> sbvApplyTerm @f (l1 qst) (l2 qst)+      goCachedIntermediate qs (BitCastTerm _ _ _ _ (a :: Term x)) = do+        a' <- goCached qs a+        return $ sbvBitCast @x @a . a'+      goCachedIntermediate+        qs+        (BitCastOrTerm _ _ _ _ (d :: Term a) (a :: Term x)) = do+          d' <- goCached qs d+          a' <- goCached qs a+          return $ \qst -> sbvBitCastOr @x @a (d' qst) (a' qst)+      goCachedIntermediate+        qs+        (BVConcatTerm _ _ _ _ (a :: Term (bv l)) (b :: Term (bv r))) =+          do+            a' <- goCached qs a+            b' <- goCached qs b+            return $+              \qst ->+                sbvBVConcatTerm @bv (Proxy @l) (Proxy @r) (a' qst) (b' qst)+      goCachedIntermediate+        qs+        (BVExtendTerm _ _ _ _ signed (pr :: p r) (a :: Term (bv l))) =+          do+            a' <- goCached qs a+            return $ sbvBVExtendTerm @bv (Proxy @l) pr signed . a'+      goCachedIntermediate+        qs+        (BVSelectTerm _ _ _ _ (pix :: p ix) (pw :: q w) (a :: Term (bv n))) =+          do+            a' <- goCached qs a+            return $ sbvBVSelectTerm @bv pix pw (Proxy @n) . a'+      goCachedIntermediate qs (DivIntegralTerm _ _ _ _ a b) = do+        a' <- goCached qs a+        b' <- goCached qs b+        return $ \qst -> sbvDivIntegralTerm @a (a' qst) (b' qst)+      goCachedIntermediate qs (ModIntegralTerm _ _ _ _ a b) = do+        a' <- goCached qs a+        b' <- goCached qs b+        return $ \qst -> sbvModIntegralTerm @a (a' qst) (b' qst)+      goCachedIntermediate qs (QuotIntegralTerm _ _ _ _ a b) = do+        a' <- goCached qs a+        b' <- goCached qs b+        return $ \qst -> sbvQuotIntegralTerm @a (a' qst) (b' qst)+      goCachedIntermediate qs (RemIntegralTerm _ _ _ _ a b) = do+        a' <- goCached qs a+        b' <- goCached qs b+        return $ \qst -> sbvRemIntegralTerm @a (a' qst) (b' qst)+      goCachedIntermediate qs (FPTraitTerm _ _ _ _ trait a) = do+        a' <- goCached qs a+        return $ sbvFPTraitTerm trait . a'+      goCachedIntermediate qs (FdivTerm _ _ _ _ a b) = do+        a <- goCached qs a+        b <- goCached qs b+        return $ \qst -> sbvFdivTerm @a (a qst) (b qst)+      goCachedIntermediate qs (RecipTerm _ _ _ _ a) = do+        a <- goCached qs a+        return $ sbvRecipTerm @a . a+      goCachedIntermediate qs (FloatingUnaryTerm _ _ _ _ op a) = do+        a <- goCached qs a+        return $ sbvFloatingUnaryTerm @a op . a+      goCachedIntermediate qs (PowerTerm _ _ _ _ a b) = do+        a <- goCached qs a+        b <- goCached qs b+        return $ \qst -> sbvPowerTerm @a (a qst) (b qst)+      goCachedIntermediate qs (FPUnaryTerm _ _ _ _ op a) = do+        a <- goCached qs a+        return $ sbvFPUnaryTerm op . a+      goCachedIntermediate qs (FPBinaryTerm _ _ _ _ op a 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+        round <- goCached qs round+        a <- goCached qs a+        return $ \qst -> sbvFPRoundingUnaryTerm op (round qst) (a qst)+      goCachedIntermediate qs (FPRoundingBinaryTerm _ _ _ _ op round a 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+        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+        b <- goCached qs b+        return $ sbvFromIntegralTerm @b @a . b+      goCachedIntermediate qs (FromFPOrTerm _ _ _ _ d mode arg) = do+        d <- goCached qs d+        mode <- goCached qs mode+        arg <- goCached qs arg+        return $ \qst -> sbvFromFPOrTerm @a (d qst) (mode qst) (arg qst)+      goCachedIntermediate qs (ToFPTerm _ _ _ _ mode (arg :: Term b) _ _) = do+        mode <- goCached qs mode+        arg <- goCached qs arg+        return $ \qst -> sbvToFPTerm @b (mode qst) (arg qst)+      goCachedIntermediate _ ConTerm {} = error "Should not happen"+      goCachedIntermediate _ SymTerm {} = error "Should not happen"+      goCachedIntermediate _ ForallTerm {} = error "Should not happen"+      goCachedIntermediate _ ExistsTerm {} = error "Should not happen"+  r <- introSupportedPrimConstraint t' $ goCached emptyQuantifiedSymbols t'+  m <- liftIO $ readIORef mapState+  constraint <- liftIO $ readIORef accumulatedDummyConstraints+  return (m, r, constraint)  -- | Lower a single primitive term to SBV. lowerSinglePrim ::   forall a m.   (HasCallStack, SBVFreshMonad m) =>-  GrisetteSMTConfig ->   Term a ->   m (SymBiMap, QuantifiedStack -> SBVType a, SBV.SBool)-lowerSinglePrim config t =-  lowerSinglePrimCached config t emptySymBiMap--lowerSinglePrimCached' ::-  forall a m.-  (HasCallStack, SBVFreshMonad m) =>-  GrisetteSMTConfig ->-  Term a ->-  RWST-    QuantifiedSymbols-    TermAll-    SymBiMap-    m-    (QuantifiedStack -> SBVType a)-lowerSinglePrimCached' config t = do-  m <- get-  introSupportedPrimConstraint t $-    case lookupTerm (SomeTerm t) m of-      Just x ->-        return-          ( \qst ->-              withPrim @a $-                fromDyn (x qst) undefined-          )-      Nothing -> do-        lowerSinglePrimImpl config t--lowerSinglePrimImpl ::-  forall a m.-  (HasCallStack, SBVFreshMonad m) =>-  GrisetteSMTConfig ->-  Term a ->-  RWST-    QuantifiedSymbols-    TermAll-    SymBiMap-    m-    (QuantifiedStack -> SBVType a)-lowerSinglePrimImpl _ (ConTerm _ v) =-  return $ const $ conSBVTerm v-lowerSinglePrimImpl _ t@(SymTerm _ ts) = do-  qs <- ask-  if isQuantifiedSymbol ts qs-    then withPrim @a $ do-      let retDyn qst =-            case lookupQuantified (someTypedSymbol ts) qst of-              Just v -> v-              Nothing -> error "BUG: Symbol not found in the quantified stack"-      modify $ \m -> addBiMapIntermediate (SomeTerm t) retDyn m-      return $-        \x ->-          fromDyn-            (retDyn x)-            (error "BUG: Symbol not found in the quantified stack")-    else withPrim @a $ do-      m <- get-      let name = symSBVName ts (sizeBiMap m)-      g <- symSBVTerm @a name-      when (isFuncType @a) $ tell $ TermAll $ funcDummyConstraint @a g-      put $ addBiMap (SomeTerm t) (toDyn g) name (someTypedSymbol ts) m-      return $ const g-#if MIN_VERSION_sbv(10,1,0)-lowerSinglePrimImpl config t@(ForallTerm _ (ts :: TypedConstantSymbol t1) v) =-  withNonFuncPrim @t1 $ do-    do-      m <- get-      let (newm, sb@(TypedSymbol sbs)) = attachNextQuantifiedSymbolInfo m ts-      put newm-      let substedTerm = substTerm ts (symTerm sbs) v-      r <--        local (addQuantifiedSymbol sb) $-          lowerSinglePrimCached'-            config-            substedTerm-      let ret qst = SBV.quantifiedBool $-            \(SBV.Forall (a :: SBVType t1)) ->-              r $ addQuantified sb (toDyn a) qst-      modify $ addBiMapIntermediate (SomeTerm t) (toDyn . ret)-      return ret-lowerSinglePrimImpl config t@(ExistsTerm _ (ts :: TypedConstantSymbol t1) v) =-  withNonFuncPrim @t1 $ do-    do-      m <- get-      let (newm, sb@(TypedSymbol sbs)) = attachNextQuantifiedSymbolInfo m ts-      put newm-      let substedTerm = substTerm ts (symTerm sbs) v-      r <--        local (addQuantifiedSymbol sb) $-          lowerSinglePrimCached'-            config-            substedTerm-      let ret qst = SBV.quantifiedBool $-            \(SBV.Exists (a :: SBVType t1)) ->-              r $ addQuantified sb (toDyn a) qst-      modify $ addBiMapIntermediate (SomeTerm t) (toDyn . ret)-      return ret-#else-lowerSinglePrimImpl _ ForallTerm {} =-  error "Quantifiers are only available when you build with SBV 10.1.0 or later"-lowerSinglePrimImpl _ ExistsTerm {} =-  error "Quantifiers are only available when you build with SBV 10.1.0 or later"-#endif-lowerSinglePrimImpl config t =-  introSupportedPrimConstraint t $-    withPrim @a $ do-      r <- lowerSinglePrimIntermediate config t-      modify $ addBiMapIntermediate (SomeTerm t) (toDyn . r)-      return r--lowerSinglePrimIntermediate ::-  forall a m.-  (HasCallStack, SBVFreshMonad m) =>-  GrisetteSMTConfig ->-  Term a ->-  RWST-    QuantifiedSymbols-    TermAll-    SymBiMap-    m-    (QuantifiedStack -> SBVType a)-lowerSinglePrimIntermediate config (NotTerm _ a) = do-  a' <- lowerSinglePrimCached' config a-  return $ SBV.sNot . a'-lowerSinglePrimIntermediate config (OrTerm _ a b) = do-  a' <- lowerSinglePrimCached' config a-  b' <- lowerSinglePrimCached' config b-  return $ \qst -> a' qst SBV..|| b' qst-lowerSinglePrimIntermediate config (AndTerm _ a b) = do-  a' <- lowerSinglePrimCached' config a-  b' <- lowerSinglePrimCached' config b-  return $ \qst -> a' qst SBV..&& b' qst-lowerSinglePrimIntermediate config (EqTerm _ (a :: Term v) b) = do-  a' <- lowerSinglePrimCached' config a-  b' <- lowerSinglePrimCached' config b-  return $ \qst -> sbvEq @v (a' qst) (b' qst)-lowerSinglePrimIntermediate config (DistinctTerm _ (args :: NonEmpty (Term t))) = do-  args' <- traverse (lowerSinglePrimCached' config) args-  return $ \qst -> sbvDistinct @t (fmap ($ qst) args')-lowerSinglePrimIntermediate config (ITETerm _ c a b) = do-  c' <- lowerSinglePrimCached' config c-  a' <- lowerSinglePrimCached' config a-  b' <- lowerSinglePrimCached' config b-  return $ \qst -> sbvIte @a (c' qst) (a' qst) (b' qst)-lowerSinglePrimIntermediate config (AddNumTerm _ a b) = do-  a' <- lowerSinglePrimCached' config a-  b' <- lowerSinglePrimCached' config b-  return $ \qst -> sbvAddNumTerm @a (a' qst) (b' qst)-lowerSinglePrimIntermediate config (NegNumTerm _ a) = do-  a' <- lowerSinglePrimCached' config a-  return $ sbvNegNumTerm @a . a'-lowerSinglePrimIntermediate config (MulNumTerm _ a b) = do-  a' <- lowerSinglePrimCached' config a-  b' <- lowerSinglePrimCached' config b-  return $ \qst -> sbvMulNumTerm @a (a' qst) (b' qst)-lowerSinglePrimIntermediate config (AbsNumTerm _ a) = do-  a' <- lowerSinglePrimCached' config a-  return $ sbvAbsNumTerm @a . a'-lowerSinglePrimIntermediate config (SignumNumTerm _ a) = do-  a' <- lowerSinglePrimCached' config a-  return $ sbvSignumNumTerm @a . a'-lowerSinglePrimIntermediate config (LtOrdTerm _ (a :: Term v) b) = do-  a' <- lowerSinglePrimCached' config a-  b' <- lowerSinglePrimCached' config b-  return $ \qst -> sbvLtOrdTerm @v (a' qst) (b' qst)-lowerSinglePrimIntermediate config (LeOrdTerm _ (a :: Term v) b) = do-  a' <- lowerSinglePrimCached' config a-  b' <- lowerSinglePrimCached' config b-  return $ \qst -> sbvLeOrdTerm @v (a' qst) (b' qst)-lowerSinglePrimIntermediate config (AndBitsTerm _ a b) = do-  a' <- lowerSinglePrimCached' config a-  b' <- lowerSinglePrimCached' config b-  return $ \qst -> sbvAndBitsTerm @a (a' qst) (b' qst)-lowerSinglePrimIntermediate config (OrBitsTerm _ a b) = do-  a' <- lowerSinglePrimCached' config a-  b' <- lowerSinglePrimCached' config b-  return $ \qst -> sbvOrBitsTerm @a (a' qst) (b' qst)-lowerSinglePrimIntermediate config (XorBitsTerm _ a b) = do-  a' <- lowerSinglePrimCached' config a-  b' <- lowerSinglePrimCached' config b-  return $ \qst -> sbvXorBitsTerm @a (a' qst) (b' qst)-lowerSinglePrimIntermediate config (ComplementBitsTerm _ a) = do-  a' <- lowerSinglePrimCached' config a-  return $ sbvComplementBitsTerm @a . a'-lowerSinglePrimIntermediate config (ShiftLeftTerm _ a b) = do-  a' <- lowerSinglePrimCached' config a-  b' <- lowerSinglePrimCached' config b-  return $ \qst -> sbvShiftLeftTerm @a (a' qst) (b' qst)-lowerSinglePrimIntermediate config (ShiftRightTerm _ a b) = do-  a' <- lowerSinglePrimCached' config a-  b' <- lowerSinglePrimCached' config b-  return $ \qst -> sbvShiftRightTerm @a (a' qst) (b' qst)-lowerSinglePrimIntermediate config (RotateLeftTerm _ a b) = do-  a' <- lowerSinglePrimCached' config a-  b' <- lowerSinglePrimCached' config b-  return $ \qst -> sbvRotateLeftTerm @a (a' qst) (b' qst)-lowerSinglePrimIntermediate config (RotateRightTerm _ a b) = do-  a' <- lowerSinglePrimCached' config a-  b' <- lowerSinglePrimCached' config b-  return $ \qst -> sbvRotateRightTerm @a (a' qst) (b' qst)-lowerSinglePrimIntermediate config (ApplyTerm _ (f :: Term f) a) = do-  l1 <- lowerSinglePrimCached' config f-  l2 <- lowerSinglePrimCached' config a-  return $ \qst -> sbvApplyTerm @f (l1 qst) (l2 qst)-lowerSinglePrimIntermediate config (BitCastTerm _ (a :: Term x)) = do-  a' <- lowerSinglePrimCached' config a-  return $ sbvBitCast @x @a . a'-lowerSinglePrimIntermediate-  config-  (BitCastOrTerm _ (d :: Term a) (a :: Term x)) = do-    d' <- lowerSinglePrimCached' config d-    a' <- lowerSinglePrimCached' config a-    return $ \qst -> sbvBitCastOr @x @a (d' qst) (a' qst)-lowerSinglePrimIntermediate-  config-  (BVConcatTerm _ (a :: Term (bv l)) (b :: Term (bv r))) =-    do-      a' <- lowerSinglePrimCached' config a-      b' <- lowerSinglePrimCached' config b-      return $ \qst -> sbvBVConcatTerm @bv (Proxy @l) (Proxy @r) (a' qst) (b' qst)-lowerSinglePrimIntermediate-  config-  (BVExtendTerm _ signed (pr :: p r) (a :: Term (bv l))) =-    do-      a' <- lowerSinglePrimCached' config a-      return $ sbvBVExtendTerm @bv (Proxy @l) pr signed . a'-lowerSinglePrimIntermediate-  config-  (BVSelectTerm _ (pix :: p ix) (pw :: q w) (a :: Term (bv n))) =-    do-      a' <- lowerSinglePrimCached' config a-      return $ sbvBVSelectTerm @bv pix pw (Proxy @n) . a'-lowerSinglePrimIntermediate config (DivIntegralTerm _ a b) = do-  a' <- lowerSinglePrimCached' config a-  b' <- lowerSinglePrimCached' config b-  return $ \qst -> sbvDivIntegralTerm @a (a' qst) (b' qst)-lowerSinglePrimIntermediate config (ModIntegralTerm _ a b) = do-  a' <- lowerSinglePrimCached' config a-  b' <- lowerSinglePrimCached' config b-  return $ \qst -> sbvModIntegralTerm @a (a' qst) (b' qst)-lowerSinglePrimIntermediate config (QuotIntegralTerm _ a b) = do-  a' <- lowerSinglePrimCached' config a-  b' <- lowerSinglePrimCached' config b-  return $ \qst -> sbvQuotIntegralTerm @a (a' qst) (b' qst)-lowerSinglePrimIntermediate config (RemIntegralTerm _ a b) = do-  a' <- lowerSinglePrimCached' config a-  b' <- lowerSinglePrimCached' config b-  return $ \qst -> sbvRemIntegralTerm @a (a' qst) (b' qst)-lowerSinglePrimIntermediate config (FPTraitTerm _ trait a) = do-  a' <- lowerSinglePrimCached' config a-  return $ sbvFPTraitTerm trait . a'-lowerSinglePrimIntermediate config (FdivTerm _ a b) = do-  a <- lowerSinglePrimCached' config a-  b <- lowerSinglePrimCached' config b-  return $ \qst -> sbvFdivTerm @a (a qst) (b qst)-lowerSinglePrimIntermediate config (RecipTerm _ a) = do-  a <- lowerSinglePrimCached' config a-  return $ sbvRecipTerm @a . a-lowerSinglePrimIntermediate config (FloatingUnaryTerm _ op a) = do-  a <- lowerSinglePrimCached' config a-  return $ sbvFloatingUnaryTerm @a op . a-lowerSinglePrimIntermediate config (PowerTerm _ a b) = do-  a <- lowerSinglePrimCached' config a-  b <- lowerSinglePrimCached' config b-  return $ \qst -> sbvPowerTerm @a (a qst) (b qst)-lowerSinglePrimIntermediate config (FPUnaryTerm _ op a) = do-  a <- lowerSinglePrimCached' config a-  return $ sbvFPUnaryTerm op . a-lowerSinglePrimIntermediate config (FPBinaryTerm _ op a b) = do-  a <- lowerSinglePrimCached' config a-  b <- lowerSinglePrimCached' config b-  return $ \qst -> sbvFPBinaryTerm op (a qst) (b qst)-lowerSinglePrimIntermediate config (FPRoundingUnaryTerm _ op round a) = do-  round <- lowerSinglePrimCached' config round-  a <- lowerSinglePrimCached' config a-  return $ \qst -> sbvFPRoundingUnaryTerm op (round qst) (a qst)-lowerSinglePrimIntermediate config (FPRoundingBinaryTerm _ op round a b) = do-  round <- lowerSinglePrimCached' config round-  a <- lowerSinglePrimCached' config a-  b <- lowerSinglePrimCached' config b-  return $ \qst -> sbvFPRoundingBinaryTerm op (round qst) (a qst) (b qst)-lowerSinglePrimIntermediate config (FPFMATerm _ round a b c) = do-  round <- lowerSinglePrimCached' config round-  a <- lowerSinglePrimCached' config a-  b <- lowerSinglePrimCached' config b-  c <- lowerSinglePrimCached' config c-  return $ \qst -> sbvFPFMATerm (round qst) (a qst) (b qst) (c qst)-lowerSinglePrimIntermediate config (FromIntegralTerm _ (b :: Term b)) = do-  b <- lowerSinglePrimCached' config b-  return $ sbvFromIntegralTerm @b @a . b-lowerSinglePrimIntermediate config (FromFPOrTerm _ d mode arg) = do-  d <- lowerSinglePrimCached' config d-  mode <- lowerSinglePrimCached' config mode-  arg <- lowerSinglePrimCached' config arg-  return $ \qst -> sbvFromFPOrTerm @a (d qst) (mode qst) (arg qst)-lowerSinglePrimIntermediate config (ToFPTerm _ mode (arg :: Term b) _ _) = do-  mode <- lowerSinglePrimCached' config mode-  arg <- lowerSinglePrimCached' config arg-  return $ \qst -> sbvToFPTerm @b (mode qst) (arg qst)-lowerSinglePrimIntermediate _ ConTerm {} = error "Should not happen"-lowerSinglePrimIntermediate _ SymTerm {} = error "Should not happen"-lowerSinglePrimIntermediate _ ForallTerm {} = error "Should not happen"-lowerSinglePrimIntermediate _ ExistsTerm {} = error "Should not happen"-lowerSinglePrimIntermediate _ UnaryTerm {} = error "Not implemented"-lowerSinglePrimIntermediate _ BinaryTerm {} = error "Not implemented"-lowerSinglePrimIntermediate _ TernaryTerm {} = error "Not implemented"+lowerSinglePrim t =+  lowerSinglePrimCached t emptySymBiMap  #if MIN_VERSION_sbv(10,3,0) preprocessUIFuncs ::@@ -848,7 +851,7 @@   SBVI.SMTModel ->   SymBiMap ->   PM.Model-parseModel _ (SBVI.SMTModel _ _ assoc origFuncs) mp =+parseModel _ model@(SBVI.SMTModel _ _ assoc origFuncs) mp =   case preprocessUIFuncs origFuncs of     Just funcs -> foldr goSingle emptyModel $ funcs ++ assocFuncs     _ -> error "SBV Failed to parse model"@@ -856,10 +859,13 @@     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 (_ :: p r) s) ->+      Just (SomeTypedSymbol (s :: TypedSymbol knd r)) ->         withSymbolSupported s $           insertValue s (parseSMTModelResult 0 cv :: r) m       Nothing ->         error $           "BUG: Please send a bug report. The model is not consistent with the "-            <> "list of symbols that have been defined."+            <> "list of symbols that have been defined. The map is "+            <> show mp+            <> ". The model is "+            <> show model

@@ -1,8 +1,7 @@ {-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveLift #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Strict #-}  -- | -- Module      :   Grisette.Internal.Backend.SymBiMap@@ -20,21 +19,18 @@     addBiMapIntermediate,     findStringToSymbol,     lookupTerm,-    QuantifiedSymbolInfo (..),     attachNextQuantifiedSymbolInfo,   ) where -import Control.DeepSeq (NFData) import Data.Dynamic (Dynamic) import qualified Data.HashMap.Strict as M-import Data.Hashable (Hashable)-import GHC.Generics (Generic) import GHC.Stack (HasCallStack) import Grisette.Internal.Backend.QuantifiedStack (QuantifiedStack)+import Grisette.Internal.Core.Data.SExpr (SExpr (Atom, List, NumberAtom)) import Grisette.Internal.Core.Data.Symbol-  ( Symbol (IndexedSymbol, SimpleSymbol),-    withInfo,+  ( mapIdentifier,+    mapMetadata,   ) import Grisette.Internal.SymPrim.Prim.SomeTerm   ( SomeTerm,@@ -44,36 +40,51 @@     SomeTypedAnySymbol,     SomeTypedSymbol,     TypedConstantSymbol,-    TypedSymbol (TypedSymbol),+    TypedSymbol (unTypedSymbol),     castSomeTypedSymbol,+    typedConstantSymbol,+    withConstantSymbolSupported,   )-import Language.Haskell.TH.Syntax (Lift)  -- | A bidirectional map between symbolic Grisette terms and sbv terms. data SymBiMap = SymBiMap   { biMapToSBV :: M.HashMap SomeTerm (QuantifiedStack -> Dynamic),+    biMapSize :: Int,     biMapFromSBV :: M.HashMap String SomeTypedAnySymbol,     quantifiedSymbolNum :: Int   } --- | Information about a quantified symbol.-newtype QuantifiedSymbolInfo = QuantifiedSymbolInfo Int-  deriving (Generic, Ord, Eq, Show, Hashable, Lift, NFData)+instance Show SymBiMap where+  show (SymBiMap t s f _) =+    "SymBiMap { size: "+      ++ show s+      ++ ", toSBV: "+      ++ show (M.keys t)+      ++ ", fromSBV: "+      ++ show (M.toList f)+      ++ " }" -nextQuantifiedSymbolInfo :: SymBiMap -> (SymBiMap, QuantifiedSymbolInfo)-nextQuantifiedSymbolInfo (SymBiMap t f num) =-  (SymBiMap t f (num + 1), QuantifiedSymbolInfo num)+-- | Information about a quantified symbol.+-- newtype QuantifiedSymbolInfo = QuantifiedSymbolInfo Int+--   deriving (Generic, Ord, Eq, Show, Hashable, Lift, NFData)+nextQuantifiedSymbolInfo :: SymBiMap -> (SymBiMap, SExpr -> SExpr)+nextQuantifiedSymbolInfo (SymBiMap t s f num) =+  ( SymBiMap t s f (num + 1),+    \meta ->+      List+        [ Atom "grisette-quantified",+          NumberAtom $ fromIntegral num,+          meta+        ]+  )  attachQuantifiedSymbolInfo ::-  QuantifiedSymbolInfo -> TypedConstantSymbol a -> TypedConstantSymbol a-attachQuantifiedSymbolInfo-  info-  (TypedSymbol (SimpleSymbol ident)) =-    TypedSymbol $ SimpleSymbol $ withInfo ident info-attachQuantifiedSymbolInfo-  info-  (TypedSymbol (IndexedSymbol ident idx)) =-    TypedSymbol $ IndexedSymbol (withInfo ident info) idx+  (SExpr -> SExpr) -> TypedConstantSymbol a -> TypedConstantSymbol a+attachQuantifiedSymbolInfo info tsym =+  withConstantSymbolSupported tsym $+    typedConstantSymbol $+      mapIdentifier (mapMetadata info) $+        unTypedSymbol tsym  -- | Attach the next quantified symbol info to a symbol. attachNextQuantifiedSymbolInfo ::@@ -84,11 +95,11 @@  -- | An empty bidirectional map. emptySymBiMap :: SymBiMap-emptySymBiMap = SymBiMap M.empty M.empty 0+emptySymBiMap = SymBiMap M.empty 0 M.empty 0  -- | The size of the bidirectional map. sizeBiMap :: SymBiMap -> Int-sizeBiMap = M.size . biMapToSBV+sizeBiMap = biMapSize  -- | Add a new entry to the bidirectional map. addBiMap ::@@ -99,19 +110,20 @@   SomeTypedSymbol knd ->   SymBiMap ->   SymBiMap-addBiMap s d n sb (SymBiMap t f num) =+addBiMap s d n sb (SymBiMap t sz f num) =   case castSomeTypedSymbol sb of-    Just sb' -> SymBiMap (M.insert s (const d) t) (M.insert n sb' f) num+    Just sb' -> SymBiMap (M.insert s (const d) t) (sz + 1) (M.insert n sb' f) num     _ -> error "Casting to AnySymbol, should not fail"  -- | Add a new entry to the bidirectional map for intermediate values. addBiMapIntermediate ::   (HasCallStack) => SomeTerm -> (QuantifiedStack -> Dynamic) -> SymBiMap -> SymBiMap-addBiMapIntermediate s d (SymBiMap t f num) = SymBiMap (M.insert s d t) f num+addBiMapIntermediate s d (SymBiMap t sz f num) =+  SymBiMap (M.insert s d t) (sz + 1) f num  -- | Find a symbolic Grisette term from a string. findStringToSymbol :: (IsSymbolKind knd) => String -> SymBiMap -> Maybe (SomeTypedSymbol knd)-findStringToSymbol s (SymBiMap _ f _) = do+findStringToSymbol s (SymBiMap _ _ f _) = do   r <- M.lookup s f   castSomeTypedSymbol r 

@@ -42,6 +42,8 @@  import Control.Applicative (Alternative ((<|>))) import Control.DeepSeq (NFData (rnf), NFData1 (liftRnf), rnf1)+import qualified Data.Binary as Binary+import Data.Bytes.Serial (Serial (deserialize, serialize)) import Data.Functor.Classes   ( Eq1 (liftEq),     Show1 (liftShowsPrec),@@ -49,6 +51,7 @@   ) import qualified Data.HashMap.Lazy as HML import Data.Hashable (Hashable (hashWithSalt))+import qualified Data.Serialize as Cereal import Data.String (IsString (fromString)) import GHC.TypeNats (KnownNat, type (<=)) import Grisette.Internal.Core.Control.Monad.Class.Union (MonadUnion)@@ -137,6 +140,7 @@   ) import Grisette.Internal.SymPrim.Prim.Term   ( LinkedRep,+    SupportedNonFuncPrim,     SupportedPrim,   ) import Grisette.Internal.SymPrim.SymBV@@ -272,6 +276,18 @@     UnionBase a ->     Union a +instance (Mergeable a, Serial a) => Serial (Union a) where+  serialize = serialize . unionBase+  deserialize = UMrg rootStrategy <$> deserialize++instance (Mergeable a, Serial a) => Cereal.Serialize (Union a) where+  put = serialize+  get = deserialize++instance (Mergeable a, Serial a) => Binary.Binary (Union a) where+  put = serialize+  get = deserialize+ -- | Get the (possibly empty) cached merging strategy. unionMergingStrategy :: Union a -> Maybe (MergingStrategy a) unionMergingStrategy (UMrg s _) = Just s@@ -483,13 +499,21 @@   toSym = simpleMerge . fmap con  instance-  (SupportedPrim ((=->) ca cb), LinkedRep ca sa, LinkedRep cb sb) =>+  ( SupportedPrim ((=->) ca cb),+    SupportedNonFuncPrim ca,+    LinkedRep ca sa,+    LinkedRep cb sb+  ) =>   ToSym (Union ((=->) ca cb)) ((=~>) sa sb)   where   toSym = simpleMerge . fmap con  instance-  (SupportedPrim ((-->) ca cb), LinkedRep ca sa, LinkedRep cb sb) =>+  ( SupportedPrim ((-->) ca cb),+    SupportedNonFuncPrim ca,+    LinkedRep ca sa,+    LinkedRep cb sb+  ) =>   ToSym (Union ((-->) ca cb)) ((-~>) sa sb)   where   toSym = simpleMerge . fmap con

@@ -1,8 +1,11 @@+{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveLift #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-}@@ -65,7 +68,12 @@   ) where +import Control.DeepSeq (NFData)+import qualified Data.Binary as Binary+import Data.Bytes.Serial (Serial (deserialize, serialize))+import Data.Hashable (Hashable) import Data.List (foldl', partition)+import qualified Data.Serialize as Cereal import GHC.Generics (Generic) import Generics.Deriving (Default (Default)) import Grisette.Internal.Core.Control.Exception@@ -82,6 +90,7 @@   ( ModelOps (exact, exceptFor),     SymbolSetOps (isEmptySet),   )+import Grisette.Internal.Core.Data.Class.PPrint (PPrint (pformat), (<+>)) import Grisette.Internal.Core.Data.Class.PlainUnion   ( PlainUnion,     simpleMerge,@@ -101,6 +110,7 @@ import Grisette.Internal.Core.Data.Class.SymEq (SymEq) import Grisette.Internal.SymPrim.Prim.Model (Model) import Grisette.Internal.SymPrim.SymBool (SymBool)+import Language.Haskell.TH.Syntax (Lift)  -- $setup -- >>> import Grisette.Core@@ -111,9 +121,24 @@ -- | The response from a verifier. data VerifierResult cex exception   = CEGISVerifierFoundCex cex-  | CEGISVerifierNoCex+  | -- | True indicates that the verifier is sure that there is no+    -- counter-example, while False indicates that the verifier is not sure,+    -- but it cannot find a counter-example.+    CEGISVerifierNoCex Bool   | CEGISVerifierException exception+  deriving (Show, Eq, Generic, Lift)+  deriving anyclass (Hashable, NFData) +instance+  (PPrint cex, PPrint exception) =>+  PPrint (VerifierResult cex exception)+  where+  pformat = \case+    CEGISVerifierFoundCex cex -> "Found cex:" <+> pformat cex+    CEGISVerifierNoCex True -> "No cex"+    CEGISVerifierNoCex False -> "Maybe no cex"+    CEGISVerifierException e -> "Exception:" <+> pformat e+ -- | Build the synthesizer constraint from the verfication result. The first -- argument will be guaranteed to be distinct during each invocation of the -- function in the CEGIS algorithm, so it can be used to instantiate the@@ -130,8 +155,17 @@   = CEGISSuccess Model   | CEGISVerifierFailure exception   | CEGISSolverFailure SolvingFailure-  deriving (Show)+  deriving (Show, Eq, Generic, Lift)+  deriving anyclass (NFData, Hashable, Serial) +instance (Serial exception) => Cereal.Serialize (CEGISResult exception) where+  put = serialize+  get = deserialize++instance (Serial exception) => Binary.Binary (CEGISResult exception) where+  put = serialize+  get = deserialize+ -- | Generic CEGIS procedure. See 'genericCEGIS' for more details. -- -- The difference from 'genericCEGIS' is that this function accepts a solver@@ -154,25 +188,33 @@   firstResult <- solverSolve solver initConstr   case firstResult of     Left err -> return ([], CEGISSolverFailure err)-    Right model -> go model False verifiers+    Right model -> go model False numAllVerifiers 0 verifiers   where-    go prevModel needRerun (verifier : remainingVerifiers) = do+    numAllVerifiers = length verifiers+    go prevModel _ 0 _ (_ : _) = return ([], CEGISSuccess prevModel)+    go prevModel needRerun runBound nextBound (verifier : remainingVerifiers) = do       verifierResult <- verifier prevModel       case verifierResult of         CEGISVerifierFoundCex cex -> do           newResult <- solverSolve solver =<< synthConstr cex           case newResult of-            Left err -> return ([], CEGISSolverFailure err)+            Left err -> return ([cex], CEGISSolverFailure err)             Right model -> do               (cexes, result) <--                go model (needRerun || rerun) $-                  verifier : remainingVerifiers+                go+                  model+                  (needRerun || rerun)+                  (length remainingVerifiers + 1)+                  (numAllVerifiers - length remainingVerifiers - 1)+                  $ verifier : remainingVerifiers               return (cex : cexes, result)-        CEGISVerifierNoCex -> go prevModel needRerun remainingVerifiers+        CEGISVerifierNoCex {} ->+          go prevModel needRerun (runBound - 1) nextBound remainingVerifiers         CEGISVerifierException exception ->           return ([], CEGISVerifierFailure exception)-    go prevModel False [] = return ([], CEGISSuccess prevModel)-    go prevModel True [] = go prevModel False verifiers+    go prevModel False _ _ [] = return ([], CEGISSuccess prevModel)+    go prevModel True _runBound nextBound [] =+      go prevModel False nextBound 0 verifiers  -- | Generic CEGIS procedure with refinement. See 'genericCEGISWithRefinement' -- for more details.@@ -365,7 +407,7 @@         solverResetAssertions verifierSolver         r <- solverSolve verifierSolver evaluated         case r of-          Left Unsat -> return CEGISVerifierNoCex+          Left Unsat -> return $ CEGISVerifierNoCex True           Left err -> return $ CEGISVerifierException err           Right model -> do             let newCexInput =@@ -652,7 +694,7 @@         solverResetAssertions verifierSolver         r <- solverSolve verifierSolver evaluated         case r of-          Left Unsat -> return CEGISVerifierNoCex+          Left Unsat -> return $ CEGISVerifierNoCex True           Left err -> return $ CEGISVerifierException err           Right model ->             return $ CEGISVerifierFoundCex (exact forallSymbols model)

@@ -61,6 +61,7 @@ import Data.Maybe (fromJust) import Data.Monoid (Alt, Ap) import Data.Ord (Down)+import Data.Ratio (Ratio, denominator, numerator, (%)) import qualified Data.Text as T import Data.Word (Word16, Word32, Word64, Word8) import GHC.TypeNats (KnownNat, type (<=))@@ -98,9 +99,7 @@ import Grisette.Internal.SymPrim.GeneralFun (type (-->) (GeneralFun)) import Grisette.Internal.SymPrim.Prim.Model (Model, evalTerm) import Grisette.Internal.SymPrim.Prim.Term-  ( LinkedRep,-    SupportedPrim,-    SymRep (SymType),+  ( SymRep (SymType),     someTypedSymbol,   ) import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal (SymAlgReal))@@ -358,6 +357,11 @@ CONCRETE_EVALUATESYM(AlgReal) #endif +instance (Integral a, EvalSym a) => EvalSym (Ratio a) where+  evalSym fillDefault model r =+    evalSym fillDefault model (numerator r)+      % evalSym fillDefault model (denominator r)+ instance (ValidFP eb fb) => EvalSym (FP eb fb) where   evalSym _ _ = id @@ -373,8 +377,7 @@     symtype $ evalTerm fillDefault model HS.empty t  #define EVALUATE_SYM_FUN(cop, op, cons) \-instance (SupportedPrim (cop ca cb), LinkedRep ca sa, LinkedRep cb sb) => \-  EvalSym (op sa sb) where \+instance EvalSym (op sa sb) where \   evalSym fillDefault model (cons t) = \     cons $ evalTerm fillDefault model HS.empty t 

@@ -62,6 +62,7 @@ import Data.Monoid (Alt, Ap) import qualified Data.Monoid as Monoid import Data.Ord (Down)+import Data.Ratio (Ratio, denominator, numerator) import qualified Data.Text as T import Data.Typeable (type (:~~:) (HRefl)) import Data.Word (Word16, Word32, Word64, Word8)@@ -95,8 +96,6 @@   ) import Grisette.Internal.SymPrim.Prim.Term   ( IsSymbolKind (decideSymbolKind),-    LinkedRep,-    SupportedPrim,     SymRep (SymType),     SymbolKind,     someTypedSymbol,@@ -343,6 +342,11 @@ CONCRETE_EXTRACT_SYMBOLICS(AlgReal) #endif +instance (ExtractSym a) => ExtractSym (Ratio a) where+  extractSymMaybe a =+    extractSymMaybe (numerator a) <> extractSymMaybe (denominator a)+  {-# INLINE extractSymMaybe #-}+ instance (ValidFP eb sb) => ExtractSym (FP eb sb) where   extractSymMaybe _ = return mempty @@ -364,9 +368,8 @@       Left HRefl -> SymbolSet <$> extractTerm HS.empty t; \       Right HRefl -> SymbolSet <$> extractTerm HS.empty t -#define EXTRACT_SYMBOLICS_FUN(cop, op, cons) \-instance (SupportedPrim (cop ca cb), LinkedRep ca sa, LinkedRep cb sb) => \-  ExtractSym (op sa sb) where \+#define EXTRACT_SYMBOLICS_FUN(op, cons) \+instance ExtractSym (op sa sb) where \   extractSymMaybe :: \     forall knd. (IsSymbolKind knd) => op sa sb -> Maybe (SymbolSet knd); \   extractSymMaybe (cons t) = \@@ -381,8 +384,8 @@ EXTRACT_SYMBOLICS_SIMPLE(SymAlgReal) EXTRACT_SYMBOLICS_BV(SymIntN) EXTRACT_SYMBOLICS_BV(SymWordN)-EXTRACT_SYMBOLICS_FUN((=->), (=~>), SymTabularFun)-EXTRACT_SYMBOLICS_FUN((-->), (-~>), SymGeneralFun)+EXTRACT_SYMBOLICS_FUN((=~>), SymTabularFun)+EXTRACT_SYMBOLICS_FUN((-~>), SymGeneralFun) #endif  instance (ValidFP eb fb) => ExtractSym (SymFP eb fb) where

@@ -54,6 +54,14 @@   type FunType uf   apply :: uf -> FunType uf +instance Apply Integer where+  type FunType Integer = Integer+  apply = id++instance Apply Bool where+  type FunType Bool = Bool+  apply = id+ instance (Apply b) => Apply (a -> b) where   type FunType (a -> b) = a -> FunType b   apply f a = apply (f a)

@@ -92,8 +92,10 @@ import Data.Bifunctor (Bifunctor (first)) import qualified Data.ByteString as B import Data.Int (Int16, Int32, Int64, Int8)+import Data.Ratio (Ratio) import Data.String (IsString (fromString)) import qualified Data.Text as T+import Data.Typeable (Typeable) import Data.Word (Word16, Word32, Word64, Word8) import GHC.TypeNats (KnownNat, type (<=)) import Generics.Deriving@@ -138,6 +140,7 @@ import Grisette.Internal.SymPrim.GeneralFun (type (-->)) import Grisette.Internal.SymPrim.Prim.Term   ( LinkedRep,+    SupportedNonFuncPrim,     SupportedPrim,   ) import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal)@@ -147,9 +150,9 @@   ) import Grisette.Internal.SymPrim.SymBool (SymBool) import Grisette.Internal.SymPrim.SymFP (SymFP, SymFPRoundingMode)-import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>))+import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>) (SymGeneralFun)) import Grisette.Internal.SymPrim.SymInteger (SymInteger)-import Grisette.Internal.SymPrim.SymTabularFun (type (=~>))+import Grisette.Internal.SymPrim.SymTabularFun (type (=~>) (SymTabularFun)) import Grisette.Internal.SymPrim.TabularFun (type (=->))  -- $setup@@ -832,6 +835,12 @@ CONCRETE_GENSYMSIMPLE_SAME_SHAPE_BV(IntN) #endif +instance (Integral a, Typeable a, Show a) => GenSym (Ratio a) (Ratio a) where+  fresh = return . mrgSingle++instance GenSymSimple (Ratio a) (Ratio a) where+  simpleFresh = return+ instance (ValidFP eb sb) => GenSym (FP eb sb) (FP eb sb) where   fresh = return . mrgSingle   {-# INLINE fresh #-}@@ -1666,19 +1675,28 @@     FreshIndex index <- nextFreshIndex; \     return $ isym ident index -#define GENSYM_FUN(cop, op) \-instance (SupportedPrim (cop ca cb), LinkedRep ca sa, LinkedRep cb sb) => \-  GenSym (op sa sb) (op sa sb)-#define GENSYM_SIMPLE_FUN(cop, op) \-instance (SupportedPrim (cop ca cb), LinkedRep ca sa, LinkedRep cb sb) => \-  GenSymSimple (op sa sb) (op sa sb) where \-  simpleFresh _ = simpleFresh ()+#define GENSYM_FUN(cop, op, consop) \+instance GenSym (op sa sb) (op sa sb) where \+  fresh consop{} = fresh ()+#define GENSYM_SIMPLE_FUN(cop, op, consop) \+instance GenSymSimple (op sa sb) (op sa sb) where \+  simpleFresh consop{} = simpleFresh () #define GENSYM_UNIT_FUN(cop, op) \-instance (SupportedPrim (cop ca cb), LinkedRep ca sa, LinkedRep cb sb) => \+instance \+  ( SupportedPrim (cop ca cb), \+    SupportedNonFuncPrim ca, \+    LinkedRep ca sa, \+    LinkedRep cb sb \+  ) => \   GenSym () (op sa sb) where \   fresh _ = mrgSingle <$> simpleFresh () #define GENSYM_UNIT_SIMPLE_FUN(cop, op) \-instance (SupportedPrim (cop ca cb), LinkedRep ca sa, LinkedRep cb sb) => \+instance \+  ( SupportedPrim (cop ca cb), \+    SupportedNonFuncPrim ca, \+    LinkedRep ca sa, \+    LinkedRep cb sb \+  ) => \   GenSymSimple () (op sa sb) where \   simpleFresh _ = do; \     ident <- getIdentifier; \@@ -1712,12 +1730,12 @@ GENSYM_UNIT_BV(SymWordN) GENSYM_UNIT_SIMPLE_BV(SymWordN) -GENSYM_FUN((=->), (=~>))-GENSYM_SIMPLE_FUN((=->), (=~>))+GENSYM_FUN((=->), (=~>), SymTabularFun)+GENSYM_SIMPLE_FUN((=->), (=~>), SymTabularFun) GENSYM_UNIT_FUN((=->), (=~>)) GENSYM_UNIT_SIMPLE_FUN((=->), (=~>))-GENSYM_FUN((-->), (-~>))-GENSYM_SIMPLE_FUN((-->), (-~>))+GENSYM_FUN((-->), (-~>), SymGeneralFun)+GENSYM_SIMPLE_FUN((-->), (-~>), SymGeneralFun) GENSYM_UNIT_FUN((-->), (-~>)) GENSYM_UNIT_SIMPLE_FUN((-->), (-~>)) #endif

@@ -2,6 +2,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -19,12 +20,15 @@ where  import Control.Monad.Identity (Identity (Identity))+import qualified Data.HashSet as HS import GHC.TypeNats (KnownNat, type (<=)) import Grisette.Internal.SymPrim.FP (ValidFP)-import Grisette.Internal.SymPrim.GeneralFun (type (-->))+import Grisette.Internal.SymPrim.GeneralFun (freshArgSymbol, substTerm, type (-->) (GeneralFun))+import Grisette.Internal.SymPrim.Prim.SomeTerm (SomeTerm (SomeTerm)) import Grisette.Internal.SymPrim.Prim.Term-  ( LinkedRep,-    SupportedPrim (pevalITETerm),+  ( SupportedPrim (pevalITETerm),+    TypedConstantSymbol,+    symTerm,   ) import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal (SymAlgReal)) import Grisette.Internal.SymPrim.SymBV@@ -39,7 +43,6 @@ import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>) (SymGeneralFun)) import Grisette.Internal.SymPrim.SymInteger (SymInteger (SymInteger)) import Grisette.Internal.SymPrim.SymTabularFun (type (=~>) (SymTabularFun))-import Grisette.Internal.SymPrim.TabularFun (type (=->))  -- $setup -- >>> import Grisette.Core@@ -69,7 +72,7 @@   {-# INLINE symIte #-}  #define ITEOP_FUN(cop, op, cons) \-instance (SupportedPrim (cop ca cb), LinkedRep ca sa, LinkedRep cb sb) => ITEOp (op sa sb) where \+instance ITEOp (op sa sb) where \   symIte (SymBool c) (cons t) (cons f) = cons $ pevalITETerm c t f; \   {-# INLINE symIte #-} @@ -83,6 +86,21 @@ ITEOP_FUN((=->), (=~>), SymTabularFun) ITEOP_FUN((-->), (-~>), SymGeneralFun) #endif++instance ITEOp (a --> b) where+  symIte+    (SymBool c)+    (GeneralFun (ta :: TypedConstantSymbol a) a)+    (GeneralFun tb b) =+      GeneralFun argSymbol $+        pevalITETerm+          c+          (substTerm ta (symTerm argSymbol) HS.empty a)+          (substTerm tb (symTerm argSymbol) HS.empty b)+      where+        argSymbol :: TypedConstantSymbol a+        argSymbol = freshArgSymbol [SomeTerm a, SomeTerm b]+  {-# INLINE symIte #-}  instance (ValidFP eb sb) => ITEOp (SymFP eb sb) where   symIte (SymBool c) (SymFP t) (SymFP f) = SymFP $ pevalITETerm c t f

@@ -99,6 +99,7 @@ import Data.Monoid (Alt, Ap, Endo (Endo, appEndo)) import qualified Data.Monoid as Monoid import Data.Ord (Down)+import Data.Ratio (Ratio) import qualified Data.Text as T import Data.Typeable   ( Typeable,@@ -141,10 +142,6 @@     withValidFPProofs,   ) import Grisette.Internal.SymPrim.GeneralFun (type (-->))-import Grisette.Internal.SymPrim.Prim.Term-  ( LinkedRep,-    SupportedPrim,-  ) import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal) import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN) import Grisette.Internal.SymPrim.SymBool (SymBool)@@ -585,7 +582,6 @@ CONCRETE_ORD_MERGEABLE(Word64) CONCRETE_ORD_MERGEABLE(Float) CONCRETE_ORD_MERGEABLE(Double)-CONCRETE_ORD_MERGEABLE(Rational) CONCRETE_ORD_MERGEABLE(B.ByteString) CONCRETE_ORD_MERGEABLE(T.Text) CONCRETE_ORD_MERGEABLE(FPRoundingMode)@@ -596,6 +592,11 @@ CONCRETE_ORD_MERGEABLE_BV(IntN) #endif +instance (Integral a, Typeable a, Show a) => Mergeable (Ratio a) where+  rootStrategy =+    let sub = SimpleStrategy $ \_ t _ -> t+     in SortedStrategy id $ const sub+ instance (ValidFP eb sb) => Mergeable (FP eb sb) where   rootStrategy =     let sub = SimpleStrategy $ \_ t _ -> t@@ -604,6 +605,12 @@             (\fp -> (bitCastOrCanonical fp :: WordN (eb + sb)))           $ const sub +instance Mergeable (a =-> b) where+  rootStrategy = NoStrategy++instance Mergeable (a --> b) where+  rootStrategy = SimpleStrategy symIte+ #define MERGEABLE_SIMPLE(symtype) \ instance Mergeable symtype where \   rootStrategy = SimpleStrategy symIte@@ -612,9 +619,8 @@ instance (KnownNat n, 1 <= n) => Mergeable (symtype n) where \   rootStrategy = SimpleStrategy symIte -#define MERGEABLE_FUN(cop, op) \-instance (SupportedPrim (cop ca cb), LinkedRep ca sa, LinkedRep cb sb) => \-  Mergeable (op sa sb) where \+#define MERGEABLE_FUN(cop, op, consop) \+instance Mergeable (op sa sb) where \   rootStrategy = SimpleStrategy symIte  #if 1@@ -624,8 +630,8 @@ MERGEABLE_SIMPLE(SymAlgReal) MERGEABLE_BV(SymIntN) MERGEABLE_BV(SymWordN)-MERGEABLE_FUN((=->), (=~>))-MERGEABLE_FUN((-->), (-~>))+MERGEABLE_FUN((=->), (=~>), SymTabularFun)+MERGEABLE_FUN((-->), (-~>), SymGeneralFun) #endif  instance (ValidFP eb sb) => Mergeable (SymFP eb sb) where

@@ -106,17 +106,17 @@ -- >>> valueOf bBool (buildModel (aBool ::= True) :: Model) -- Nothing -- >>> insertValue bBool False (buildModel (aBool ::= True) :: Model)--- Model {a -> True :: Bool, b -> False :: Bool}+-- Model {a -> true :: Bool, b -> false :: Bool} -- >>> let abModel = buildModel (aBool ::= True, bBool ::= False) :: Model -- >>> let acSet = buildSymbolSet (aBool, cBool) :: AnySymbolSet -- >>> exceptFor acSet abModel--- Model {b -> False :: Bool}+-- Model {b -> false :: Bool} -- >>> restrictTo acSet abModel--- Model {a -> True :: Bool}+-- Model {a -> true :: Bool} -- >>> extendTo acSet abModel--- Model {a -> True :: Bool, b -> False :: Bool, c -> False :: Bool}+-- Model {a -> true :: Bool, b -> false :: Bool, c -> false :: Bool} -- >>> exact acSet abModel--- Model {a -> True :: Bool, c -> False :: Bool}+-- Model {a -> true :: Bool, c -> false :: Bool} class   (SymbolSetOps symbolSet typedSymbol) =>   ModelOps model symbolSet typedSymbol@@ -166,5 +166,5 @@   -- >>> let aBool = "a" :: TypedAnySymbol Bool   -- >>> let bBool = "b" :: TypedAnySymbol Bool   -- >>> buildModel (aBool ::= True, bBool ::= False) :: Model-  -- Model {a -> True :: Bool, b -> False :: Bool}+  -- Model {a -> true :: Bool, b -> false :: Bool}   buildModel :: rep -> model

@@ -5,6 +5,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuantifiedConstraints #-}@@ -94,6 +95,7 @@ import Data.Monoid (Alt, Ap) import qualified Data.Monoid as Monoid import Data.Ord (Down)+import Data.Ratio (Ratio, denominator, numerator) import Data.String (IsString (fromString)) import qualified Data.Text as T import Data.Word (Word16, Word32, Word64, Word8)@@ -116,6 +118,7 @@     type (:*:) ((:*:)),     type (:+:) (L1, R1),   )+import GHC.Real (ratioPrec, ratioPrec1) import GHC.Stack (HasCallStack) import GHC.TypeLits (KnownNat, type (<=)) import Generics.Deriving@@ -129,17 +132,21 @@ import Grisette.Internal.Core.Data.Symbol (Identifier, Symbol) import Grisette.Internal.SymPrim.AlgReal (AlgReal) import Grisette.Internal.SymPrim.BV (IntN, WordN)-import Grisette.Internal.SymPrim.FP (FP, FPRoundingMode, NotRepresentableFPError, ValidFP)+import Grisette.Internal.SymPrim.FP+  ( FP,+    FPRoundingMode,+    NotRepresentableFPError,+    ValidFP,+  )+import Grisette.Internal.SymPrim.GeneralFun (type (-->)) import Grisette.Internal.SymPrim.Prim.Internal.Term () import Grisette.Internal.SymPrim.Prim.Model   ( Model (Model),     SymbolSet (SymbolSet),   )-import Grisette.Internal.SymPrim.Prim.ModelValue (ModelValue) import Grisette.Internal.SymPrim.Prim.Term-  ( LinkedRep,+  ( ModelValue,     SomeTypedSymbol (SomeTypedSymbol),-    SupportedPrim,     TypedSymbol (unTypedSymbol),     prettyPrintTerm,   )@@ -156,6 +163,7 @@ import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>) (SymGeneralFun)) import Grisette.Internal.SymPrim.SymInteger (SymInteger (SymInteger)) import Grisette.Internal.SymPrim.SymTabularFun (type (=~>) (SymTabularFun))+import Grisette.Internal.SymPrim.TabularFun (type (=->)) import Grisette.Internal.TH.DeriveBuiltin (deriveBuiltins) import Grisette.Internal.TH.DeriveInstanceProvider   ( Strategy (ViaDefault, ViaDefault1),@@ -564,6 +572,13 @@ FORMAT_SIMPLE(AlgReal) #endif +instance (PPrint a) => PPrint (Ratio a) where+  pformatPrec p r =+    condEnclose (p > ratioPrec) "(" ")" $+      pformatPrec ratioPrec1 (numerator r)+        <> "%"+        <> pformatPrec ratioPrec1 (denominator r)+ instance PPrint B.ByteString where   pformat = pretty . C.unpack @@ -579,6 +594,12 @@ instance (ValidFP eb sb) => PPrint (FP eb sb) where   pformat = viaShow +instance (Show a, Show b) => PPrint (a =-> b) where+  pformat = viaShow++instance PPrint (a --> b) where+  pformat = viaShow+ -- Prettyprint #define FORMAT_SYM_SIMPLE(symtype) \ instance PPrint symtype where \@@ -589,8 +610,7 @@   pformat (symtype t) = prettyPrintTerm t  #define FORMAT_SYM_FUN(op, cons) \-instance (SupportedPrim ca, SupportedPrim cb, LinkedRep ca sa, LinkedRep cb sb)\-  => PPrint (sa op sb) where \+instance PPrint (sa op sb) where \   pformat (cons t) = prettyPrintTerm t  #if 1@@ -911,7 +931,7 @@     pformatWithConstructor n "Model" [bodyFormatted]     where       pformatSymbolWithoutType :: SomeTypedSymbol knd -> Doc ann-      pformatSymbolWithoutType (SomeTypedSymbol _ s) = pformat $ unTypedSymbol s+      pformatSymbolWithoutType (SomeTypedSymbol s) = pformat $ unTypedSymbol s       pformatPair :: (SomeTypedSymbol knd, ModelValue) -> Doc ann       pformatPair (s, v) = pformatSymbolWithoutType s <> " -> " <> pformat v       bodyFormatted = pformatListLike "{" "}" $ pformatPair <$> HM.toList m

@@ -95,10 +95,6 @@   ) import Grisette.Internal.SymPrim.FP (ValidFP) import Grisette.Internal.SymPrim.GeneralFun (type (-->))-import Grisette.Internal.SymPrim.Prim.Term-  ( LinkedRep,-    SupportedPrim,-  ) import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal) import Grisette.Internal.SymPrim.SymBV   ( SymIntN,@@ -109,7 +105,6 @@ import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>)) import Grisette.Internal.SymPrim.SymInteger (SymInteger) import Grisette.Internal.SymPrim.SymTabularFun (type (=~>))-import Grisette.Internal.SymPrim.TabularFun (type (=->)) import Grisette.Internal.TH.DeriveBuiltin (deriveBuiltins) import Grisette.Internal.TH.DeriveInstanceProvider   ( Strategy (ViaDefault, ViaDefault1),@@ -820,8 +815,7 @@   {-# INLINE mrgIte #-}  #define SIMPLE_MERGEABLE_FUN(cop, op) \-instance (SupportedPrim (cop ca cb), LinkedRep ca sa, LinkedRep cb sb) => \-  SimpleMergeable (op sa sb) where \+instance SimpleMergeable (op sa sb) where \   mrgIte = symIte; \   {-# INLINE mrgIte #-} @@ -835,6 +829,10 @@ SIMPLE_MERGEABLE_FUN((=->), (=~>)) SIMPLE_MERGEABLE_FUN((-->), (-~>)) #endif++instance SimpleMergeable (a --> b) where+  mrgIte = symIte+  {-# INLINE mrgIte #-}  instance (ValidFP eb sb) => SimpleMergeable (SymFP eb sb) where   mrgIte = symIte

@@ -28,10 +28,11 @@ where  import Data.String (IsString)+import qualified Data.Text as T import Grisette.Internal.Core.Data.Symbol   ( Identifier,     Symbol (IndexedSymbol, SimpleSymbol),-    withLoc,+    withLocation,   ) import Language.Haskell.TH.Syntax.Compat (SpliceQ) @@ -114,7 +115,7 @@ -- attached to the identifier. -- -- >>> $$(slocsym "a") :: SymBool--- a:<interactive>:...+-- a:[grisette-file-location <interactive>...] -- -- Calling 'slocsym' with the same name at different location will always -- generate different symbolic constants. Calling 'slocsym' at the same@@ -125,17 +126,17 @@ -- >>> let f _ = $$(slocsym "a") :: SymBool -- >>> f () == f () -- True-slocsym :: (Solvable c s) => Identifier -> SpliceQ s-slocsym nm = [||ssym $$(withLoc nm)||]+slocsym :: (Solvable c s) => T.Text -> SpliceQ s+slocsym nm = [||ssym $$(withLocation nm)||]  -- | Generate indexed symbolic variables. The file location will be attached to -- the identifier. -- -- >>> $$(ilocsym "a" 1) :: SymBool--- a:<interactive>:...@1+-- a:[grisette-file-location <interactive>...]@1 -- -- Calling 'ilocsym' with the same name and index at different location will -- always generate different symbolic constants. Calling 'slocsym' at the same -- location for multiple times will generate the same symbolic constants.-ilocsym :: (Solvable c s) => Identifier -> Int -> SpliceQ s-ilocsym nm idx = [||isym $$(withLoc nm) idx||]+ilocsym :: (Solvable c s) => T.Text -> Int -> SpliceQ s+ilocsym nm idx = [||isym $$(withLocation nm) idx||]

@@ -4,6 +4,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveLift #-}+{-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-}@@ -54,16 +55,22 @@ where  import Control.DeepSeq (NFData)-import Control.Exception (SomeException, mask, onException)+import Control.Exception (mask, onException) import Control.Monad.Except (ExceptT, runExceptT)+import qualified Data.Binary as Binary+import Data.Bytes.Serial (Serial (deserialize, serialize)) import qualified Data.HashSet as S import Data.Hashable (Hashable) import Data.Maybe (fromJust)+import qualified Data.Serialize as Cereal+import qualified Data.Text as T import GHC.Generics (Generic)+import Generics.Deriving (Default (Default)) import Grisette.Internal.Core.Data.Class.ExtractSym   ( ExtractSym (extractSym),   ) import Grisette.Internal.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.||)))+import Grisette.Internal.Core.Data.Class.PPrint (PPrint) import Grisette.Internal.Core.Data.Class.PlainUnion   ( PlainUnion,     simpleMerge,@@ -100,11 +107,21 @@   | -- | The solver has reached the maximum number of models to return.     ResultNumLimitReached   | -- | The solver has encountered an error.-    SolvingError SomeException+    SolvingError T.Text   | -- | The solver has been terminated.     Terminated-  deriving (Show)+  deriving (Show, Eq, Generic, Lift)+  deriving anyclass (NFData, Hashable, Serial)+  deriving (PPrint) via (Default SolvingFailure) +instance Cereal.Serialize SolvingFailure where+  put = serialize+  get = deserialize++instance Binary.Binary SolvingFailure where+  put = serialize+  get = deserialize+ -- | A monadic solver interface. -- -- This interface abstract the monadic interface of a solver. All the operations@@ -127,7 +144,7 @@  -- | The commands that can be sent to a solver. data SolverCommand-  = SolverAssert SymBool+  = SolverAssert !SymBool   | SolverCheckSat   | SolverPush Int   | SolverPop Int@@ -167,7 +184,7 @@   --   -- >>> solver <- newSolver z3   -- >>> solverSolve solver "a"-  -- Right (Model {a -> True :: Bool})+  -- Right (Model {a -> true :: Bool})   -- >>> solverSolve solver $ symNot "a"   -- Left Unsat   --@@ -176,7 +193,7 @@   -- >>> solverResetAssertions solver   -- Right ()   -- >>> solverSolve solver $ symNot "a"-  -- Right (Model {a -> False :: Bool})+  -- Right (Model {a -> false :: Bool})   solverResetAssertions :: handle -> IO (Either SolvingFailure ())   solverResetAssertions handle =     solverRunCommand (const $ return $ Right ()) handle SolverResetAssertions@@ -221,7 +238,7 @@       | otherwise = do           let newFormula =                 S.foldl'-                  ( \acc (SomeTypedSymbol _ v) ->+                  ( \acc (SomeTypedSymbol v) ->                       acc                         .|| (symNot (SymBool $ fromJust $ equation v prevModel))                   )@@ -313,7 +330,7 @@ -- | Solve a single formula. Find an assignment to it to make it true. -- -- >>> solve z3 ("a" .&& ("b" :: SymInteger) .== 1)--- Right (Model {a -> True :: Bool, b -> 1 :: Integer})+-- Right (Model {a -> true :: Bool, b -> 1 :: Integer}) -- >>> solve z3 ("a" .&& symNot "a") -- Left Unsat solve ::

@@ -51,11 +51,13 @@ import Data.Functor.Const (Const) import Data.Functor.Product (Product) import Data.Functor.Sum (Sum)+import qualified Data.HashSet as HS import Data.Int (Int16, Int32, Int64, Int8) import Data.Kind (Type) import Data.Monoid (Alt, Ap) import qualified Data.Monoid as Monoid import Data.Ord (Down)+import Data.Ratio (Ratio, denominator, numerator, (%)) import qualified Data.Text as T import Data.Word (Word16, Word32, Word64, Word8) import GHC.TypeNats (KnownNat, type (<=))@@ -81,14 +83,20 @@   ) import Grisette.Internal.SymPrim.AlgReal (AlgReal) import Grisette.Internal.SymPrim.BV (IntN, WordN)-import Grisette.Internal.SymPrim.FP (FP, FPRoundingMode, NotRepresentableFPError, ValidFP)-import Grisette.Internal.SymPrim.GeneralFun (substTerm, type (-->))+import Grisette.Internal.SymPrim.FP+  ( FP,+    FPRoundingMode,+    NotRepresentableFPError,+    ValidFP,+  )+import Grisette.Internal.SymPrim.GeneralFun (substTerm, type (-->) (GeneralFun)) import Grisette.Internal.SymPrim.Prim.Term   ( IsSymbolKind,     LinkedRep (underlyingTerm),-    SupportedPrim,+    SymRep (SymType),     SymbolKind,     TypedSymbol,+    someTypedSymbol,   ) import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal (SymAlgReal)) import Grisette.Internal.SymPrim.SymBV@@ -103,7 +111,7 @@ import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>) (SymGeneralFun)) import Grisette.Internal.SymPrim.SymInteger (SymInteger (SymInteger)) import Grisette.Internal.SymPrim.SymTabularFun (type (=~>) (SymTabularFun))-import Grisette.Internal.SymPrim.TabularFun (type (=->))+import Grisette.Internal.SymPrim.TabularFun (type (=->) (TabularFun)) import Grisette.Internal.TH.DeriveBuiltin (deriveBuiltins) import Grisette.Internal.TH.DeriveInstanceProvider   ( Strategy (ViaDefault, ViaDefault1),@@ -328,21 +336,28 @@ CONCRETE_SUBSTITUTESYM(AlgReal) #endif +instance (Integral a, SubstSym a) => SubstSym (Ratio a) where+  substSym sym val a =+    substSym sym val (numerator a) % substSym sym val (denominator a)+  {-# INLINE substSym #-}+ instance (ValidFP eb sb) => SubstSym (FP eb sb) where   substSym _ _ = id  #define SUBSTITUTE_SYM_SIMPLE(symtype) \ instance SubstSym symtype where \-  substSym sym v (symtype t) = symtype $ substTerm sym (underlyingTerm v) t+  substSym sym v (symtype t) = \+    symtype $ substTerm sym (underlyingTerm v) HS.empty t  #define SUBSTITUTE_SYM_BV(symtype) \ instance (KnownNat n, 1 <= n) => SubstSym (symtype n) where \-  substSym sym v (symtype t) = symtype $ substTerm sym (underlyingTerm v) t+  substSym sym v (symtype t) = \+    symtype $ substTerm sym (underlyingTerm v) HS.empty t -#define SUBSTITUTE_SYM_FUN(cop, op, cons) \-instance (SupportedPrim (cop ca cb), LinkedRep ca sa, LinkedRep cb sb) => \-  SubstSym (op sa sb) where \-  substSym sym v (cons t) = cons $ substTerm sym (underlyingTerm v) t+#define SUBSTITUTE_SYM_FUN(op, cons) \+instance SubstSym (op sa sb) where \+  substSym sym v (cons t) = \+    cons $ substTerm sym (underlyingTerm v) HS.empty t  #if 1 SUBSTITUTE_SYM_SIMPLE(SymBool)@@ -350,13 +365,13 @@ SUBSTITUTE_SYM_SIMPLE(SymAlgReal) SUBSTITUTE_SYM_BV(SymIntN) SUBSTITUTE_SYM_BV(SymWordN)-SUBSTITUTE_SYM_FUN((=->), (=~>), SymTabularFun)-SUBSTITUTE_SYM_FUN((-->), (-~>), SymGeneralFun)+SUBSTITUTE_SYM_FUN((=~>), SymTabularFun)+SUBSTITUTE_SYM_FUN((-~>), SymGeneralFun) SUBSTITUTE_SYM_SIMPLE(SymFPRoundingMode) #endif  instance (ValidFP eb sb) => SubstSym (SymFP eb sb) where-  substSym sym v (SymFP t) = SymFP $ substTerm sym (underlyingTerm v) t+  substSym sym v (SymFP t) = SymFP $ substTerm sym (underlyingTerm v) HS.empty t  -- Instances deriveBuiltins@@ -627,3 +642,14 @@   liftSubstSym2 f g sym val (x, y, z, w) =     (substSym sym val x, substSym sym val y, f sym val z, g sym val w)   {-# INLINE liftSubstSym2 #-}++instance (SubstSym a, SubstSym b) => SubstSym (a =-> b) where+  substSym sym val (TabularFun f d) =+    TabularFun (substSym sym val f) (substSym sym val d)+  {-# INLINE substSym #-}++instance (SubstSym (SymType b)) => SubstSym (a --> b) where+  substSym sym val (GeneralFun s t) =+    GeneralFun s $+      substTerm sym (underlyingTerm val) (HS.singleton $ someTypedSymbol s) t+  {-# INLINE substSym #-}

@@ -61,6 +61,7 @@ import Data.Monoid (Alt, Ap) import qualified Data.Monoid as Monoid import Data.Ord (Down)+import Data.Ratio (Ratio, denominator, numerator) import qualified Data.Text as T import Data.Word (Word16, Word32, Word64, Word8) import GHC.TypeNats (KnownNat, type (<=))@@ -342,6 +343,10 @@ CONCRETE_SEQ_BV(IntN) CONCRETE_SEQ(AlgReal) #endif++instance (SymEq a) => SymEq (Ratio a) where+  a .== b = numerator a .== numerator b .&& denominator a .== denominator b+  {-# INLINE (.==) #-}  instance (ValidFP eb sb) => SymEq (FP eb sb) where   l .== r = con $ l == r

@@ -63,6 +63,7 @@ import Data.Monoid (Alt, Ap) import qualified Data.Monoid as Monoid import Data.Ord (Down (Down))+import Data.Ratio (Ratio, denominator, numerator) import qualified Data.Text as T import Data.Word (Word16, Word32, Word64, Word8) import GHC.TypeLits (KnownNat, type (<=))@@ -428,6 +429,12 @@ CONCRETE_SORD_BV(IntN) CONCRETE_SORD(AlgReal) #endif++instance (SymOrd a, Integral a) => SymOrd (Ratio a) where+  a .<= b = numerator a * denominator b .<= numerator b * denominator a+  {-# INLINE (.<=) #-}+  a .< b = numerator a * denominator b .< numerator b * denominator a+  {-# INLINE (.<) #-}  instance (ValidFP eb sb) => SymOrd (FP eb sb) where   l .<= r = con $ l <= r

@@ -58,6 +58,7 @@ import Data.Monoid (Alt, Ap) import qualified Data.Monoid as Monoid import Data.Ord (Down)+import Data.Ratio (Ratio, denominator, numerator, (%)) import qualified Data.Text as T import Data.Word (Word16, Word32, Word64, Word8) import GHC.Generics@@ -85,18 +86,22 @@   ( Solvable (conView),     pattern Con,   )-import Grisette.Internal.SymPrim.AlgReal (AlgReal)+import Grisette.Internal.SymPrim.AlgReal (AlgReal (AlgExactRational)) import Grisette.Internal.SymPrim.BV   ( IntN (IntN),     WordN (WordN),   )-import Grisette.Internal.SymPrim.FP (FP, FP32, FP64, FPRoundingMode, NotRepresentableFPError, ValidFP)+import Grisette.Internal.SymPrim.FP+  ( FP,+    FP32,+    FP64,+    FPRoundingMode,+    NotRepresentableFPError,+    ValidFP,+  ) import Grisette.Internal.SymPrim.GeneralFun (type (-->)) import Grisette.Internal.SymPrim.IntBitwidth (intBitwidthQ)-import Grisette.Internal.SymPrim.Prim.Term-  ( LinkedRep,-    SupportedPrim,-  )+import Grisette.Internal.SymPrim.Prim.Term (LinkedRep) import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal) import Grisette.Internal.SymPrim.SymBV   ( SymIntN,@@ -109,9 +114,9 @@     SymFP64,     SymFPRoundingMode,   )-import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>))+import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>) (SymGeneralFun)) import Grisette.Internal.SymPrim.SymInteger (SymInteger)-import Grisette.Internal.SymPrim.SymTabularFun (type (=~>))+import Grisette.Internal.SymPrim.SymTabularFun (type (=~>) (SymTabularFun)) import Grisette.Internal.SymPrim.TabularFun (type (=->)) import Grisette.Internal.TH.DeriveBuiltin (deriveBuiltins) import Grisette.Internal.TH.DeriveInstanceProvider@@ -303,16 +308,22 @@ instance (ValidFP eb sb) => ToCon (FP eb sb) (FP eb sb) where   toCon = Just +instance ToCon (a =-> b) (a =-> b) where+  toCon = Just++instance ToCon (a --> b) (a --> b) where+  toCon = Just+ #define TO_CON_SYMID_SIMPLE(symtype) \ instance ToCon symtype symtype where \   toCon = Just  #define TO_CON_SYMID_BV(symtype) \-instance (KnownNat n, 1 <= n) => ToCon (symtype n) (symtype n) where \+instance ToCon (symtype n) (symtype n) where \   toCon = Just  #define TO_CON_SYMID_FUN(op) \-instance (SupportedPrim a, SupportedPrim b) => ToCon (a op b) (a op b) where \+instance ToCon (a op b) (a op b) where \   toCon = Just  #if 1@@ -337,10 +348,9 @@ instance (KnownNat n, 1 <= n) => ToCon (symtype n) (contype n) where \   toCon = conView -#define TO_CON_FROMSYM_FUN(conop, symop) \-instance (SupportedPrim (conop ca cb), LinkedRep ca sa, LinkedRep cb sb) => \-  ToCon (symop sa sb) (conop ca cb) where \-  toCon = conView+#define TO_CON_FROMSYM_FUN(conop, symop, consop) \+instance (LinkedRep ca sa, LinkedRep cb sb) => ToCon (symop sa sb) (conop ca cb) where \+  toCon a@(consop _) = conView a  #if 1 TO_CON_FROMSYM_SIMPLE(Bool, SymBool)@@ -348,8 +358,8 @@ TO_CON_FROMSYM_SIMPLE(AlgReal, SymAlgReal) TO_CON_FROMSYM_BV(IntN, SymIntN) TO_CON_FROMSYM_BV(WordN, SymWordN)-TO_CON_FROMSYM_FUN((=->), (=~>))-TO_CON_FROMSYM_FUN((-->), (-~>))+TO_CON_FROMSYM_FUN((=->), (=~>), SymTabularFun)+TO_CON_FROMSYM_FUN((-->), (-~>), SymGeneralFun) TO_CON_FROMSYM_SIMPLE(FPRoundingMode, SymFPRoundingMode) #endif @@ -380,6 +390,19 @@  instance ToCon SymFP64 Double where   toCon (Con (fp :: FP64)) = Just $ bitCastOrCanonical fp+  toCon _ = Nothing++instance (ToCon a b, Integral b) => ToCon (Ratio a) (Ratio b) where+  toCon r = do+    n <- toCon (numerator r)+    d <- toCon (denominator r)+    return $ n % d++instance ToCon SymAlgReal Rational where+  toCon (Con (x :: AlgReal)) =+    case x of+      AlgExactRational r -> Just r+      _ -> Nothing   toCon _ = Nothing  deriveBuiltins

@@ -62,7 +62,9 @@ import Data.Monoid (Alt, Ap) import qualified Data.Monoid as Monoid import Data.Ord (Down)+import Data.Ratio (Ratio, denominator, numerator, (%)) import qualified Data.Text as T+import Data.Typeable (Typeable) import Data.Word (Word16, Word32, Word64, Word8) import GHC.TypeNats (KnownNat, type (<=)) import Generics.Deriving@@ -108,6 +110,7 @@ import Grisette.Internal.SymPrim.IntBitwidth (intBitwidthQ) import Grisette.Internal.SymPrim.Prim.Term   ( LinkedRep,+    SupportedNonFuncPrim,     SupportedPrim,   ) import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal)@@ -323,6 +326,12 @@ instance (ValidFP eb sb) => ToSym (FP eb sb) (FP eb sb) where   toSym = id +instance ToSym (a =-> b) (a =-> b) where+  toSym = id++instance ToSym (a --> b) (a --> b) where+  toSym = id+ #define TO_SYM_SYMID_SIMPLE(symtype) \ instance ToSym symtype symtype where \   toSym = id@@ -359,7 +368,7 @@   toSym = con  #define TO_SYM_FROMCON_FUN(conop, symop) \-instance (SupportedPrim (conop ca cb), LinkedRep ca sa, LinkedRep cb sb) => \+instance (SupportedPrim (conop ca cb), SupportedNonFuncPrim ca, LinkedRep ca sa, LinkedRep cb sb) => \   ToSym (conop ca cb) (symop sa sb) where \   toSym = con @@ -401,6 +410,16 @@ instance ToSym Double SymFP64 where   toSym = con . bitCast   {-# INLINE toSym #-}++instance+  (Integral b, Typeable b, Show b, ToSym a b) =>+  ToSym (Ratio a) (Ratio b)+  where+  toSym r = toSym (numerator r) % toSym (denominator r)+  {-# INLINE toSym #-}++instance ToSym Rational SymAlgReal where+  toSym v = con (fromRational v)  deriveBuiltins   (ViaDefault ''ToSym)

@@ -1,7 +1,10 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}  -- | -- Module      :   Grisette.Internal.Core.Data.MemoUtils@@ -12,33 +15,173 @@ -- Stability   :   Experimental -- Portability :   GHC only module Grisette.Internal.Core.Data.MemoUtils-  ( -- * Hashtable-based memoization+  ( -- * Memoization+    stableMemo,+    stableMemo2,+    stableMemo3,+    stableMup,+    stableMemoFix,+    weakStableMemo,+    weakStableMemo2,+    weakStableMemo3,+    weakStableMup,+    weakStableMemoFix,     htmemo,     htmemo2,     htmemo3,-    htmup,     htmemoFix,+    htmup,   ) where -import Data.Function (fix)-import qualified Data.HashTable.IO as H+import Control.Applicative (Const (Const, getConst))+import Control.Monad.Fix (fix)+import Data.Atomics (atomicModifyIORefCAS_)+import qualified Data.HashMap.Strict as HM import Data.Hashable (Hashable)+import Data.IORef (IORef, newIORef, readIORef)+import Data.Proxy (Proxy (Proxy))+import GHC.Base (Any, Type) import System.IO.Unsafe (unsafePerformIO)+import System.Mem.StableName (StableName, makeStableName)+import System.Mem.Weak (Weak)+import qualified System.Mem.Weak as Weak+import Unsafe.Coerce (unsafeCoerce) -type HashTable k v = H.BasicHashTable k v+newtype (f <<< g) a = O {unO :: f (g a)} +-- Invariant: The type parameters for a key and its corresponding+-- value are the same.+type SNMap f g = IORef (HM.HashMap (StableName (f Any)) (g Any))++type MemoTable ref f g = SNMap f (ref <<< g)++class Ref ref where+  mkRef :: a -> b -> IO () -> IO (ref b)+  deRef :: ref a -> IO (Maybe a)+  finalize :: ref a -> IO ()+  tableFinalizer :: MemoTable ref f g -> IO ()+  tableFinalizer t = readIORef t >>= mapM_ (finalize . unO)++instance Ref Weak where+  mkRef x y = Weak.mkWeak x y . Just+  deRef = Weak.deRefWeak+  finalize = Weak.finalize++newtype Strong a = Strong a++instance Ref Strong where+  mkRef _ y _ = return $ Strong y+  deRef (Strong x) = return $ Just x+  finalize (Strong _) = return ()+  tableFinalizer _ = return ()++finalizer :: StableName (f Any) -> Weak (MemoTable ref f g) -> IO ()+finalizer sn weakTbl = do+  r <- Weak.deRefWeak weakTbl+  case r of+    Nothing -> return ()+    Just tbl -> do+      atomicModifyIORefCAS_ tbl $ HM.delete sn++unsafeToAny :: f a -> f Any+unsafeToAny = unsafeCoerce++unsafeFromAny :: f Any -> f a+unsafeFromAny = unsafeCoerce++{-# NOINLINE memo' #-}+memo' ::+  (Ref ref) =>+  Proxy ref ->+  (forall a. f a -> g a) ->+  MemoTable ref f g ->+  Weak (MemoTable ref f g) ->+  f b ->+  g b+memo' _ f tbl weakTbl !x = unsafePerformIO $ do+  sn <- makeStableName $ unsafeToAny x+  lkp <- HM.lookup sn <$> readIORef tbl+  case lkp of+    Nothing -> notFound sn+    Just (O w) -> do+      maybeVal <- deRef w+      case maybeVal of+        Nothing -> notFound sn+        Just val -> do+          return $ unsafeFromAny val+  where+    notFound sn = do+      let !y = f x+      weak <- mkRef x (unsafeToAny y) $ finalizer sn weakTbl+      atomicModifyIORefCAS_ tbl $ HM.insert sn $ O weak+      return y++{-# NOINLINE memo0 #-}+memo0 ::+  (Ref ref) =>+  Proxy (ref :: Type -> Type) ->+  (forall a. f a -> g a) ->+  f b ->+  g b+memo0 p f =+  let (tbl, weak) = unsafePerformIO $ do+        tbl' <- newIORef HM.empty+        weak' <- Weak.mkWeakPtr tbl . Just $ tableFinalizer tbl+        return (tbl', weak')+   in memo' p f tbl weak++-- | Memoize a unary function.+stableMemo :: (a -> b) -> (a -> b)+stableMemo f = getConst . memo0 (Proxy :: Proxy Strong) (Const . f . getConst) . Const++-- | Lift a memoizer to work with one more argument.+stableMup :: (b -> c) -> (a -> b) -> (a -> c)+stableMup mem f = stableMemo (mem . f)++-- | Curried memoization to share partial evaluation+stableMemo2 :: (a -> b -> c) -> (a -> b -> c)+stableMemo2 = stableMup stableMemo++-- | Curried memoization to share partial evaluation+stableMemo3 :: (a -> b -> c -> d) -> (a -> b -> c -> d)+stableMemo3 = stableMup stableMemo2++-- | Memoizing recursion. Use like 'fix'.+stableMemoFix :: ((a -> b) -> (a -> b)) -> a -> b+stableMemoFix h = fix (stableMemo . h)++-- | Memoize a unary function.+weakStableMemo :: (a -> b) -> (a -> b)+weakStableMemo f = getConst . memo0 (Proxy :: Proxy Weak) (Const . f . getConst) . Const++-- | Lift a memoizer to work with one more argument.+weakStableMup :: (b -> c) -> (a -> b) -> (a -> c)+weakStableMup mem f = weakStableMemo (mem . f)++-- | Curried memoization to share partial evaluation+weakStableMemo2 :: (a -> b -> c) -> (a -> b -> c)+weakStableMemo2 = weakStableMup weakStableMemo++-- | Curried memoization to share partial evaluation+weakStableMemo3 :: (a -> b -> c -> d) -> (a -> b -> c -> d)+weakStableMemo3 = weakStableMup weakStableMemo2++-- | Memoizing recursion. Use like 'fix'.+weakStableMemoFix :: ((a -> b) -> (a -> b)) -> a -> b+weakStableMemoFix h = fix (weakStableMemo . h)+ -- | Function memoizer with mutable hash table.+{-# NOINLINE htmemo #-} htmemo :: (Eq k, Hashable k) => (k -> a) -> k -> a htmemo f = unsafePerformIO $ do-  cache <- H.new :: IO (HashTable k v)-  return $ \x -> unsafePerformIO $ do-    tryV <- H.lookup cache x+  cache <- newIORef HM.empty+  return $ \(!x) -> unsafePerformIO $ do+    tryV <- HM.lookup x <$> readIORef cache     case tryV of       Nothing -> do-        -- traceM "New value"-        let v = f x-        H.insert cache x v+        let !v = f x+        atomicModifyIORefCAS_ cache $ \old -> HM.insert x v old         return v       Just v -> return v 

@@ -0,0 +1,88 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Unused LANGUAGE pragma" #-}++-- |+-- Module      :   Grisette.Internal.Core.Data.SExpr+-- Copyright   :   (c) Sirui Lu 2024+-- License     :   BSD-3-Clause (see the LICENSE file)+--+-- Maintainer  :   siruilu@cs.washington.edu+-- Stability   :   Experimental+-- Portability :   GHC only+module Grisette.Internal.Core.Data.SExpr+  ( SExpr (..),+    showsSExprWithParens,+    parseFileLocation,+    fileLocation,+  )+where++import Control.DeepSeq (NFData)+import qualified Data.Binary as Binary+import Data.Bytes.Serial (Serial (deserialize, serialize))+import Data.Hashable (Hashable)+import qualified Data.Serialize as Cereal+import Data.Serialize.Text ()+import qualified Data.Text as T+import Debug.Trace.LocationTH (__LOCATION__)+import GHC.Generics (Generic)+import Language.Haskell.TH.Syntax (Lift, unsafeTExpCoerce)+import Language.Haskell.TH.Syntax.Compat (SpliceQ, liftSplice)++-- | S-expression data type. Used for symbol metadata.+data SExpr = Atom T.Text | List [SExpr] | NumberAtom Integer | BoolAtom Bool+  deriving stock (Eq, Ord, Generic, Lift)+  deriving anyclass (Hashable, NFData, Serial)++instance Cereal.Serialize SExpr where+  put = serialize+  get = deserialize++instance Binary.Binary SExpr where+  put = serialize+  get = deserialize++instance Show SExpr where+  showsPrec _ = showsSExprWithParens '(' ')'++unwordsS :: [ShowS] -> ShowS+unwordsS [] = id+unwordsS [x] = x+unwordsS (x : xs) = x . showString " " . unwordsS xs++-- | Show an S-expression with specific parentheses.+showsSExprWithParens :: Char -> Char -> SExpr -> ShowS+showsSExprWithParens _ _ (Atom s) = showString $ T.unpack s+showsSExprWithParens lp rp (List l) =+  showString [lp] . unwordsS (map shows l) . (showString [rp])+showsSExprWithParens _ _ (NumberAtom n) = shows n+showsSExprWithParens _ _ (BoolAtom b) = showString $ if b then "#t" else "#f"++-- | Parse a file location string into an S-expression.+parseFileLocation :: String -> SExpr+parseFileLocation str =+  let r = reverse str+      (s2, r1) = break (== '-') r+      (s1, r2) = break (== ':') $ tail r1+      (l, p) = break (== ':') $ tail r2+   in List+        [ Atom "grisette-file-location",+          Atom $ T.pack $ reverse $ tail p,+          NumberAtom $ read $ reverse l,+          List+            [ NumberAtom $ read $ reverse s1,+              NumberAtom $ read $ reverse s2+            ]+        ]++-- | Get the file location of the splice.+fileLocation :: SpliceQ SExpr+fileLocation =+  [||parseFileLocation $$(liftSplice $ unsafeTExpCoerce __LOCATION__)||]

@@ -23,29 +23,40 @@ module Grisette.Internal.Core.Data.Symbol   ( Identifier (..),     identifier,-    withInfo,-    withLoc,+    withMetadata,+    withLocation,+    mapMetadata,     uniqueIdentifier,     Symbol (..),     simple,     indexed,     symbolIdentifier,-    modifyIdentifier,+    mapIdentifier,   ) where -import Control.DeepSeq (NFData (rnf))+import Control.DeepSeq (NFData)+import qualified Data.Binary as Binary+import Data.Bytes.Serial (Serial (deserialize, serialize)) import Data.Hashable (Hashable (hashWithSalt)) import Data.IORef (IORef, atomicModifyIORef', newIORef)+import qualified Data.Serialize as Cereal import Data.String (IsString (fromString)) import qualified Data.Text as T-import Data.Typeable (Proxy (Proxy), Typeable, eqT, typeRep, type (:~:) (Refl))-import Debug.Trace.LocationTH (__LOCATION__) import GHC.Generics (Generic) import GHC.IO (unsafePerformIO)-import Language.Haskell.TH.Syntax (Lift (liftTyped), unsafeTExpCoerce)-import Language.Haskell.TH.Syntax.Compat (SpliceQ, liftSplice)+import Grisette.Internal.Core.Data.SExpr+  ( SExpr (Atom, List, NumberAtom),+    fileLocation,+    showsSExprWithParens,+  )+import Language.Haskell.TH.Syntax (Lift)+import Language.Haskell.TH.Syntax.Compat (SpliceQ) +-- $setup+-- >>> import Grisette.Core+-- >>> import Grisette.SymPrim+ -- | Identifier type used for 'Grisette.Core.GenSym' -- -- The constructor is hidden intentionally.@@ -64,12 +75,12 @@ --     >>> "a" :: Identifier -- available when OverloadedStrings is enabled --     a -----   * bundle the identifier with some user provided information+--   * bundle the identifier with some user provided metadata -- --     Identifiers created with different name or different additional --     information will not be the same. -----     >>> withInfo "a" (1 :: Int)+--     >>> withMetadata "a" (NumberAtom 1) --     a:1 -- --   * bundle the calling file location with the identifier to ensure global@@ -78,62 +89,29 @@ --     Identifiers created at different locations will not be the --     same. The identifiers created at the same location will be the same. -----     >>> $$(withLoc "a") -- a sample result could be "a:<interactive>:18:4-18"---     a:<interactive>:...-data Identifier where-  Identifier :: T.Text -> Identifier-  IdentifierWithInfo ::-    ( Typeable a,-      Ord a,-      Lift a,-      NFData a,-      Show a,-      Hashable a-    ) =>-    Identifier ->-    a ->-    Identifier--instance Show Identifier where-  show (Identifier i) = T.unpack i-  show (IdentifierWithInfo s i) = show s ++ ":" ++ show i--instance IsString Identifier where-  fromString = Identifier . T.pack--instance Eq Identifier where-  Identifier l == Identifier r = l == r-  IdentifierWithInfo l (linfo :: linfo)-    == IdentifierWithInfo r (rinfo :: rinfo) = case eqT @linfo @rinfo of-      Just Refl -> l == r && linfo == rinfo-      _ -> False-  _ == _ = False+--     >>> $$(withLocation "a") -- a sample result could be "a:[grisette-file-location <interactive> 18 (4 18)]"+--     a:[grisette-file-location <interactive>...]+data Identifier = Identifier {baseIdent :: T.Text, metadata :: SExpr}+  deriving (Eq, Ord, Generic, Lift)+  deriving anyclass (Hashable, NFData, Serial) -instance Ord Identifier where-  Identifier l <= Identifier r = l <= r-  Identifier _ <= _ = True-  _ <= Identifier _ = False-  IdentifierWithInfo l (linfo :: linfo)-    <= IdentifierWithInfo r (rinfo :: rinfo) =-      l < r-        || ( l == r-               && ( case eqT @linfo @rinfo of-                      Just Refl -> linfo <= rinfo-                      _ -> typeRep (Proxy @linfo) <= typeRep (Proxy @rinfo)-                  )-           )+instance Cereal.Serialize Identifier where+  put = serialize+  get = deserialize -instance Hashable Identifier where-  hashWithSalt s (Identifier n) = s `hashWithSalt` n-  hashWithSalt s (IdentifierWithInfo n i) = s `hashWithSalt` n `hashWithSalt` i+instance Binary.Binary Identifier where+  put = serialize+  get = deserialize -instance Lift Identifier where-  liftTyped (Identifier n) = [||Identifier n||]-  liftTyped (IdentifierWithInfo n i) = [||IdentifierWithInfo n i||]+instance Show Identifier where+  showsPrec _ (Identifier i (List [])) = showString (T.unpack i)+  showsPrec _ (Identifier i metadata) =+    showString (T.unpack i)+      . showString ":"+      . showsSExprWithParens '[' ']' metadata -instance NFData Identifier where-  rnf (Identifier n) = rnf n-  rnf (IdentifierWithInfo n i) = rnf n `seq` rnf i+instance IsString Identifier where+  fromString i = Identifier (T.pack i) $ List []  -- | Simple identifier. -- The same identifier refers to the same symbolic variable in the whole@@ -142,79 +120,38 @@ -- The user may need to use unique identifiers to avoid unintentional identifier -- collision. identifier :: T.Text -> Identifier-identifier = Identifier+identifier = flip Identifier $ List [] --- | Identifier with extra information.+-- | Identifier with extra metadata. ----- The same identifier with the same information refers to the same symbolic+-- The same identifier with the same metadata refers to the same symbolic -- variable in the whole program. ----- The user may need to use unique identifiers or additional information to+-- The user may need to use unique identifiers or additional metadata to -- avoid unintentional identifier collision.-withInfo ::-  (Typeable a, Ord a, Lift a, NFData a, Show a, Hashable a) =>-  Identifier ->-  a ->-  Identifier-withInfo = IdentifierWithInfo---- $setup--- >>> import Grisette.Core--- >>> import Grisette.SymPrim---- File location type.-data FileLocation = FileLocation-  { locPath :: String,-    locLineno :: Int,-    locSpan :: (Int, Int)-  }-  deriving (Eq, Ord, Generic, Lift, NFData, Hashable)--instance Show FileLocation where-  show (FileLocation p l (s1, s2)) =-    p ++ ":" ++ show l ++ ":" ++ show s1 ++ "-" ++ show s2+withMetadata :: T.Text -> SExpr -> Identifier+withMetadata = Identifier -parseFileLocation :: String -> FileLocation-parseFileLocation str =-  let r = reverse str-      (s2, r1) = break (== '-') r-      (s1, r2) = break (== ':') $ tail r1-      (l, p) = break (== ':') $ tail r2-   in FileLocation-        (reverse $ tail p)-        (read $ reverse l)-        (read $ reverse s1, read $ reverse s2)+-- | Identifier with the file location.+withLocation :: T.Text -> SpliceQ Identifier+withLocation nm = [||withMetadata nm $$fileLocation||] --- | Identifier with the current location as extra information.------ >>> $$(withLoc "a") -- a sample result could be "a:<interactive>:18:4-18"--- a:<interactive>:...------ The uniqueness is ensured for the call to 'identifier' at different location.-withLoc :: Identifier -> SpliceQ Identifier-withLoc s =-  [||-  withInfo-    s-    (parseFileLocation $$(liftSplice $ unsafeTExpCoerce __LOCATION__))-  ||]+-- | Modify the metadata of an identifier.+mapMetadata :: (SExpr -> SExpr) -> Identifier -> Identifier+mapMetadata f (Identifier i m) = Identifier i (f m)  identifierCount :: IORef Int identifierCount = unsafePerformIO $ newIORef 0 {-# NOINLINE identifierCount #-} -newtype UniqueCount = UniqueCount Int-  deriving newtype (Eq, Ord, NFData, Hashable)-  deriving (Lift)--instance Show UniqueCount where-  show (UniqueCount i) = "unique<" <> show i <> ">"- -- | Get a globally unique identifier within the 'IO' monad. uniqueIdentifier :: T.Text -> IO Identifier uniqueIdentifier ident = do   i <- atomicModifyIORef' identifierCount (\x -> (x + 1, x))-  return $ withInfo (identifier ident) (UniqueCount i)+  return $+    withMetadata+      ident+      (List [Atom "grisette-unique", NumberAtom $ toInteger i])  -- | Symbol types for a symbolic variable. --@@ -222,17 +159,30 @@ data Symbol where   SimpleSymbol :: Identifier -> Symbol   IndexedSymbol :: Identifier -> Int -> Symbol-  deriving (Eq, Ord, Generic, Lift, NFData, Hashable)+  deriving (Eq, Ord, Generic, Lift, NFData, Serial) +instance Cereal.Serialize Symbol where+  put = serialize+  get = deserialize++instance Binary.Binary Symbol where+  put = serialize+  get = deserialize++instance Hashable Symbol where+  hashWithSalt s (SimpleSymbol i) = hashWithSalt s i+  hashWithSalt s (IndexedSymbol i idx) = s `hashWithSalt` i `hashWithSalt` idx+  {-# INLINE hashWithSalt #-}+ -- | Get the identifier of a symbol. symbolIdentifier :: Symbol -> Identifier symbolIdentifier (SimpleSymbol i) = i symbolIdentifier (IndexedSymbol i _) = i  -- | Modify the identifier of a symbol.-modifyIdentifier :: (Identifier -> Identifier) -> Symbol -> Symbol-modifyIdentifier f (SimpleSymbol i) = SimpleSymbol (f i)-modifyIdentifier f (IndexedSymbol i idx) = IndexedSymbol (f i) idx+mapIdentifier :: (Identifier -> Identifier) -> Symbol -> Symbol+mapIdentifier f (SimpleSymbol i) = SimpleSymbol (f i)+mapIdentifier f (IndexedSymbol i idx) = IndexedSymbol (f i) idx  instance Show Symbol where   show (SimpleSymbol i) = show i

@@ -31,8 +31,18 @@   ) where +#if MIN_VERSION_prettyprinter(1,7,0)+import Prettyprinter (align, group, nest, vsep)+#else+import Data.Text.Prettyprint.Doc (align, group, nest, vsep)+#endif+ import Control.DeepSeq (NFData (rnf), NFData1 (liftRnf), rnf1) import Control.Monad (ap)+import qualified Data.Binary as Binary+import Data.Bytes.Get (MonadGet (getWord8))+import Data.Bytes.Put (MonadPut (putWord8))+import Data.Bytes.Serial (Serial (deserialize, serialize)) import Data.Functor.Classes   ( Eq1 (liftEq),     Show1 (liftShowsPrec),@@ -40,6 +50,7 @@     showsUnaryWith,   ) import Data.Hashable (Hashable (hashWithSalt))+import qualified Data.Serialize as Cereal import GHC.Generics (Generic, Generic1) import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp (symIte)) import Grisette.Internal.Core.Data.Class.LogicalOp@@ -77,12 +88,6 @@ import Grisette.Internal.SymPrim.SymBool (SymBool) import Language.Haskell.TH.Syntax (Lift) -#if MIN_VERSION_prettyprinter(1,7,0)-import Prettyprinter (align, group, nest, vsep)-#else-import Data.Text.Prettyprint.Doc (align, group, nest, vsep)-#endif- -- | The base union implementation, which is an if-then-else tree structure. data UnionBase a where   -- | A single value@@ -161,6 +166,29 @@ instance (Mergeable a) => Mergeable (UnionBase a) where   rootStrategy = SimpleStrategy $ ifWithStrategy rootStrategy   {-# INLINE rootStrategy #-}++instance (Mergeable a, Serial a) => Serial (UnionBase a) where+  serialize (UnionSingle a) = putWord8 0 >> serialize a+  serialize (UnionIf _ _ c a b) =+    putWord8 1 >> serialize c >> serialize a >> serialize b+  deserialize = do+    tag <- getWord8+    case tag of+      0 -> UnionSingle <$> deserialize+      1 ->+        ifWithStrategy rootStrategy+          <$> deserialize+          <*> deserialize+          <*> deserialize+      _ -> fail "Invalid tag"++instance (Mergeable a, Serial a) => Cereal.Serialize (UnionBase a) where+  put = serialize+  get = deserialize++instance (Mergeable a, Serial a) => Binary.Binary (UnionBase a) where+  put = serialize+  get = deserialize  instance Mergeable1 UnionBase where   liftRootStrategy ms = SimpleStrategy $ ifWithStrategy ms

@@ -4,6 +4,7 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-}  -- | -- Module      :   Grisette.Internal.SymPrim.AlgReal@@ -25,10 +26,14 @@  import Control.DeepSeq (NFData) import Control.Exception (Exception, throw)+import qualified Data.Binary as Binary+import Data.Bytes.Serial (Serial (deserialize, serialize)) import Data.Hashable (Hashable) import qualified Data.SBV as SBV import qualified Data.SBV.Internals as SBV+import qualified Data.Serialize as Cereal import GHC.Generics (Generic)+import Grisette.Internal.Core.Data.Class.Function (Apply (FunType, apply)) import Language.Haskell.TH.Syntax (Lift) import Test.QuickCheck (Arbitrary) import Test.QuickCheck.Arbitrary (Arbitrary (arbitrary))@@ -40,7 +45,16 @@ newtype AlgRealPoly = AlgRealPoly [(Integer, Integer)]   deriving (Eq, Generic, Lift)   deriving newtype (Hashable, NFData)+  deriving anyclass (Serial) +instance Cereal.Serialize AlgRealPoly where+  put = serialize+  get = deserialize++instance Binary.Binary AlgRealPoly where+  put = serialize+  get = deserialize+ -- | Boundary point for real intervals. data RealPoint   = -- | Open point.@@ -48,8 +62,16 @@   | -- | Closed point.     ClosedPoint Rational   deriving (Eq, Generic, Lift)-  deriving anyclass (Hashable, NFData)+  deriving anyclass (Hashable, NFData, Serial) +instance Cereal.Serialize RealPoint where+  put = serialize+  get = deserialize++instance Binary.Binary RealPoint where+  put = serialize+  get = deserialize+ toSBVRealPoint :: RealPoint -> SBV.RealPoint Rational toSBVRealPoint (OpenPoint r) = SBV.OpenPoint r toSBVRealPoint (ClosedPoint r) = SBV.ClosedPoint r@@ -82,8 +104,16 @@     RealPoint ->     AlgReal   deriving (Generic, Lift)-  deriving anyclass (Hashable, NFData)+  deriving anyclass (Hashable, NFData, Serial) +instance Cereal.Serialize AlgReal where+  put = serialize+  get = deserialize++instance Binary.Binary AlgReal where+  put = serialize+  get = deserialize+ -- | Convert algebraic real numbers to SBV's algebraic real numbers. toSBVAlgReal :: AlgReal -> SBV.AlgReal toSBVAlgReal (AlgExactRational r) = SBV.AlgRational True r@@ -180,3 +210,7 @@  instance Arbitrary AlgReal where   arbitrary = AlgExactRational <$> arbitrary++instance Apply AlgReal where+  type FunType AlgReal = AlgReal+  apply = id

@@ -57,6 +57,7 @@ import Data.Functor.Sum (Sum) import Data.Int (Int16, Int32, Int64, Int8) import Data.Kind (Type)+import Data.Ratio (Ratio, denominator, numerator) import qualified Data.Text as T import Data.Word (Word16, Word32, Word64, Word8) import GHC.Generics@@ -463,6 +464,10 @@ CONCRETE_ALLSYMS_BV(IntN) CONCRETE_ALLSYMS(AlgReal) #endif++instance (AllSyms a) => AllSyms (Ratio a) where+  allSymsS r = allSymsS (numerator r) . allSymsS (denominator r)+  {-# INLINE allSymsS #-}  instance (ValidFP eb sb) => AllSyms (FP eb sb) where   allSymsS _ = id

@@ -8,11 +8,11 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -funbox-strict-fields #-}@@ -45,6 +45,7 @@   ( ArithException (Overflow),     throw,   )+import qualified Data.Binary as Binary import Data.Bits   ( Bits       ( bit,@@ -66,10 +67,12 @@       ),     FiniteBits (finiteBitSize),   )+import Data.Bytes.Serial (Serial (deserialize, serialize)) import Data.Hashable (Hashable) import Data.Maybe (fromMaybe, isJust) import Data.Proxy (Proxy (Proxy)) import Data.SBV (Int16, Int32, Int64, Int8, Word8)+import qualified Data.Serialize as Cereal import Data.Word (Word16, Word32, Word64) import GHC.Enum   ( boundedEnumFrom,@@ -104,6 +107,7 @@         sizedBVZext       ),   )+import Grisette.Internal.Core.Data.Class.Function (Apply (FunType, apply)) import Grisette.Internal.Core.Data.Class.SignConversion   ( SignConversion (toSigned, toUnsigned),   )@@ -173,6 +177,18 @@       binRepPre = "0b" ++ replicate (fromIntegral bitwidth - length binRep) '0'       binRep = showIntAtBase 2 (\x -> if x == 0 then '0' else '1') w "" +instance (KnownNat n, 1 <= n) => Serial (WordN n) where+  serialize (WordN w) = serialize w+  deserialize = WordN <$> deserialize++instance (KnownNat n, 1 <= n) => Cereal.Serialize (WordN n) where+  put = serialize+  get = deserialize++instance (KnownNat n, 1 <= n) => Binary.Binary (WordN n) where+  put = serialize+  get = deserialize+ convertInt :: (Num a) => L.Lexeme -> ReadPrec a convertInt (L.Number n)   | Just i <- L.numberToInteger n = return (fromInteger i)@@ -240,6 +256,18 @@       binRepPre = "0b" ++ replicate (fromIntegral bitwidth - length binRep) '0'       binRep = showIntAtBase 2 (\x -> if x == 0 then '0' else '1') w "" +instance (KnownNat n, 1 <= n) => Serial (IntN n) where+  serialize (IntN w) = serialize w+  deserialize = IntN <$> deserialize++instance (KnownNat n, 1 <= n) => Cereal.Serialize (IntN n) where+  put = serialize+  get = deserialize++instance (KnownNat n, 1 <= n) => Binary.Binary (IntN n) where+  put = serialize+  get = deserialize+ instance (KnownNat n, 1 <= n) => Read (IntN n) where   readPrec = readNumber convertInt <|> readBinary   readListPrec = readListPrecDefault@@ -633,3 +661,11 @@ instance BitCast (IntN 1) Bool where   bitCast 0 = False   bitCast _ = True++instance Apply (IntN n) where+  type FunType (IntN n) = IntN n+  apply = id++instance Apply (WordN n) where+  type FunType (WordN n) = WordN n+  apply = id

@@ -19,6 +19,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -45,12 +46,17 @@     ConvertibleBound (..),     nextFP,     prevFP,+    withUnsafeValidFP,+    checkDynamicValidFP,+    invalidFPMessage,   ) where  import Control.DeepSeq (NFData (rnf)) import Control.Exception (Exception, throw)+import qualified Data.Binary as Binary import Data.Bits (Bits (complement, shiftL, shiftR, xor, (.&.)))+import Data.Bytes.Serial (Serial (deserialize, serialize)) import Data.Hashable (Hashable (hashWithSalt)) import Data.Int (Int16, Int32, Int64) import Data.Maybe (fromJust)@@ -74,10 +80,20 @@ import Data.SBV.Float (fpEncodeFloat) import qualified Data.SBV.Float as SBVF import qualified Data.SBV.Internals as SBVI-import Data.Type.Equality (type (:~:) (Refl))+import qualified Data.Serialize as Cereal+import Data.Type.Bool (type (&&), type (||))+import Data.Type.Equality (type (:~:) (Refl), type (==)) import GHC.Exception (Exception (displayException)) import GHC.Generics (Generic)-import GHC.TypeLits (KnownNat, Nat, natVal, type (+), type (<=))+import GHC.Natural (Natural)+import GHC.TypeNats+  ( CmpNat,+    KnownNat,+    Nat,+    natVal,+    type (+),+    type (<=),+  ) import Grisette.Internal.Core.Data.Class.BitCast   ( BitCast (bitCast),     BitCastCanonical (bitCastCanonicalValue),@@ -85,6 +101,7 @@     bitCastOrCanonical,   ) import Grisette.Internal.Core.Data.Class.BitVector (SizedBV (sizedBVConcat))+import Grisette.Internal.Core.Data.Class.Function (Apply (FunType, apply)) import Grisette.Internal.Core.Data.Class.IEEEFP   ( IEEEFPConstants       ( fpMaxNormalized,@@ -188,6 +205,41 @@ -- number. type ValidFP (eb :: Nat) (sb :: Nat) = ValidFloat eb sb +-- | Check if the given floating-point type is valid.+checkDynamicValidFP :: Natural -> Natural -> Bool+checkDynamicValidFP eb sb =+  eb >= 2 && eb <= 61 && sb >= 2 && sb <= 4611686018427387902++-- | A message thrown when the floating-point type is invalid.+invalidFPMessage :: String+invalidFPMessage =+  "Invalid floating point type `SFloatingPoint eb sb'\n`n"+    <> "  A valid float of type 'SFloatingPoint eb sb' must satisfy:\n"+    <> "        eb `elem` [2 .. 61]\n"+    <> "        sb `elem` [2 .. 4611686018427387902]\n\n"+    <> "  Given type falls outside of this range, or the sizes are not known naturals."++-- | Provide an (unsafe) type-level proof that the given floating-point type is+-- valid.+withUnsafeValidFP ::+  forall eb sb r. (KnownNat eb, KnownNat sb) => ((ValidFP eb sb) => r) -> r+withUnsafeValidFP r =+  let eb = natVal (Proxy @eb)+      sb = natVal (Proxy @sb)+   in if checkDynamicValidFP eb sb+        then case unsafeAxiom @True+          @( ((CmpNat eb 2 == 'EQ) || (CmpNat eb 2 == 'GT))+               && ( ((CmpNat eb 61 == 'EQ) || (CmpNat eb 61 == 'LT))+                      && ( ((CmpNat sb 2 == 'EQ) || (CmpNat sb 2 == 'GT))+                             && ( (CmpNat sb 4611686018427387902 == 'EQ)+                                    || (CmpNat sb 4611686018427387902 == 'LT)+                                )+                         )+                  )+           ) of+          Refl -> r+        else error invalidFPMessage+ -- | IEEE 754 floating-point number with @eb@ exponent bits and @sb@ significand -- bits. --@@ -350,7 +402,7 @@   | -- | Round towards zero.     RTZ   deriving (Eq, Ord, Generic, Lift)-  deriving anyclass (Hashable, NFData)+  deriving anyclass (Hashable, NFData, Serial)  instance Show FPRoundingMode where   show RNE = "rne"@@ -892,3 +944,27 @@       eb = natVal (Proxy @eb)       ebn = 2 ^ (eb - 1)       sb = natVal (Proxy @sb)++instance Apply (FP eb sb) where+  type FunType (FP eb sb) = FP eb sb+  apply = id++instance Apply FPRoundingMode where+  type FunType FPRoundingMode = FPRoundingMode+  apply = id++instance (ValidFP eb sb) => Serial (FP eb sb) where+  serialize x =+    withValidFPProofs @eb @sb $+      serialize (bitCastOrCanonical x :: WordN (eb + sb))+  deserialize = do+    w :: WordN (eb + sb) <- withValidFPProofs @eb @sb deserialize+    return $ withValidFPProofs @eb @sb $ bitCast w++instance (ValidFP eb sb) => Cereal.Serialize (FP eb sb) where+  put = serialize+  get = deserialize++instance (ValidFP eb sb) => Binary.Binary (FP eb sb) where+  put = serialize+  get = deserialize

@@ -22,6 +22,7 @@   ) where +import Data.Hashable (Hashable) import qualified Data.SBV as SBV import Grisette.Internal.SymPrim.Prim.Internal.Term   ( IsSymbolKind,@@ -31,21 +32,21 @@         conSBVTerm,         defaultValue,         funcDummyConstraint,-        isFuncType,         parseSMTModelResult,         pevalDistinctTerm,         pevalEqTerm,         pevalITETerm,+        sameCon,         sbvDistinct,         sbvEq,         symSBVName,         symSBVTerm,         withPrim       ),-    TypedSymbol (TypedSymbol),+    TypedSymbol (unTypedSymbol),     decideSymbolKind,-    pevalITEBasicTerm,     translateTypeError,+    typedAnySymbol,     withNonFuncPrim,   ) import Language.Haskell.TH@@ -72,7 +73,7 @@   ( plainTVInferred,     plainTVSpecified,   )-import Type.Reflection (TypeRep, typeRep, type (:~~:) (HRefl))+import Type.Reflection (TypeRep, Typeable, typeRep, type (:~~:) (HRefl))  instanceWithOverlapDescD ::   Maybe Overlap -> Q Cxt -> Q Type -> [DecsQ] -> DecsQ@@ -87,6 +88,7 @@ supportedPrimFun ::   ExpQ ->   ExpQ ->+  ExpQ ->   ([TypeQ] -> ExpQ) ->   String ->   String ->@@ -95,6 +97,7 @@   DecsQ supportedPrimFun   dv+  ite   parse   consbv   funNameInError@@ -112,8 +115,9 @@       (if numArg == 2 then Nothing else Just Overlapping)       (constraints tyVars)       [t|SupportedPrim $(funType tyVars)|]-      ( [ [d|$(varP 'defaultValue) = $dv|],-          [d|$(varP 'pevalITETerm) = pevalITEBasicTerm|],+      ( [ [d|$(varP 'sameCon) = (==)|],+          [d|$(varP 'defaultValue) = $dv|],+          [d|$(varP 'pevalITETerm) = $ite|],           [d|             $(varP 'pevalEqTerm) =               $( translateError@@ -174,12 +178,11 @@                     |]               ),           [d|-            $(varP 'castTypedSymbol) = \(TypedSymbol sym) ->+            $(varP 'castTypedSymbol) = \sym ->               case decideSymbolKind @($knd'ty) of                 Left HRefl -> Nothing-                Right HRefl -> Just $ TypedSymbol sym+                Right HRefl -> Just $ typedAnySymbol $ unTypedSymbol sym             |],-          [d|$(varP 'isFuncType) = True|],           ( if numArg == 2               then                 [d|@@ -215,7 +218,18 @@             (typeRep :: TypeRep $(funType tyVars))           |] -      constraints = traverse (\ty -> [t|SupportedNonFuncPrim $ty|])+      constraints =+        fmap concat+          . traverse+            ( \ty ->+                sequence+                  [ [t|SupportedNonFuncPrim $ty|],+                    [t|Eq $ty|],+                    [t|Show $ty|],+                    [t|Hashable $ty|],+                    [t|Typeable $ty|]+                  ]+            )       funType =         foldl1 (\fty ty -> [t|$(varT funTypeName) $ty $fty|]) . reverse       withPrims :: [Q Type] -> Q Exp@@ -230,9 +244,10 @@ -- | Generate instances of 'SupportedPrim' for functions with up to a given -- number of arguments. supportedPrimFunUpTo ::-  ExpQ -> ExpQ -> ([TypeQ] -> ExpQ) -> String -> String -> Name -> Int -> DecsQ+  ExpQ -> ExpQ -> ExpQ -> ([TypeQ] -> ExpQ) -> String -> String -> Name -> Int -> DecsQ supportedPrimFunUpTo   dv+  ite   parse   consbv   funNameInError@@ -243,6 +258,7 @@       <$> sequence         [ supportedPrimFun             dv+            ite             parse             consbv             funNameInError

@@ -31,22 +31,26 @@     buildGeneralFun,     generalSubstSomeTerm,     substTerm,+    freshArgSymbol,   ) where  import Control.DeepSeq (NFData (rnf)) import Data.Bifunctor (Bifunctor (second))-import Data.Foldable (Foldable (foldl'))+import Data.Foldable (Foldable (foldl', toList)) 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-import GHC.Generics (Generic)-import Grisette.Internal.Core.Data.Class.Function (Function ((#)))+import Grisette.Internal.Core.Data.Class.Function+  ( Apply (FunType, apply),+    Function ((#)),+  ) import Grisette.Internal.Core.Data.MemoUtils (htmemo) import Grisette.Internal.Core.Data.Symbol-  ( Symbol (IndexedSymbol, SimpleSymbol),-    withInfo,+  ( Symbol (IndexedSymbol),   ) import Grisette.Internal.SymPrim.FunInstanceGen (supportedPrimFunUpTo) import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalFP@@ -59,8 +63,7 @@   ) import Grisette.Internal.SymPrim.Prim.Internal.PartialEval (totalize2) import Grisette.Internal.SymPrim.Prim.Internal.Term-  ( BinaryOp (pevalBinary),-    IsSymbolKind,+  ( IsSymbolKind,     LinkedRep (underlyingTerm, wrapTerm),     NonFuncPrimConstraint,     NonFuncSBVBaseType,@@ -93,6 +96,7 @@     PEvalRotateTerm (pevalRotateRightTerm),     PEvalShiftTerm (pevalShiftLeftTerm, pevalShiftRightTerm),     SBVRep (SBVType),+    SomeTypedAnySymbol,     SomeTypedConstantSymbol,     SupportedNonFuncPrim (withNonFuncPrim),     SupportedPrim@@ -101,9 +105,11 @@         parseSMTModelResult,         pevalDistinctTerm,         pevalITETerm,+        primTypeRep,         withPrim       ),     SupportedPrimConstraint (PrimConstraint),+    SymRep (SymType),     SymbolKind (AnyKind),     Term       ( AbsNumTerm,@@ -114,7 +120,6 @@         BVConcatTerm,         BVExtendTerm,         BVSelectTerm,-        BinaryTerm,         BitCastOrTerm,         BitCastTerm,         ComplementBitsTerm,@@ -153,23 +158,22 @@         ShiftRightTerm,         SignumNumTerm,         SymTerm,-        TernaryTerm,         ToFPTerm,-        UnaryTerm,         XorBitsTerm       ),-    TernaryOp (pevalTernary),+    TypedAnySymbol,     TypedConstantSymbol,-    TypedSymbol (TypedSymbol, unTypedSymbol),-    UnaryOp (pevalUnary),+    TypedSymbol,     applyTerm,     conTerm,     eqHeteroSymbol,     existsTerm,     forallTerm,+    introSupportedPrimConstraint,     partitionCVArg,     pevalAndTerm,     pevalEqTerm,+    pevalITEBasicTerm,     pevalNotTerm,     pevalOrTerm,     pevalQuotIntegralTerm,@@ -179,6 +183,10 @@     someTypedSymbol,     symTerm,     translateTypeError,+    typedAnySymbol,+    typedConstantSymbol,+    withConstantSymbolSupported,+    withSymbolSupported,   ) import Grisette.Internal.SymPrim.Prim.SomeTerm (SomeTerm (SomeTerm), someTerm) import Language.Haskell.TH.Syntax (Lift (liftTyped))@@ -210,39 +218,142 @@ -- (+ 1 (+ a y)) data (-->) a b where   GeneralFun ::-    (SupportedPrim a, SupportedPrim b) =>+    (SupportedNonFuncPrim a, SupportedPrim b) =>     TypedConstantSymbol a ->     Term b ->     a --> b  instance (LinkedRep a sa, LinkedRep b sb) => Function (a --> b) sa sb where-  (GeneralFun s t) # x = wrapTerm $ substTerm s (underlyingTerm x) t+  (GeneralFun s t) # x = wrapTerm $ substTerm s (underlyingTerm x) HS.empty t  infixr 0 --> +extractSymSomeTermIncludeBoundedVars ::+  SomeTerm -> HS.HashSet SomeTypedAnySymbol+extractSymSomeTermIncludeBoundedVars = htmemo go+  where+    goTyped :: Term a -> HS.HashSet SomeTypedAnySymbol+    goTyped = go . someTerm++    go :: SomeTerm -> HS.HashSet SomeTypedAnySymbol+    go (SomeTerm (SymTerm _ _ _ _ (sym :: TypedAnySymbol a))) =+      HS.singleton $ someTypedSymbol sym+    go (SomeTerm (ConTerm _ _ _ _ cv :: Term v)) =+      case (primTypeRep :: TypeRep v) of+        App (App gf _) _ ->+          case eqTypeRep (typeRep @(-->)) gf of+            Just HRefl ->+              case cv of+                GeneralFun (tsym :: TypedConstantSymbol x) tm ->+                  HS.union+                    ( HS.singleton+                        (someTypedSymbol $ fromJust $ castTypedSymbol tsym)+                    )+                    $ go (SomeTerm tm)+            Nothing -> HS.empty+        _ -> HS.empty+    go (SomeTerm (ForallTerm _ _ _ _ sym arg)) =+      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++-- | Generate a fresh argument symbol that is not used as bounded or unbounded+-- variables in the function body for a general symbolic function.+freshArgSymbol ::+  forall a. (SupportedNonFuncPrim a) => [SomeTerm] -> TypedConstantSymbol a+freshArgSymbol terms = typedConstantSymbol $ go 0+  where+    allSymbols = mconcat $ extractSymSomeTermIncludeBoundedVars <$> terms+    go :: Int -> Symbol+    go n =+      let currentSymbol = IndexedSymbol "arg" n+          currentTypedSymbol =+            someTypedSymbol (typedAnySymbol currentSymbol :: TypedAnySymbol a)+       in if HS.member currentTypedSymbol allSymbols+            then go (n + 1)+            else currentSymbol+ -- | Build a general symbolic function with a bounded symbol and a term. buildGeneralFun ::+  forall a b.   (SupportedNonFuncPrim a, SupportedPrim b) =>   TypedConstantSymbol a ->   Term b ->   a --> b buildGeneralFun arg v =   GeneralFun-    (TypedSymbol newarg)-    (substTerm arg (symTerm newarg) v)+    argSymbol+    (substTerm arg (symTerm argSymbol) HS.empty v)   where-    newarg = case unTypedSymbol arg of-      SimpleSymbol s -> SimpleSymbol (withInfo s ARG)-      IndexedSymbol s i -> IndexedSymbol (withInfo s ARG) i--data ARG = ARG-  deriving (Eq, Ord, Lift, Show, Generic)--instance NFData ARG where-  rnf ARG = ()--instance Hashable ARG where-  hashWithSalt s ARG = s `hashWithSalt` (0 :: Int)+    argSymbol = freshArgSymbol [SomeTerm v]  instance Eq (a --> b) where   GeneralFun sym1 tm1 == GeneralFun sym2 tm2 = sym1 == sym2 && tm1 == tm2@@ -281,6 +392,10 @@       SBV.SBV (NonFuncSBVBaseType a) ->       SBVType b +instance (Apply st, LinkedRep ca sa, LinkedRep ct st) => Apply (ca --> ct) where+  type FunType (ca --> ct) = SymType ca -> FunType (SymType ct)+  apply uf a = apply (uf # a)+ pevalGeneralFunApplyTerm ::   ( SupportedNonFuncPrim a,     SupportedPrim b,@@ -291,9 +406,9 @@   Term b pevalGeneralFunApplyTerm = totalize2 doPevalApplyTerm applyTerm   where-    doPevalApplyTerm (ConTerm _ (GeneralFun arg tm)) v =-      Just $ substTerm arg v tm-    doPevalApplyTerm (ITETerm _ c l r) v =+    doPevalApplyTerm (ConTerm _ _ _ _ (GeneralFun arg tm)) v =+      Just $ substTerm arg v HS.empty tm+    doPevalApplyTerm (ITETerm _ _ _ _ c l r) v =       return $ pevalITETerm c (pevalApplyTerm l v) (pevalApplyTerm r v)     doPevalApplyTerm _ _ = Nothing @@ -315,7 +430,7 @@   ([([SBVD.CV], SBVD.CV)], SBVD.CV) ->   a --> b parseGeneralFunSMTModelResult level (l, s) =-  let sym = IndexedSymbol "arg" level+  let sym = typedConstantSymbol $ IndexedSymbol "arg" level       funs =         second           ( \r ->@@ -335,7 +450,7 @@           )           (conTerm def)           funs-   in buildGeneralFun (TypedSymbol sym) body+   in buildGeneralFun sym body  -- | General procedure for substituting symbols in a term. {-# NOINLINE generalSubstSomeTerm #-}@@ -358,8 +473,8 @@       HS.HashSet SomeTypedConstantSymbol ->       SomeTerm ->       SomeTerm-    goSome _ bs c@(SomeTerm (ConTerm _ cv :: Term x)) =-      case (typeRep :: TypeRep x) of+    goSome _ bs c@(SomeTerm (ConTerm _ _ _ _ cv :: Term x)) =+      case (primTypeRep :: TypeRep x) of         App (App gf _) _ ->           case eqTypeRep gf (typeRep @(-->)) of             Just HRefl -> case cv of@@ -374,135 +489,118 @@                  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 (UnaryTerm _ tag (arg :: Term a))) =-      goUnary memo (pevalUnary tag) arg-    goSome-      memo-      _-      (SomeTerm (BinaryTerm _ tag (arg1 :: Term a1) (arg2 :: Term a2))) =-        goBinary memo (pevalBinary tag) arg1 arg2-    goSome-      memo-      _-      ( SomeTerm-          ( TernaryTerm-              _-              tag-              (arg1 :: Term a1)-              (arg2 :: Term a2)-              (arg3 :: Term a3)-            )-        ) = do-        goTernary memo (pevalTernary tag) arg1 arg2 arg3-    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)) =-      goBinary memo pevalEqTerm arg1 arg2-    goSome memo _ (SomeTerm (DistinctTerm _ args)) =-      SomeTerm $ pevalDistinctTerm (fmap (go memo) args)-    goSome memo _ (SomeTerm (ITETerm _ cond 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)) =       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)@@ -515,17 +613,35 @@   (SupportedPrim a, SupportedPrim b, IsSymbolKind knd) =>   TypedSymbol knd a ->   Term a ->+  HS.HashSet SomeTypedConstantSymbol ->   Term b ->   Term b substTerm sym a =   generalSubstSomeTerm-    ( \t@(TypedSymbol t') ->-        if eqHeteroSymbol sym t then unsafeCoerce a else symTerm t'+    ( \t ->+        if eqHeteroSymbol sym t+          then unsafeCoerce a+          else withSymbolSupported t $ symTerm t     )-    HS.empty  supportedPrimFunUpTo-  [|buildGeneralFun (TypedSymbol "a") (conTerm defaultValue)|]+  [|buildGeneralFun (typedConstantSymbol "a") (conTerm defaultValue)|]+  [|+    \c t f -> case (t, f) of+      ( ConTerm _ _ _ _ (GeneralFun (ta :: TypedConstantSymbol a) a),+        ConTerm _ _ _ _ (GeneralFun tb b)+        ) ->+          conTerm $+            GeneralFun argSymbol $+              pevalITETerm+                c+                (substTerm ta (symTerm argSymbol) HS.empty a)+                (substTerm tb (symTerm argSymbol) HS.empty b)+          where+            argSymbol :: TypedConstantSymbol a+            argSymbol = freshArgSymbol [SomeTerm a, SomeTerm b]+      _ -> pevalITEBasicTerm c t f+    |]   [|parseGeneralFunSMTModelResult|]   ( \tyVars ->       [|

@@ -33,12 +33,12 @@ -- This is used to build a model from a list of symbolic constants and their values. -- -- >>> buildModel ("a" := (1 :: Integer), "b" := True) :: Model--- Model {a -> 1 :: Integer, b -> True :: Bool}+-- Model {a -> 1 :: Integer, b -> true :: Bool} data ModelSymPair ct st where   (:=) :: (LinkedRep ct st) => st -> ct -> ModelSymPair ct st  instance ModelRep (ModelSymPair ct st) Model where   buildModel (sym := val) =     case underlyingTerm sym of-      SymTerm _ symbol -> insertValue symbol val emptyModel+      SymTerm _ _ _ _ symbol -> insertValue symbol val emptyModel       _ -> error "buildModel: should only use symbolic constants"

@@ -1,8 +1,13 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Strict #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-cse #-}  -- |@@ -13,46 +18,311 @@ -- Maintainer  :   siruilu@cs.washington.edu -- Stability   :   Experimental -- Portability :   GHC only-module Grisette.Internal.SymPrim.Prim.Internal.Caches (typeMemoizedCache) where+module Grisette.Internal.SymPrim.Prim.Internal.Caches+  ( SomeStableName (..),+    Id,+    Ident,+    Digest,+    Interned (..),+    intern,+    haveCache,+    threadCacheSize,+    -- dumpThreadCache,+    threadCacheLiveSize,+  )+where  import Control.Concurrent-  ( forkIO,-    newEmptyMVar,+  ( MVar,+    ThreadId,+    myThreadId,+    newMVar,     putMVar,-    readMVar,     takeMVar,-    tryPutMVar,   )-import Data.Data (Proxy (Proxy), TypeRep, Typeable, typeRep)-import qualified Data.HashMap.Strict as M-import Data.IORef (IORef, atomicModifyIORef', newIORef)-import Data.Interned (Cache, Interned, mkCache)+import Control.Monad (replicateM)+import qualified Data.Array as A+import Data.Atomics (atomicModifyIORefCAS, atomicModifyIORefCAS_)+import Data.Data (Proxy (Proxy), Typeable, typeRepFingerprint)+import Data.Foldable (traverse_)+import qualified Data.HashMap.Strict as HM+import Data.Hashable (Hashable)+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.Maybe (isJust)+import qualified Data.Vector.Unboxed.Mutable as M+import Data.Word (Word32) import GHC.Base (Any)-import GHC.IO (unsafeDupablePerformIO, unsafePerformIO)+import GHC.Fingerprint (Fingerprint)+import GHC.IO (unsafePerformIO)+import GHC.StableName (makeStableName)+import GHC.Weak (Weak, deRefWeak, finalize)+import Grisette.Internal.SymPrim.Prim.Internal.Utils+  ( SomeStableName (SomeStableName),+    WeakThreadId,+    WeakThreadIdRef,+    mkWeakStableNameRefWithFinalizer,+    mkWeakThreadIdRefWithFinalizer,+    myWeakThreadId,+    weakThreadId,+  )+import System.Mem.StableName (StableName)+import Type.Reflection (someTypeRep) import Unsafe.Coerce (unsafeCoerce) -mkOnceIO :: IO a -> IO (IO a)-mkOnceIO io = do-  mv <- newEmptyMVar-  demand <- newEmptyMVar-  forkIO (takeMVar demand >> io >>= putMVar mv)-  return (tryPutMVar demand () >> readMVar mv)+-- | A unique identifier for a term.+type Id = Word32 -termCacheCell :: IO (IORef (M.HashMap TypeRep Any))-termCacheCell = unsafePerformIO $ mkOnceIO $ newIORef M.empty+-- | The identity of a term.+type Ident = StableName Any++-- | A digest of a term.+type Digest = Word32++newtype Cache t = Cache {getCache :: A.Array Int (CacheState t)}++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)+    } ->+    CacheState t++finalizeCacheState :: CacheState t -> IO ()+finalizeCacheState (CacheState _ _ s) = do+  m <- readIORef s+  traverse_ (\(_, w) -> finalize w) m++finalizeCache :: Cache t -> IO ()+finalizeCache (Cache a) = mapM_ finalizeCacheState (A.elems a)++-- | A class for interning terms.+class Interned t where+  data Description t+  type Uninterned t+  describe :: Uninterned t -> Description t+  identify :: WeakThreadId -> Digest -> Id -> Ident -> Uninterned t -> t+  threadId :: t -> WeakThreadId+  descriptionDigest :: Description t -> Digest+ {-# NOINLINE termCacheCell #-}+termCacheCell ::+  IORef+    ( HM.HashMap+        WeakThreadId+        ( WeakThreadIdRef,+          IORef (HM.HashMap Fingerprint (Cache Any))+        )+    )+termCacheCell = unsafePerformIO $ newIORef HM.empty +cacheWidth :: Word32+cacheWidth = 10+{-# INLINE cacheWidth #-}++mkCache :: forall t. (Interned t) => IO (Cache t)+mkCache = result+  where+    element =+      CacheState+        <$> newMVar ()+        <*> M.replicate 1 0+        <*> newIORef HM.empty+    result = do+      elements <- replicateM (fromIntegral cacheWidth) element+      return $ Cache $ A.listArray (0, fromIntegral cacheWidth - 1) elements+ -- | Internal cache for memoization of term construction. Different types have -- different caches and they may share names, ids, or representations, but they -- are not the same term.-typeMemoizedCache :: forall a. (Interned a, Typeable a) => Cache a-typeMemoizedCache = unsafeDupablePerformIO $ do-  c <- termCacheCell-  atomicModifyIORef' c $ \m ->-    case M.lookup (typeRep (Proxy @a)) m of-      Just d -> (m, unsafeCoerce d)-      Nothing -> (M.insert (typeRep (Proxy @a)) (unsafeCoerce r1) m, r1)-        where-          r1 :: Cache a-          !r1 = mkCache-          {-# NOINLINE r1 #-}+typeMemoizedCache ::+  forall a. (Interned a) => ThreadId -> Fingerprint -> IO (Cache a)+typeMemoizedCache tid tyFingerprint = do+  caches <- readIORef termCacheCell+  let wtid = weakThreadId tid+  case HM.lookup wtid caches of+    Just (_, cref) -> do+      cache <- readIORef cref+      case HM.lookup tyFingerprint cache of+        Just d -> return $ unsafeCoerce d+        Nothing -> do+          r1 <- mkCache+          writeIORef cref $!+            HM.insert tyFingerprint (unsafeCoerce r1) cache+          return r1+    Nothing -> do+      r1 <- mkCache+      wtidRef <-+        mkWeakThreadIdRefWithFinalizer tid $ do+          finalizeCache r1+          atomicModifyIORefCAS_ termCacheCell (HM.delete wtid)+      r <- newIORef $ HM.singleton tyFingerprint (unsafeCoerce r1)+      atomicModifyIORefCAS termCacheCell $+        \m -> (HM.insert wtid (wtidRef, r) m, r1)++reclaimTerm ::+  forall t.+  (Interned t, Hashable (Description t), Eq (Description t)) =>+  WeakThreadId ->+  Fingerprint ->+  Int ->+  Description t ->+  IO ()+reclaimTerm id tyFingerprint grp dt = do+  caches <- readIORef termCacheCell+  case HM.lookup id caches of+    Just (_, cref) -> do+      cache <- readIORef cref+      case HM.lookup tyFingerprint cache of+        Just c -> do+          let Cache a = unsafeCoerce c :: Cache t+          let CacheState sem _ s = a A.! grp+          takeMVar sem+          current <- readIORef s+          case HM.lookup dt current of+            Nothing -> return ()+            Just (_, wr) -> do+              t <- deRefWeak wr+              case t of+                Nothing -> writeIORef s $ HM.delete dt current+                Just _ -> return ()+          putMVar sem ()+        Nothing -> return ()+    Nothing -> return ()++-- | Internalize a term.+intern ::+  forall t.+  (Interned t, Typeable t, Hashable (Description t), Eq (Description t)) =>+  Uninterned t ->+  IO t+intern !bt = do+  tid <- myThreadId+  let wtid = weakThreadId tid+  let fingerprint = typeRepFingerprint $ someTypeRep (Proxy @t)+  cache <- typeMemoizedCache tid fingerprint+  let !dt = describe bt :: Description t+      !hdt = descriptionDigest dt+      !r = hdt `mod` cacheWidth+      CacheState sem nextId 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)+      let newId = newId0 * cacheWidth + r+      newIdent <- makeStableName dt+      let anyNewIdent = unsafeCoerce newIdent :: Ident+      identRef <-+        mkWeakStableNameRefWithFinalizer anyNewIdent $+          reclaimTerm wtid fingerprint (fromIntegral r) dt+      let !t = identify (weakThreadId tid) hdt newId anyNewIdent bt+      writeIORef s $ HM.insert dt (newId, identRef) current+      putMVar sem ()+      return t+    Just (oldId, oldIdentRef) -> do+      t1 <- deRefWeak oldIdentRef+      case t1 of+        Nothing -> do+          newId0 <- M.unsafeRead nextId 0+          M.unsafeWrite nextId 0 (newId0 + 1)+          let newId = newId0 * cacheWidth + r+          newIdent <- makeStableName dt+          let anyNewIdent = unsafeCoerce newIdent :: Ident+          identRef <-+            mkWeakStableNameRefWithFinalizer anyNewIdent $+              reclaimTerm wtid fingerprint (fromIntegral r) dt+          let !term = identify (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+{-# NOINLINE intern #-}++-- | Check if the current thread has a cache.+haveCache :: IO Bool+haveCache = do+  caches <- readIORef termCacheCell+  tid <- myWeakThreadId+  return $ HM.member tid caches++cacheStateSize :: CacheState t -> IO Int+cacheStateSize (CacheState _ _ s) = HM.size <$> readIORef s++cacheStateLiveSize :: CacheState t -> IO Int+cacheStateLiveSize (CacheState sem _ s) = do+  takeMVar sem+  v <- fmap snd . HM.toList <$> readIORef s+  r <-+    sum+      <$> mapM+        ( \(_, x) -> do+            x <- deRefWeak x+            if isJust x then return 1 else return 0+        )+        v+  putMVar sem ()+  return r++{-+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)++cacheLiveSize :: Cache t -> IO Int+cacheLiveSize (Cache a) = sum <$> mapM cacheStateLiveSize (A.elems a)++-- | Get the size of the current thread's cache.+threadCacheSize :: WeakThreadId -> IO Int+threadCacheSize tid = do+  caches <- readIORef termCacheCell+  case HM.lookup tid caches of+    Just (_, cref) -> do+      cache <- readIORef cref+      sum <$> mapM cacheSize (HM.elems cache)+    Nothing -> return 0++-- | Get the live size of the current thread's cache.+threadCacheLiveSize :: WeakThreadId -> IO Int+threadCacheLiveSize tid = do+  caches <- readIORef termCacheCell+  case HM.lookup tid caches of+    Just (_, cref) -> do+      cache <- readIORef cref+      sum <$> mapM cacheLiveSize (HM.elems cache)+    Nothing -> return 0++{-+-- | 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 ()+-}

@@ -27,7 +27,7 @@ import Data.Maybe (isJust) import Data.Proxy (Proxy (Proxy)) import qualified Data.SBV as SBV-import Data.Typeable (type (:~:) (Refl))+import Data.Typeable (Typeable, type (:~:) (Refl)) import GHC.TypeNats (KnownNat, Nat, natVal, sameNat, type (+), type (-), type (<=)) import Grisette.Internal.Core.Data.Class.BitVector   ( SizedBV@@ -53,6 +53,7 @@         sbvBVSelectTerm       ),     PEvalBitCastTerm (pevalBitCastTerm, sbvBitCast),+    SupportedPrim,     Term       ( BVConcatTerm,         BVExtendTerm,@@ -61,16 +62,16 @@         ConTerm       ),     bitCastTerm,-    bvconcatTerm,-    bvextendTerm,-    bvselectTerm,+    bvConcatTerm,+    bvExtendTerm,+    bvSelectTerm,     conTerm,+    pattern DynTerm,   ) import Grisette.Internal.SymPrim.Prim.Internal.Unfold   ( binaryUnfoldOnce,     unaryUnfoldOnce,   )-import Grisette.Internal.SymPrim.Prim.Internal.Utils (pattern Dyn) import Grisette.Internal.SymPrim.Prim.TermUtils (castTerm) import Grisette.Internal.Utils.Parameterized   ( LeqProof (LeqProof),@@ -98,14 +99,17 @@     ix + w <= n,     PEvalBVTerm bv,     forall x. (KnownNat x, 1 <= x) => PEvalBitCastTerm (bv2 x) (bv x),-    PEvalBVTerm bv2+    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)+  unaryUnfoldOnce (doPevalDefaultBVSelectTerm @bv2 ix w) (bvSelectTerm ix w)  unsafePevalBVSelectTerm ::   forall bv n ix w.@@ -135,7 +139,10 @@     1 <= w,     ix + w <= n,     PEvalBVTerm bv,-    PEvalBVTerm bv2+    PEvalBVTerm bv2,+    Typeable bv,+    SupportedPrim (bv w),+    SupportedPrim (bv2 n)   ) =>   p ix ->   q w ->@@ -145,14 +152,14 @@   | isJust (sameNat (Proxy @ix) (Proxy @0))       && isJust (sameNat (Proxy @w) (Proxy @n)) =       Just rhs >>= castTerm-doPevalDefaultBVSelectTerm ix w (ConTerm _ b) =+doPevalDefaultBVSelectTerm ix w (ConTerm _ _ _ _ b) =   Just $ conTerm $ sizedBVSelect ix w b-doPevalDefaultBVSelectTerm ix w (BitCastTerm _ (Dyn (b :: Term (bv2 n)))) =+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)))+  (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@@ -182,7 +189,7 @@ doPevalDefaultBVSelectTerm   _   _-  (BVSelectTerm _ (_ :: proxy ix1) _ (b :: Term (bv n1))) =+  (BVSelectTerm _ _ _ _ (_ :: proxy ix1) _ (b :: Term (bv n1))) =     Just $       unsafePevalBVSelectTerm         (natRepr @n1)@@ -192,7 +199,7 @@ doPevalDefaultBVSelectTerm   pix   pw-  (BVExtendTerm _ signed _ (b :: Term (bv n1)))+  (BVExtendTerm _ _ _ _ signed _ (b :: Term (bv n1)))     | ix + w <= n1 = Just $ unsafePevalBVSelectTerm n1Repr ixRepr wRepr b     | ix < n1 =         case mkNatRepr (n1 - ix) of@@ -216,14 +223,16 @@     KnownNat r,     1 <= l,     1 <= r,-    l <= 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)+  unaryUnfoldOnce (doPevalDefaultBVExtendTerm signed p) (bvExtendTerm signed p)  unsafePevalBVExtendTerm ::   forall bv l r.@@ -247,13 +256,15 @@     KnownNat r,     1 <= l,     1 <= r,-    l <= 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) =+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) =@@ -273,7 +284,7 @@     rRepr = natRepr @r     l = natVal @l (Proxy @l)     r = natVal @r pr-doPevalDefaultBVExtendTerm True p (BVExtendTerm _ True _ (b :: Term (bv l1))) =+doPevalDefaultBVExtendTerm True p (BVExtendTerm _ _ _ _ True _ (b :: Term (bv l1))) =   case unsafeLeqProof @l1 @r of     LeqProof -> Just $ pevalBVExtendTerm True p b doPevalDefaultBVExtendTerm _ _ _ = Nothing@@ -284,7 +295,8 @@     KnownNat b,     1 <= a,     1 <= b,-    PEvalBVTerm bv+    PEvalBVTerm bv,+    forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n)   ) =>   Term (bv a) ->   Term (bv b) ->@@ -293,11 +305,11 @@   withKnownNat (addNat (natRepr @a) (natRepr @b)) $     case (unsafeLeqProof @1 @(a + b)) of       LeqProof ->-        binaryUnfoldOnce doPevalDefaultBVConcatTerm bvconcatTerm+        binaryUnfoldOnce doPevalDefaultBVConcatTerm bvConcatTerm  unsafeBVConcatTerm ::   forall bv n1 n2 r.-  (PEvalBVTerm bv) =>+  (PEvalBVTerm bv, forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n)) =>   NatRepr n1 ->   NatRepr n2 ->   NatRepr r ->@@ -314,7 +326,7 @@       withKnownNat n1Repr $         withKnownNat n2Repr $           withKnownNat rRepr $-            bvconcatTerm lhs rhs+            bvConcatTerm lhs rhs  unsafePevalBVConcatTerm ::   forall bv n1 n2 r.@@ -341,24 +353,26 @@   forall bv l r.   ( KnownNat l,     KnownNat r,+    KnownNat (l + r),     1 <= l,     1 <= r,     1 <= (l + r),-    PEvalBVTerm bv+    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') =+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))) =+  (ConTerm _ _ _ _ vl)+  (BVConcatTerm _ _ _ _ (ConTerm _ _ _ _ (vrl :: bv rl)) (rr :: Term (bv rr))) =     case unsafeLeqProof @1 @(l + rl) of       LeqProof ->         Just $@@ -372,10 +386,10 @@     where       lRlRepr = addNat (natRepr @l) (natRepr @rl) -- 3. [c1 (s c2)] -> (c1 (s c2))-doPevalDefaultBVConcatTerm (ConTerm {}) (BVConcatTerm _ _ ConTerm {}) = Nothing+doPevalDefaultBVConcatTerm (ConTerm {}) (BVConcatTerm _ _ _ _ _ ConTerm {}) = Nothing -- 4. [(c s) ?) -> (c [s ?]) doPevalDefaultBVConcatTerm-  (BVConcatTerm _ (ll@ConTerm {} :: Term (bv ll)) (lr :: Term (bv lr)))+  (BVConcatTerm _ _ _ _ (ll@ConTerm {} :: Term (bv ll)) (lr :: Term (bv lr)))   r =     Just $ unsafeBVConcatTerm llRepr lrRRepr lRRepr ll rhs     where@@ -392,8 +406,11 @@   l   ( BVConcatTerm       _+      _+      _+      _       (rl@ConTerm {} :: Term (bv rl))-      (BVConcatTerm _ (rrl :: Term (bv rrl)) (rrr@ConTerm {} :: Term (bv rrr)))+      (BVConcatTerm _ _ _ _ (rrl :: Term (bv rrl)) (rrr@ConTerm {} :: Term (bv rrr)))     ) =     Just $ unsafeBVConcatTerm lRlRrlRepr rrrRepr lRRepr lRlRrl rrr     where@@ -409,8 +426,8 @@       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) =+  (BVConcatTerm _ _ _ _ (ll :: Term (bv ll)) ((ConTerm _ _ _ _ vlr) :: Term (bv lr)))+  (ConTerm _ _ _ _ vr) =     Just $ unsafeBVConcatTerm llRepr lrRRepr lRRepr ll rhs     where       llRepr = natRepr @ll@@ -425,8 +442,8 @@           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))) =+  (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@@ -448,7 +465,7 @@ -- 8. [?notc (s2 c)] -> ((s1 s2) c) doPevalDefaultBVConcatTerm   l-  (BVConcatTerm _ (rl :: Term (bv rl)) (rr@ConTerm {} :: Term (bv rr))) =+  (BVConcatTerm _ _ _ _ (rl :: Term (bv rl)) (rr@ConTerm {} :: Term (bv rr))) =     Just $       unsafeBVConcatTerm         lRlRepr@@ -554,12 +571,12 @@     where       doPevalBitCastBV :: Term (WordN n) -> Maybe (Term (IntN n))       doPevalBitCastBV-        (BVConcatTerm _ (l :: Term (WordN l)) (r :: Term (WordN r))) =+        (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))) =+      doPevalBitCastBV (BVExtendTerm _ _ _ _ signed pr (b :: Term (WordN l))) =         Just $           pevalBVExtendTerm signed pr $             pevalBitCastTerm @(WordN l) @(IntN l) b@@ -571,12 +588,12 @@     where       doPevalBitCastBV :: Term (IntN n) -> Maybe (Term (WordN n))       doPevalBitCastBV-        (BVConcatTerm _ (l :: Term (IntN l)) (r :: Term (IntN r))) =+        (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))) =+      doPevalBitCastBV (BVExtendTerm _ _ _ _ signed pr (b :: Term (IntN l))) =         Just $           pevalBVExtendTerm signed pr $             pevalBitCastTerm @(IntN l) @(WordN l) b

@@ -34,30 +34,34 @@ import Grisette.Internal.SymPrim.Prim.Internal.Term   ( PEvalBitCastOrTerm (pevalBitCastOrTerm, sbvBitCastOr),     PEvalBitCastTerm (pevalBitCastTerm, sbvBitCast),-    SupportedNonFuncPrim,+    SupportedPrim,     Term (BitCastTerm, ConTerm),     bitCastOrTerm,     bitCastTerm,     conTerm,+    introSupportedPrimConstraint,+    pattern DynTerm,   )-import Grisette.Internal.SymPrim.Prim.Internal.Unfold (binaryUnfoldOnce, unaryUnfoldOnce)-import Grisette.Internal.SymPrim.Prim.Internal.Utils (pattern Dyn)+import Grisette.Internal.SymPrim.Prim.Internal.Unfold+  ( binaryUnfoldOnce,+    unaryUnfoldOnce,+  )  doPevalBitCastSameType ::-  forall x b. (SupportedNonFuncPrim b) => Term x -> Maybe (Term b)-doPevalBitCastSameType (BitCastTerm _ (Dyn (b :: Term b))) = Just b-doPevalBitCastSameType (BitCastTerm _ x) = doPevalBitCastSameType x+  forall x b. (SupportedPrim b) => Term x -> Maybe (Term b)+doPevalBitCastSameType (BitCastTerm _ _ _ _ (DynTerm (b :: Term b))) = Just b+doPevalBitCastSameType (BitCastTerm _ _ _ _ x) = doPevalBitCastSameType x doPevalBitCastSameType _ = Nothing  -- | Partially evaluate a bitcast term. If no reduction is performed, return -- Nothing.-doPevalBitCast :: (PEvalBitCastTerm a b) => Term a -> Maybe (Term b)-doPevalBitCast (ConTerm _ v) = Just $ conTerm $ bitCast v+doPevalBitCast :: (PEvalBitCastTerm a b, SupportedPrim b) => Term a -> Maybe (Term b)+doPevalBitCast (ConTerm _ _ _ _ v) = Just $ conTerm $ bitCast v doPevalBitCast t = doPevalBitCastSameType t  pevalBitCastGeneral ::   forall a b.-  (PEvalBitCastTerm a b) =>+  (PEvalBitCastTerm a b, SupportedPrim b) =>   Term a ->   Term b pevalBitCastGeneral = unaryUnfoldOnce doPevalBitCast bitCastTerm@@ -67,7 +71,8 @@   Term b ->   Term a ->   Maybe (Term b)-doPevalBitCastOr (ConTerm _ d) (ConTerm _ v) = Just $ conTerm $ bitCastOr d v+doPevalBitCastOr (ConTerm _ _ _ _ d) (ConTerm _ _ _ _ v) =+  Just $ conTerm $ bitCastOr d v doPevalBitCastOr _ _ = Nothing  pevalBitCastOr ::@@ -76,8 +81,9 @@   Term b ->   Term a ->   Term b-pevalBitCastOr =-  binaryUnfoldOnce doPevalBitCastOr bitCastOrTerm+pevalBitCastOr d a =+  introSupportedPrimConstraint d $+    binaryUnfoldOnce doPevalBitCastOr bitCastOrTerm d a  instance PEvalBitCastTerm Bool (IntN 1) where   pevalBitCastTerm = pevalBitCastGeneral

@@ -48,11 +48,12 @@   (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+    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)+    doPevalAndBitsTerm a (ConTerm _ _ _ _ b)       | b == zeroBits = Just $ conTerm zeroBits       | b == complement zeroBits = Just a     doPevalAndBitsTerm a b | a == b = Just a@@ -62,34 +63,34 @@   (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+    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)+    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) => Term a -> Term a -> Term a+  (PEvalBitwiseTerm a, SupportedPrim a, Bits a) => Term a -> Term a -> Term a pevalDefaultXorBitsTerm = binaryUnfoldOnce doPevalXorBitsTerm xorBitsTerm   where-    doPevalXorBitsTerm (ConTerm _ a) (ConTerm _ b) =+    doPevalXorBitsTerm (ConTerm _ _ _ _ a) (ConTerm _ _ _ _ b) =       Just $ conTerm (a `xor` b)-    doPevalXorBitsTerm (ConTerm _ a) b+    doPevalXorBitsTerm (ConTerm _ _ _ _ a) b       | a == zeroBits = Just b       | a == complement zeroBits = Just $ pevalComplementBitsTerm b-    doPevalXorBitsTerm a (ConTerm _ 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) =+    doPevalXorBitsTerm (ComplementBitsTerm _ _ _ _ i) (ComplementBitsTerm _ _ _ _ j) =       Just $ pevalXorBitsTerm i j-    doPevalXorBitsTerm (ComplementBitsTerm _ i) j =+    doPevalXorBitsTerm (ComplementBitsTerm _ _ _ _ i) j =       Just $ pevalComplementBitsTerm $ pevalXorBitsTerm i j-    doPevalXorBitsTerm i (ComplementBitsTerm _ j) =+    doPevalXorBitsTerm i (ComplementBitsTerm _ _ _ _ j) =       Just $ pevalComplementBitsTerm $ pevalXorBitsTerm i j     doPevalXorBitsTerm _ _ = Nothing @@ -98,8 +99,8 @@ pevalDefaultComplementBitsTerm =   unaryUnfoldOnce doPevalComplementBitsTerm complementBitsTerm   where-    doPevalComplementBitsTerm (ConTerm _ a) = Just $ conTerm $ complement a-    doPevalComplementBitsTerm (ComplementBitsTerm _ a) = Just a+    doPevalComplementBitsTerm (ConTerm _ _ _ _ a) = Just $ conTerm $ complement a+    doPevalComplementBitsTerm (ComplementBitsTerm _ _ _ _ a) = Just a     doPevalComplementBitsTerm _ = Nothing  instance (KnownNat n, 1 <= n) => PEvalBitwiseTerm (WordN n) where

@@ -40,6 +40,7 @@     Term (ConTerm),     conTerm,     divIntegralTerm,+    introSupportedPrimConstraint,     modIntegralTerm,     quotIntegralTerm,     remIntegralTerm,@@ -48,90 +49,99 @@  -- | Default partial evaluation of division operation for integral types. pevalDefaultDivIntegralTerm ::-  (PEvalDivModIntegralTerm a) => Term a -> Term a -> Term a-pevalDefaultDivIntegralTerm =-  binaryUnfoldOnce doPevalDefaultDivIntegralTerm divIntegralTerm+  (PEvalDivModIntegralTerm a, Integral a) => Term a -> Term a -> Term a+pevalDefaultDivIntegralTerm l r =+  introSupportedPrimConstraint l $+    binaryUnfoldOnce doPevalDefaultDivIntegralTerm divIntegralTerm l r  doPevalDefaultDivIntegralTerm ::-  (PEvalDivModIntegralTerm a) => Term a -> Term a -> Maybe (Term a)-doPevalDefaultDivIntegralTerm (ConTerm _ a) (ConTerm _ b)+  (PEvalDivModIntegralTerm a, Integral a) => Term a -> Term a -> Maybe (Term a)+doPevalDefaultDivIntegralTerm (ConTerm _ _ _ _ a) (ConTerm _ _ _ _ b)   | b /= 0 = Just $ conTerm $ a `div` b-doPevalDefaultDivIntegralTerm a (ConTerm _ 1) = Just a+doPevalDefaultDivIntegralTerm a (ConTerm _ _ _ _ 1) = Just a doPevalDefaultDivIntegralTerm _ _ = Nothing  -- | Default partial evaluation of division operation for bounded integral -- types. pevalDefaultDivBoundedIntegralTerm ::-  (PEvalDivModIntegralTerm a, Bounded a) => Term a -> Term a -> Term a-pevalDefaultDivBoundedIntegralTerm =-  binaryUnfoldOnce doPevalDefaultDivBoundedIntegralTerm divIntegralTerm+  (PEvalDivModIntegralTerm a, Bounded a, Integral a) =>+  Term a ->+  Term a ->+  Term a+pevalDefaultDivBoundedIntegralTerm l r =+  introSupportedPrimConstraint l $+    binaryUnfoldOnce doPevalDefaultDivBoundedIntegralTerm divIntegralTerm l r  doPevalDefaultDivBoundedIntegralTerm ::-  (PEvalDivModIntegralTerm a, Bounded a) =>+  (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) => Term a -> Term a -> Term a-pevalDefaultModIntegralTerm =-  binaryUnfoldOnce doPevalDefaultModIntegralTerm modIntegralTerm+  (PEvalDivModIntegralTerm a, Integral a) => Term a -> Term a -> Term a+pevalDefaultModIntegralTerm l r =+  introSupportedPrimConstraint l $+    binaryUnfoldOnce doPevalDefaultModIntegralTerm modIntegralTerm l r  doPevalDefaultModIntegralTerm ::-  (PEvalDivModIntegralTerm a) => Term a -> Term a -> Maybe (Term a)-doPevalDefaultModIntegralTerm (ConTerm _ a) (ConTerm _ b)+  (PEvalDivModIntegralTerm a, Integral a) => Term a -> Term a -> Maybe (Term a)+doPevalDefaultModIntegralTerm (ConTerm _ _ _ _ a) (ConTerm _ _ _ _ b)   | b /= 0 = Just $ conTerm $ a `mod` b-doPevalDefaultModIntegralTerm _ (ConTerm _ 1) = Just $ conTerm 0-doPevalDefaultModIntegralTerm _ (ConTerm _ (-1)) = Just $ conTerm 0+doPevalDefaultModIntegralTerm _ (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) => Term a -> Term a -> Term a-pevalDefaultQuotIntegralTerm =-  binaryUnfoldOnce doPevalDefaultQuotIntegralTerm quotIntegralTerm+  (PEvalDivModIntegralTerm a, Integral a) => Term a -> Term a -> Term a+pevalDefaultQuotIntegralTerm l r =+  introSupportedPrimConstraint l $+    binaryUnfoldOnce doPevalDefaultQuotIntegralTerm quotIntegralTerm l r  doPevalDefaultQuotIntegralTerm ::-  (PEvalDivModIntegralTerm a) => Term a -> Term a -> Maybe (Term a)-doPevalDefaultQuotIntegralTerm (ConTerm _ a) (ConTerm _ b)+  (PEvalDivModIntegralTerm a, Integral a) => Term a -> Term a -> Maybe (Term a)+doPevalDefaultQuotIntegralTerm (ConTerm _ _ _ _ a) (ConTerm _ _ _ _ b)   | b /= 0 = Just $ conTerm $ a `quot` b-doPevalDefaultQuotIntegralTerm a (ConTerm _ 1) = Just a+doPevalDefaultQuotIntegralTerm a (ConTerm _ _ _ _ 1) = Just a doPevalDefaultQuotIntegralTerm _ _ = Nothing  -- | Default partial evaluation of quotient operation for bounded integral -- types. pevalDefaultQuotBoundedIntegralTerm ::-  (PEvalDivModIntegralTerm a, Bounded a) => Term a -> Term a -> Term a-pevalDefaultQuotBoundedIntegralTerm =-  binaryUnfoldOnce doPevalDefaultQuotBoundedIntegralTerm quotIntegralTerm+  (PEvalDivModIntegralTerm a, Bounded a, Integral a) => Term a -> Term a -> Term a+pevalDefaultQuotBoundedIntegralTerm l r =+  introSupportedPrimConstraint l $+    binaryUnfoldOnce doPevalDefaultQuotBoundedIntegralTerm quotIntegralTerm l r  doPevalDefaultQuotBoundedIntegralTerm ::-  (PEvalDivModIntegralTerm a, Bounded a) =>+  (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) => Term a -> Term a -> Term a-pevalDefaultRemIntegralTerm =-  binaryUnfoldOnce doPevalDefaultRemIntegralTerm remIntegralTerm+  (PEvalDivModIntegralTerm a, Integral a) => Term a -> Term a -> Term a+pevalDefaultRemIntegralTerm l r =+  introSupportedPrimConstraint l $+    binaryUnfoldOnce doPevalDefaultRemIntegralTerm remIntegralTerm l r  doPevalDefaultRemIntegralTerm ::-  (PEvalDivModIntegralTerm a) => Term a -> Term a -> Maybe (Term a)-doPevalDefaultRemIntegralTerm (ConTerm _ a) (ConTerm _ b)+  (PEvalDivModIntegralTerm a, Integral a) => Term a -> Term a -> Maybe (Term a)+doPevalDefaultRemIntegralTerm (ConTerm _ _ _ _ a) (ConTerm _ _ _ _ b)   | b /= 0 = Just $ conTerm $ a `rem` b-doPevalDefaultRemIntegralTerm _ (ConTerm _ 1) = Just $ conTerm 0-doPevalDefaultRemIntegralTerm _ (ConTerm _ (-1)) = Just $ conTerm 0+doPevalDefaultRemIntegralTerm _ (ConTerm _ _ _ _ 1) = Just $ conTerm 0+doPevalDefaultRemIntegralTerm _ (ConTerm _ _ _ _ (-1)) = Just $ conTerm 0 doPevalDefaultRemIntegralTerm _ _ = Nothing  instance PEvalDivModIntegralTerm Integer where

@@ -83,7 +83,7 @@   Term Bool pevalFPTraitTerm trait = unaryUnfoldOnce doPevalFPTraitTerm (fpTraitTerm trait)   where-    doPevalFPTraitTerm (ConTerm _ a) = case trait of+    doPevalFPTraitTerm (ConTerm _ _ _ _ a) = case trait of       FPIsNaN -> Just $ conTerm $ isNaN a       FPIsPositive ->         Just $@@ -172,7 +172,7 @@   Term (FP eb sb) ->   Term (FP eb sb) ->   Term (FP eb sb)-pevalFPBinaryTerm bop (ConTerm _ l) (ConTerm _ r) =+pevalFPBinaryTerm bop (ConTerm _ _ _ _ l) (ConTerm _ _ _ _ r) =   case bop of     FPMaximum -> conTerm $ fpMaximum l r     FPMaximumNumber -> conTerm $ fpMaximumNumber l r@@ -223,12 +223,12 @@  -- | Partially evaluate a floating-point rounding unary term. pevalFPRoundingUnaryTerm ::-  (ValidFP eb sb, SupportedPrim (FP eb sb), SupportedPrim FPRoundingMode) =>+  (ValidFP eb sb, SupportedPrim (FP eb sb)) =>   FPRoundingUnaryOp ->   Term FPRoundingMode ->   Term (FP eb sb) ->   Term (FP eb sb)-pevalFPRoundingUnaryTerm uop (ConTerm _ rd) (ConTerm _ l) =+pevalFPRoundingUnaryTerm uop (ConTerm _ _ _ _ rd) (ConTerm _ _ _ _ l) =   case uop of     FPSqrt -> conTerm $ fpSqrt rd l     FPRoundToIntegral -> conTerm $ fpRoundToIntegral rd l@@ -248,13 +248,13 @@  -- | Partially evaluate a floating-point rounding binary term. pevalFPRoundingBinaryTerm ::-  (ValidFP eb sb, SupportedPrim (FP eb sb), SupportedPrim FPRoundingMode) =>+  (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) =+pevalFPRoundingBinaryTerm bop (ConTerm _ _ _ _ rd) (ConTerm _ _ _ _ l) (ConTerm _ _ _ _ r) =   case bop of     FPAdd -> conTerm $ fpAdd rd l r     FPSub -> conTerm $ fpSub rd l r@@ -279,14 +279,18 @@  -- | Partially evaluate a floating-point fused multiply-add term. pevalFPFMATerm ::-  (ValidFP eb sb, SupportedPrim (FP eb sb), SupportedPrim FPRoundingMode) =>+  (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+  (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 #-} 

@@ -28,6 +28,7 @@     Term (ConTerm),     conTerm,     fdivTerm,+    introSupportedPrimConstraint,     recipTerm,   ) import Grisette.Internal.SymPrim.Prim.Internal.Unfold@@ -43,24 +44,27 @@   withSbvFractionalTermConstraint r = withPrim @(FP eb sb) r  pevalDefaultFdivTerm ::-  (PEvalFractionalTerm a) => Term a -> Term a -> Term a-pevalDefaultFdivTerm =-  binaryUnfoldOnce doPevalDefaultFdivTerm fdivTerm+  (PEvalFractionalTerm a, Eq a) => Term a -> Term a -> Term a+pevalDefaultFdivTerm l r =+  introSupportedPrimConstraint l $+    binaryUnfoldOnce doPevalDefaultFdivTerm fdivTerm l r  doPevalDefaultFdivTerm ::-  (PEvalFractionalTerm a) => Term a -> Term a -> Maybe (Term a)-doPevalDefaultFdivTerm (ConTerm _ a) (ConTerm _ b)+  (PEvalFractionalTerm a, Eq a) => Term a -> Term a -> Maybe (Term a)+doPevalDefaultFdivTerm (ConTerm _ _ _ _ a) (ConTerm _ _ _ _ b)   | b /= 0 = Just $ conTerm $ a / b-doPevalDefaultFdivTerm a (ConTerm _ 1) = Just a+doPevalDefaultFdivTerm a (ConTerm _ _ _ _ 1) = Just a doPevalDefaultFdivTerm _ _ = Nothing  pevalDefaultRecipTerm ::-  (PEvalFractionalTerm a) => Term a -> Term a-pevalDefaultRecipTerm = unaryUnfoldOnce doPevalDefaultRecipTerm recipTerm+  (PEvalFractionalTerm a, Eq a) => Term a -> Term a+pevalDefaultRecipTerm l =+  introSupportedPrimConstraint l $+    unaryUnfoldOnce doPevalDefaultRecipTerm recipTerm l  doPevalDefaultRecipTerm ::-  (PEvalFractionalTerm a) => Term a -> Maybe (Term a)-doPevalDefaultRecipTerm (ConTerm _ n) | n /= 0 = Just $ conTerm $ recip n+  (PEvalFractionalTerm a, Eq a) => Term a -> Maybe (Term a)+doPevalDefaultRecipTerm (ConTerm _ _ _ _ n) | n /= 0 = Just $ conTerm $ recip n doPevalDefaultRecipTerm _ = Nothing  instance PEvalFractionalTerm AlgReal where

@@ -30,18 +30,24 @@ import Grisette.Internal.SymPrim.Prim.Internal.Term   ( PEvalFromIntegralTerm (pevalFromIntegralTerm, sbvFromIntegralTerm),     SupportedNonFuncPrim (withNonFuncPrim),+    SupportedPrim,     Term (ConTerm),     conTerm,     fromIntegralTerm,   ) import Grisette.Internal.SymPrim.Prim.Internal.Unfold (unaryUnfoldOnce) -pevalFromIntegralTermGeneric :: (PEvalFromIntegralTerm a b) => Term a -> Term b+pevalFromIntegralTermGeneric ::+  (PEvalFromIntegralTerm a b, SupportedPrim b) => Term a -> Term b 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+  pevalFromIntegralTerm = id+  sbvFromIntegralTerm = id  instance PEvalFromIntegralTerm Integer AlgReal where   pevalFromIntegralTerm = pevalFromIntegralTermGeneric

@@ -27,7 +27,13 @@ import qualified Data.SBV.Internals as SBVI import GHC.TypeLits (KnownNat, Nat, type (<=)) import Grisette.Internal.Core.Data.Class.IEEEFP-  ( IEEEFPConstants (fpNaN, fpNegativeInfinite, fpNegativeZero, fpPositiveInfinite, fpPositiveZero),+  ( IEEEFPConstants+      ( fpNaN,+        fpNegativeInfinite,+        fpNegativeZero,+        fpPositiveInfinite,+        fpPositiveZero+      ),     IEEEFPConvertible (fromFPOr, toFP),     fpIsInfinite,     fpIsNaN,@@ -130,29 +136,30 @@ generalPevalFromFPOrTerm ::   ( PEvalIEEEFPConvertibleTerm a,     ValidFP eb sb,+    SupportedPrim a,     IEEEFPConvertible a (FP eb sb) FPRoundingMode   ) =>   Term a ->   Term FPRoundingMode ->   Term (FP eb sb) ->   Term a-generalPevalFromFPOrTerm (ConTerm _ d) (ConTerm _ rd) (ConTerm _ f) =+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 ::-  ( PEvalIEEEFPConvertibleTerm a,+  ( PEvalIEEEFPConvertibleTerm AlgReal,     ValidFP eb sb,-    IEEEFPConvertible a (FP eb sb) FPRoundingMode+    IEEEFPConvertible AlgReal (FP eb sb) FPRoundingMode   ) =>-  Term a ->+  Term AlgReal ->   Term FPRoundingMode ->   Term (FP eb sb) ->-  Term a-algRealPevalFromFPOrTerm (ConTerm _ d) _ (ConTerm _ f) =+  Term AlgReal+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 ::@@ -163,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 @@ -185,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

@@ -44,6 +44,7 @@     absNumTerm,     addNumTerm,     conTerm,+    introSupportedPrimConstraint,     mulNumTerm,     negNumTerm,     pevalSubNumTerm,@@ -57,122 +58,132 @@   )  -- | Default partial evaluation of addition of numerical terms.-pevalDefaultAddNumTerm :: (PEvalNumTerm a) => Term a -> Term a -> Term a-pevalDefaultAddNumTerm =-  binaryUnfoldOnce-    doPevalDefaultAddNumTerm-    (\a b -> normalizeAddNum $ addNumTerm a b)+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) => 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+  (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) ->+  (l1, AddNumTerm _ _ _ _ (ConTerm _ _ _ _ j) k) ->     Just $ pevalAddNumTerm (conTerm $ l1 + j) k   _ -> doPevalDefaultAddNumTermNoCon l b-doPevalDefaultAddNumTerm a r@(ConTerm _ _) = doPevalDefaultAddNumTerm r a+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 =+doPevalDefaultAddNumTermNoCon (AddNumTerm _ _ _ _ i@ConTerm {} j) k =   Just $ pevalAddNumTerm i $ pevalAddNumTerm j k-doPevalDefaultAddNumTermNoCon i (AddNumTerm _ j@ConTerm {} k) =+doPevalDefaultAddNumTermNoCon i (AddNumTerm _ _ _ _ j@ConTerm {} k) =   Just $ pevalAddNumTerm j $ pevalAddNumTerm i k-doPevalDefaultAddNumTermNoCon (NegNumTerm _ i) (NegNumTerm _ j) =+doPevalDefaultAddNumTermNoCon (NegNumTerm _ _ _ _ i) (NegNumTerm _ _ _ _ j) =   Just $ pevalNegNumTerm $ pevalAddNumTerm i j doPevalDefaultAddNumTermNoCon-  (MulNumTerm _ (ConTerm _ i) j)-  (MulNumTerm _ (ConTerm _ k) l)+  (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)+  (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 (AddNumTerm _ _ _ _ l r@(ConTerm {})) = addNumTerm r l normalizeAddNum v = v  -- | Default partial evaluation of negation of numerical terms.-pevalDefaultNegNumTerm :: (PEvalNumTerm a) => Term a -> Term a-pevalDefaultNegNumTerm = unaryUnfoldOnce doPevalDefaultNegNumTerm negNumTerm+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) =+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) =+doPevalDefaultNegNumTerm (AddNumTerm _ _ _ _ (NegNumTerm _ _ _ _ l) r) =   Just $ pevalAddNumTerm l (pevalNegNumTerm r)-doPevalDefaultNegNumTerm (AddNumTerm _ l (NegNumTerm _ r)) =+doPevalDefaultNegNumTerm (AddNumTerm _ _ _ _ l (NegNumTerm _ _ _ _ r)) =   Just $ pevalAddNumTerm (pevalNegNumTerm l) r-doPevalDefaultNegNumTerm (MulNumTerm _ (ConTerm _ l) r) =+doPevalDefaultNegNumTerm (MulNumTerm _ _ _ _ (ConTerm _ _ _ _ l) r) =   Just $ pevalMulNumTerm (conTerm $ -l) r-doPevalDefaultNegNumTerm (MulNumTerm _ (NegNumTerm _ _) _) =+doPevalDefaultNegNumTerm (MulNumTerm _ _ _ _ (NegNumTerm {}) _) =   error "Should not happen"-doPevalDefaultNegNumTerm (MulNumTerm _ _ (NegNumTerm _ _)) =+doPevalDefaultNegNumTerm (MulNumTerm _ _ _ _ _ (NegNumTerm {})) =   error "Should not happen"-doPevalDefaultNegNumTerm (AddNumTerm _ _ ConTerm {}) = error "Should not happen"+doPevalDefaultNegNumTerm (AddNumTerm _ _ _ _ _ ConTerm {}) = error "Should not happen" doPevalDefaultNegNumTerm _ = Nothing  -- Mul-pevalDefaultMulNumTerm :: (PEvalNumTerm a) => Term a -> Term a -> Term a-pevalDefaultMulNumTerm =-  binaryUnfoldOnce-    doPevalDefaultMulNumTerm-    (\a b -> normalizeMulNum $ mulNumTerm a b)+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 (MulNumTerm _ _ _ _ l r@(ConTerm {})) = mulNumTerm r l normalizeMulNum v = v  doPevalDefaultMulNumTerm ::-  (PEvalNumTerm 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+  (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) ->+  (l1, MulNumTerm _ _ _ _ (ConTerm _ _ _ _ j) k) ->     Just $ pevalMulNumTerm (conTerm $ l1 * j) k-  (l1, AddNumTerm _ (ConTerm _ 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"+  (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 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 =+doPevalDefaultMulNumTermNoCon (MulNumTerm _ _ _ _ i@ConTerm {} j) k =   Just $ pevalMulNumTerm i $ pevalMulNumTerm j k-doPevalDefaultMulNumTermNoCon i (MulNumTerm _ j@ConTerm {} k) =+doPevalDefaultMulNumTermNoCon i (MulNumTerm _ _ _ _ j@ConTerm {} k) =   Just $ pevalMulNumTerm j $ pevalMulNumTerm i k-doPevalDefaultMulNumTermNoCon (NegNumTerm _ i) j =+doPevalDefaultMulNumTermNoCon (NegNumTerm _ _ _ _ i) j =   Just $ pevalNegNumTerm $ pevalMulNumTerm i j-doPevalDefaultMulNumTermNoCon i (NegNumTerm _ j) =+doPevalDefaultMulNumTermNoCon i (NegNumTerm _ _ _ _ j) =   Just $ pevalNegNumTerm $ pevalMulNumTerm i j doPevalDefaultMulNumTermNoCon i j@ConTerm {} = Just $ pevalMulNumTerm j i-doPevalDefaultMulNumTermNoCon (MulNumTerm _ _ ConTerm {}) _ =+doPevalDefaultMulNumTermNoCon (MulNumTerm _ _ _ _ _ ConTerm {}) _ =   error "Should not happen"-doPevalDefaultMulNumTermNoCon _ (MulNumTerm _ _ ConTerm {}) =+doPevalDefaultMulNumTermNoCon _ (MulNumTerm _ _ _ _ _ ConTerm {}) =   error "Should not happen" doPevalDefaultMulNumTermNoCon _ _ = Nothing  -- Abs pevalBitsAbsNumTerm :: (PEvalNumTerm a, Bits a) => Term a -> Term a-pevalBitsAbsNumTerm =-  unaryUnfoldOnce doPevalBitsAbsNumTerm absNumTerm+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 (ConTerm _ _ _ _ a) = Just $ conTerm $ abs a+doPevalGeneralAbsNumTerm (NegNumTerm _ _ _ _ v) = Just $ pevalAbsNumTerm v+doPevalGeneralAbsNumTerm t@(AbsNumTerm {}) = Just t doPevalGeneralAbsNumTerm _ = Nothing  doPevalBitsAbsNumTerm ::@@ -188,7 +199,7 @@   msum     [ doPevalGeneralAbsNumTerm t,       case t of-        MulNumTerm _ l r ->+        MulNumTerm _ _ _ _ l r ->           Just $ pevalMulNumTerm (pevalAbsNumTerm l) $ pevalAbsNumTerm r         _ -> Nothing     ]@@ -196,11 +207,12 @@ -- Signum  pevalGeneralSignumNumTerm :: (PEvalNumTerm a) => Term a -> Term a-pevalGeneralSignumNumTerm =-  unaryUnfoldOnce doPevalGeneralSignumNumTerm signumNumTerm+pevalGeneralSignumNumTerm l =+  introSupportedPrimConstraint l $+    unaryUnfoldOnce doPevalGeneralSignumNumTerm signumNumTerm l  doPevalGeneralSignumNumTerm :: (PEvalNumTerm a) => Term a -> Maybe (Term a)-doPevalGeneralSignumNumTerm (ConTerm _ a) = Just $ conTerm $ signum a+doPevalGeneralSignumNumTerm (ConTerm _ _ _ _ a) = Just $ conTerm $ signum a doPevalGeneralSignumNumTerm _ = Nothing  doPevalNoOverflowSignumNumTerm :: (PEvalNumTerm a) => Term a -> Maybe (Term a)@@ -208,8 +220,8 @@   msum     [ doPevalGeneralSignumNumTerm t,       case t of-        NegNumTerm _ v -> Just $ pevalNegNumTerm $ pevalSignumNumTerm v-        MulNumTerm _ l r ->+        NegNumTerm _ _ _ _ v -> Just $ pevalNegNumTerm $ pevalSignumNumTerm v+        MulNumTerm _ _ _ _ l r ->           Just $             pevalMulNumTerm (pevalSignumNumTerm l) $               pevalSignumNumTerm r

@@ -54,21 +54,21 @@ import Grisette.Internal.SymPrim.Prim.Internal.Unfold (binaryUnfoldOnce)  -- | General partially evaluation of less than operation.-pevalGeneralLtOrdTerm :: (PEvalOrdTerm a) => Term a -> Term a -> Term Bool+pevalGeneralLtOrdTerm :: (PEvalOrdTerm a, Ord a) => Term a -> Term a -> Term Bool pevalGeneralLtOrdTerm = binaryUnfoldOnce doPevalGeneralLtOrdTerm ltOrdTerm  doPevalGeneralLtOrdTerm ::-  (PEvalOrdTerm a) => Term a -> Term a -> Maybe (Term Bool)-doPevalGeneralLtOrdTerm (ConTerm _ a) (ConTerm _ b) = Just $ conTerm $ a < b+  (PEvalOrdTerm a, Ord a) => Term a -> Term a -> Maybe (Term Bool)+doPevalGeneralLtOrdTerm (ConTerm _ _ _ _ a) (ConTerm _ _ _ _ b) = Just $ conTerm $ a < b doPevalGeneralLtOrdTerm _ _ = Nothing  -- | General partially evaluation of less than or equal to operation.-pevalGeneralLeOrdTerm :: (PEvalOrdTerm a) => Term a -> Term a -> Term Bool+pevalGeneralLeOrdTerm :: (PEvalOrdTerm a, Ord a) => Term a -> Term a -> Term Bool pevalGeneralLeOrdTerm = binaryUnfoldOnce doPevalGeneralLeOrdTerm leOrdTerm  doPevalGeneralLeOrdTerm ::-  (PEvalOrdTerm a) => Term a -> Term a -> Maybe (Term Bool)-doPevalGeneralLeOrdTerm (ConTerm _ a) (ConTerm _ b) = Just $ conTerm $ a <= b+  (PEvalOrdTerm a, Ord a) => Term a -> Term a -> Maybe (Term Bool)+doPevalGeneralLeOrdTerm (ConTerm _ _ _ _ a) (ConTerm _ _ _ _ b) = Just $ conTerm $ a <= b doPevalGeneralLeOrdTerm _ _ = Nothing  instance PEvalOrdTerm Integer where@@ -78,18 +78,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           ]@@ -99,15 +99,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           ]

@@ -28,10 +28,17 @@ 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, pevalRotateRightTerm, sbvRotateLeftTerm, sbvRotateRightTerm, withSbvRotateTermConstraint),+  ( PEvalRotateTerm+      ( pevalRotateLeftTerm,+        pevalRotateRightTerm,+        sbvRotateLeftTerm,+        sbvRotateRightTerm,+        withSbvRotateTermConstraint+      ),     SupportedNonFuncPrim (withNonFuncPrim),     Term (ConTerm),     conTerm,+    introSupportedPrimConstraint,     rotateLeftTerm,     rotateRightTerm,   )@@ -45,10 +52,11 @@   Term a ->   Term a pevalFiniteBitsSymRotateRotateLeftTerm t n =-  unaryUnfoldOnce-    (`doPevalFiniteBitsSymRotateRotateLeftTerm` n)-    (`rotateLeftTerm` n)-    t+  introSupportedPrimConstraint t $+    unaryUnfoldOnce+      (`doPevalFiniteBitsSymRotateRotateLeftTerm` n)+      (`rotateLeftTerm` n)+      t  doPevalFiniteBitsSymRotateRotateLeftTerm ::   forall a.@@ -56,12 +64,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@@ -79,10 +87,11 @@   Term a ->   Term a pevalFiniteBitsSymRotateRotateRightTerm t n =-  unaryUnfoldOnce-    (`doPevalFiniteBitsSymRotateRotateRightTerm` n)-    (`rotateRightTerm` n)-    t+  introSupportedPrimConstraint t $+    unaryUnfoldOnce+      (`doPevalFiniteBitsSymRotateRotateRightTerm` n)+      (`rotateRightTerm` n)+      t  doPevalFiniteBitsSymRotateRotateRightTerm ::   forall a.@@ -90,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@@ -99,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

@@ -32,6 +32,7 @@     SupportedPrim,     Term (ConTerm),     conTerm,+    introSupportedPrimConstraint,     shiftLeftTerm,     shiftRightTerm,   )@@ -45,10 +46,11 @@   Term a ->   Term a pevalFiniteBitsSymShiftShiftLeftTerm t n =-  unaryUnfoldOnce-    (`doPevalFiniteBitsSymShiftShiftLeftTerm` n)-    (`shiftLeftTerm` n)-    t+  introSupportedPrimConstraint t $+    unaryUnfoldOnce+      (`doPevalFiniteBitsSymShiftShiftLeftTerm` n)+      (`shiftLeftTerm` n)+      t  doPevalFiniteBitsSymShiftShiftLeftTerm ::   forall a.@@ -56,16 +58,16 @@   Term a ->   Term a ->   Maybe (Term a)-doPevalFiniteBitsSymShiftShiftLeftTerm (ConTerm _ a) (ConTerm _ 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)+doPevalFiniteBitsSymShiftShiftLeftTerm _ (ConTerm _ _ _ _ n)   | n >= 0 && (fromIntegral n :: Integer) >= fromIntegral (finiteBitSize n) =       Just $ conTerm zeroBits doPevalFiniteBitsSymShiftShiftLeftTerm _ _ = Nothing@@ -78,10 +80,11 @@   Term a ->   Term a pevalFiniteBitsSymShiftShiftRightTerm t n =-  unaryUnfoldOnce-    (`doPevalFiniteBitsSymShiftShiftRightTerm` n)-    (`shiftRightTerm` n)-    t+  introSupportedPrimConstraint t $+    unaryUnfoldOnce+      (`doPevalFiniteBitsSymShiftShiftRightTerm` n)+      (`shiftRightTerm` n)+      t  doPevalFiniteBitsSymShiftShiftRightTerm ::   forall a.@@ -89,18 +92,18 @@   Term a ->   Term a ->   Maybe (Term a)-doPevalFiniteBitsSymShiftShiftRightTerm (ConTerm _ a) (ConTerm _ 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)+doPevalFiniteBitsSymShiftShiftRightTerm _ (ConTerm _ _ _ _ n)   | not (isSigned n)       && (fromIntegral n :: Integer) >= fromIntegral (finiteBitSize n) =       Just $ conTerm zeroBits

@@ -25,12 +25,17 @@ 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@@ -53,14 +58,16 @@       ( castTypedSymbol,         conSBVTerm,         defaultValue,-        defaultValueDynamic,         funcDummyConstraint,-        isFuncType,+        hashConWithSalt,         parseSMTModelResult,         pevalDistinctTerm,         pevalEqTerm,         pevalITETerm,         pformatCon,+        sameCon,+        sbvDistinct,+        sbvEq,         sbvIte,         symSBVName,         symSBVTerm,@@ -70,7 +77,7 @@       ( PrimConstraint       ),     Term (ConTerm),-    TypedSymbol (TypedSymbol),+    TypedSymbol (unTypedSymbol),     conTerm,     distinctTerm,     eqTerm,@@ -79,16 +86,14 @@     pevalITEBasicTerm,     pevalNotTerm,     sbvFresh,+    typedAnySymbol,+    typedConstantSymbol,   )-import Grisette.Internal.SymPrim.Prim.ModelValue (ModelValue, toModelValue) import Grisette.Internal.Utils.Parameterized (unsafeAxiom)  defaultValueForInteger :: Integer defaultValueForInteger = 0 -defaultValueForIntegerDyn :: ModelValue-defaultValueForIntegerDyn = toModelValue defaultValueForInteger- -- Basic Integer instance SBVRep Integer where   type SBVType Integer = SBV.SBV Integer@@ -105,35 +110,47 @@     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 = distinctTerm l+pevalGeneralDistinct l =+  case getAllConcrete (toList l) of+    Nothing -> distinctTerm l+    Just xs -> conTerm $ checkConcreteDistinct xs  instance SupportedPrim Integer where   pformatCon = show   defaultValue = defaultValueForInteger-  defaultValueDynamic _ = defaultValueForIntegerDyn   pevalITETerm = pevalITEBasicTerm   pevalEqTerm = pevalDefaultEqTerm   pevalDistinctTerm = pevalGeneralDistinct   conSBVTerm n = fromInteger n   symSBVName symbol _ = show symbol   symSBVTerm name = sbvFresh name-  withPrim r = r   parseSMTModelResult _ = parseScalarSMTModelResult id   castTypedSymbol ::     forall knd knd'.     (IsSymbolKind knd') =>     TypedSymbol knd Integer ->     Maybe (TypedSymbol knd' Integer)-  castTypedSymbol (TypedSymbol s) =+  castTypedSymbol s =     case decideSymbolKind @knd' of-      Left HRefl -> Just $ TypedSymbol s-      Right HRefl -> Just $ TypedSymbol s-  isFuncType = False+      Left HRefl -> Just $ typedConstantSymbol $ unTypedSymbol s+      Right HRefl -> Just $ typedAnySymbol $ unTypedSymbol s   funcDummyConstraint _ = SBV.sTrue  instance NonFuncSBVRep Integer where@@ -152,6 +169,8 @@   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@@ -161,6 +180,7 @@   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@@ -169,11 +189,10 @@     (IsSymbolKind knd') =>     TypedSymbol knd (IntN w) ->     Maybe (TypedSymbol knd' (IntN w))-  castTypedSymbol (TypedSymbol s) =+  castTypedSymbol s =     case decideSymbolKind @knd' of-      Left HRefl -> Just $ TypedSymbol s-      Right HRefl -> Just $ TypedSymbol s-  isFuncType = False+      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@@ -186,6 +205,7 @@   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@@ -203,6 +223,8 @@   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@@ -212,6 +234,7 @@   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@@ -220,11 +243,10 @@     (IsSymbolKind knd') =>     TypedSymbol knd (WordN w) ->     Maybe (TypedSymbol knd' (WordN w))-  castTypedSymbol (TypedSymbol s) =+  castTypedSymbol s =     case decideSymbolKind @knd' of-      Left HRefl -> Just $ TypedSymbol s-      Right HRefl -> Just $ TypedSymbol s-  isFuncType = False+      Left HRefl -> Just $ typedConstantSymbol $ unTypedSymbol s+      Right HRefl -> Just $ typedAnySymbol $ unTypedSymbol s   funcDummyConstraint _ = SBV.sTrue  instance (KnownNat w, 1 <= w) => NonFuncSBVRep (WordN w) where@@ -243,20 +265,32 @@   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 (ConTerm _ _ _ _ l) (ConTerm _ _ _ _ r) = conTerm $ l == r   pevalEqTerm l@ConTerm {} r = pevalEqTerm r l   pevalEqTerm l r = eqTerm l r-  pevalDistinctTerm = distinctTerm+  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-  withPrim r = r   parseSMTModelResult _ cv =     withPrim @(FP eb sb) $       parseScalarSMTModelResult (\(x :: SBV.FloatingPoint eb sb) -> coerce x) cv-  isFuncType = False   funcDummyConstraint _ = SBV.sTrue    -- Workaround for sbv#702.@@ -276,10 +310,10 @@     (IsSymbolKind knd') =>     TypedSymbol knd (FP eb sb) ->     Maybe (TypedSymbol knd' (FP eb sb))-  castTypedSymbol (TypedSymbol s) =+  castTypedSymbol s =     case decideSymbolKind @knd' of-      Left HRefl -> Just $ TypedSymbol s-      Right HRefl -> Just $ TypedSymbol s+      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@@ -298,7 +332,7 @@ instance SupportedPrim FPRoundingMode where   defaultValue = RNE   pevalITETerm = pevalITEBasicTerm-  pevalEqTerm (ConTerm _ l) (ConTerm _ r) = conTerm $ l == r+  pevalEqTerm (ConTerm _ _ _ _ l) (ConTerm _ _ _ _ r) = conTerm $ l == r   pevalEqTerm l@ConTerm {} r = pevalEqTerm r l   pevalEqTerm l r = eqTerm l r   pevalDistinctTerm = pevalGeneralDistinct@@ -309,7 +343,6 @@   conSBVTerm RTZ = SBV.sRTZ   symSBVName symbol _ = show symbol   symSBVTerm name = sbvFresh name-  withPrim r = r   parseSMTModelResult _ cv =     withPrim @(FPRoundingMode) $       parseScalarSMTModelResult@@ -326,11 +359,10 @@     (IsSymbolKind knd') =>     TypedSymbol knd FPRoundingMode ->     Maybe (TypedSymbol knd' FPRoundingMode)-  castTypedSymbol (TypedSymbol s) =+  castTypedSymbol s =     case decideSymbolKind @knd' of-      Left HRefl -> Just $ TypedSymbol s-      Right HRefl -> Just $ TypedSymbol s-  isFuncType = False+      Left HRefl -> Just $ typedConstantSymbol $ unTypedSymbol s+      Right HRefl -> Just $ typedAnySymbol $ unTypedSymbol s   funcDummyConstraint _ = SBV.sTrue  instance NonFuncSBVRep FPRoundingMode where@@ -351,14 +383,13 @@ instance SupportedPrim AlgReal where   defaultValue = 0   pevalITETerm = pevalITEBasicTerm-  pevalEqTerm (ConTerm _ l) (ConTerm _ r) = conTerm $ l == r+  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-  withPrim r = r   parseSMTModelResult _ cv =     withPrim @AlgReal $       parseScalarSMTModelResult fromSBVAlgReal cv@@ -367,11 +398,10 @@     (IsSymbolKind knd') =>     TypedSymbol knd AlgReal ->     Maybe (TypedSymbol knd' AlgReal)-  castTypedSymbol (TypedSymbol s) =+  castTypedSymbol s =     case decideSymbolKind @knd' of-      Left HRefl -> Just $ TypedSymbol s-      Right HRefl -> Just $ TypedSymbol s-  isFuncType = False+      Left HRefl -> Just $ typedConstantSymbol $ unTypedSymbol s+      Right HRefl -> Just $ typedAnySymbol $ unTypedSymbol s   funcDummyConstraint _ = SBV.sTrue  instance NonFuncSBVRep AlgReal where

@@ -0,0 +1,2205 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      :   Grisette.Internal.SymPrim.Prim.Internal.Serialize+-- Copyright   :   (c) Sirui Lu 2024+-- License     :   BSD-3-Clause (see the LICENSE file)+--+-- Maintainer  :   siruilu@cs.washington.edu+-- Stability   :   Experimental+-- Portability :   GHC only+module Grisette.Internal.SymPrim.Prim.Internal.Serialize () where++import Control.Monad (replicateM, unless, when)+import Control.Monad.State (StateT, evalStateT)+import qualified Control.Monad.State as State+import qualified Data.Binary as Binary+import Data.Bytes.Get (MonadGet (getWord8))+import Data.Bytes.Put (MonadPut (putWord8))+import Data.Bytes.Serial (Serial (deserialize, serialize))+import Data.Foldable (traverse_)+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS+import Data.Hashable (Hashable (hashWithSalt))+import Data.List (intercalate)+import Data.List.NonEmpty (NonEmpty ((:|)))+import Data.Proxy (Proxy (Proxy))+import qualified Data.Serialize as Cereal+import Data.Word (Word8)+import GHC.Generics (Generic)+import GHC.Natural (Natural)+import GHC.Stack (HasCallStack)+import GHC.TypeNats (KnownNat, natVal, type (+), type (<=))+import Grisette.Internal.SymPrim.AlgReal (AlgReal)+import Grisette.Internal.SymPrim.BV (IntN, WordN)+import Grisette.Internal.SymPrim.FP+  ( FP,+    FPRoundingMode,+    ValidFP,+    checkDynamicValidFP,+    invalidFPMessage,+    withUnsafeValidFP,+  )+import Grisette.Internal.SymPrim.GeneralFun (type (-->) (GeneralFun))+import Grisette.Internal.SymPrim.Prim.Internal.Caches (Id)+import Grisette.Internal.SymPrim.Prim.Internal.Instances.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 ()+import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalFromIntegralTerm ()+import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalIEEEFPConvertibleTerm ()+import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalNumTerm ()+import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalOrdTerm ()+import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalRotateTerm ()+import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalShiftTerm ()+import Grisette.Internal.SymPrim.Prim.Internal.Instances.SupportedPrim ()+import Grisette.Internal.SymPrim.Prim.Internal.Term+  ( FPBinaryOp,+    FPRoundingBinaryOp,+    FPRoundingUnaryOp,+    FPTrait,+    FPUnaryOp,+    IsSymbolKind (decideSymbolKind),+    ModelValue (ModelValue),+    PEvalBitCastTerm,+    PEvalBitwiseTerm,+    PEvalDivModIntegralTerm,+    PEvalFloatingTerm,+    PEvalFractionalTerm,+    PEvalFromIntegralTerm,+    PEvalIEEEFPConvertibleTerm,+    PEvalNumTerm,+    PEvalOrdTerm,+    PEvalRotateTerm,+    PEvalShiftTerm,+    SomeTypedAnySymbol,+    SomeTypedSymbol (SomeTypedSymbol),+    SupportedNonFuncPrim,+    SupportedPrim (primTypeRep, withPrim),+    Term+      ( 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+      ),+    TypedAnySymbol,+    TypedConstantSymbol,+    TypedSymbol (TypedSymbol),+    absNumTerm,+    addNumTerm,+    andBitsTerm,+    andTerm,+    applyTerm,+    bitCastOrTerm,+    bitCastTerm,+    bvConcatTerm,+    bvExtendTerm,+    bvSelectTerm,+    complementBitsTerm,+    conTerm,+    distinctTerm,+    divIntegralTerm,+    eqTerm,+    existsTerm,+    fdivTerm,+    floatingUnaryTerm,+    forallTerm,+    fpBinaryTerm,+    fpFMATerm,+    fpRoundingBinaryTerm,+    fpRoundingUnaryTerm,+    fpTraitTerm,+    fpUnaryTerm,+    fromFPOrTerm,+    fromIntegralTerm,+    introSupportedPrimConstraint,+    iteTerm,+    leOrdTerm,+    ltOrdTerm,+    modIntegralTerm,+    mulNumTerm,+    negNumTerm,+    notTerm,+    orBitsTerm,+    orTerm,+    powerTerm,+    quotIntegralTerm,+    recipTerm,+    remIntegralTerm,+    rotateLeftTerm,+    rotateRightTerm,+    shiftLeftTerm,+    shiftRightTerm,+    signumNumTerm,+    someTypedSymbol,+    symTerm,+    termId,+    toFPTerm,+    withSupportedPrimTypeable,+    xorBitsTerm,+  )+import Grisette.Internal.SymPrim.Prim.SomeTerm+  ( SomeTerm (SomeTerm),+    someTerm,+  )+import Grisette.Internal.SymPrim.Prim.TermUtils (castTerm)+import Grisette.Internal.SymPrim.TabularFun (type (=->))+import Grisette.Internal.Utils.Parameterized+  ( KnownProof (KnownProof),+    LeqProof (LeqProof),+    NatRepr,+    SomeNatRepr (SomeNatRepr),+    SomePositiveNatRepr (SomePositiveNatRepr),+    mkNatRepr,+    mkPositiveNatRepr,+    unsafeAxiom,+    unsafeKnownProof,+    unsafeLeqProof,+  )+import Type.Reflection+  ( SomeTypeRep (SomeTypeRep),+    TypeRep,+    Typeable,+    eqTypeRep,+    someTypeRep,+    typeRep,+    pattern App,+    pattern Con,+    type (:~:) (Refl),+    type (:~~:) (HRefl),+  )++data KnownNonFuncType where+  BoolType :: KnownNonFuncType+  IntegerType :: KnownNonFuncType+  WordNType :: (KnownNat n, 1 <= n) => Proxy n -> KnownNonFuncType+  IntNType :: (KnownNat n, 1 <= n) => Proxy n -> KnownNonFuncType+  FPType :: (ValidFP eb sb) => Proxy eb -> Proxy sb -> KnownNonFuncType+  FPRoundingModeType :: KnownNonFuncType+  AlgRealType :: KnownNonFuncType++instance Eq KnownNonFuncType where+  BoolType == BoolType = True+  IntegerType == IntegerType = True+  WordNType p == WordNType q = natVal p == natVal q+  IntNType p == IntNType q = natVal p == natVal q+  FPType p q == FPType r s = natVal p == natVal r && natVal q == natVal s+  FPRoundingModeType == FPRoundingModeType = True+  AlgRealType == AlgRealType = True+  _ == _ = False++instance Hashable KnownNonFuncType where+  hashWithSalt s BoolType = s `hashWithSalt` (0 :: Int)+  hashWithSalt s IntegerType = s `hashWithSalt` (1 :: Int)+  hashWithSalt s (WordNType p) =+    s `hashWithSalt` (2 :: Int) `hashWithSalt` natVal p+  hashWithSalt s (IntNType p) =+    s `hashWithSalt` (3 :: Int) `hashWithSalt` natVal p+  hashWithSalt s (FPType p q) =+    s `hashWithSalt` (4 :: Int) `hashWithSalt` natVal p `hashWithSalt` natVal q+  hashWithSalt s FPRoundingModeType = s `hashWithSalt` (5 :: Int)+  hashWithSalt s AlgRealType = s `hashWithSalt` (6 :: Int)++data KnownNonFuncTypeWitness where+  KnownNonFuncTypeWitness ::+    ( SupportedNonFuncPrim a,+      Eq a,+      Show a,+      Hashable a,+      Typeable a,+      Serial a+    ) =>+    Proxy a ->+    KnownNonFuncTypeWitness++witnessKnownNonFuncType :: KnownNonFuncType -> KnownNonFuncTypeWitness+witnessKnownNonFuncType BoolType = KnownNonFuncTypeWitness (Proxy @Bool)+witnessKnownNonFuncType IntegerType = KnownNonFuncTypeWitness (Proxy @Integer)+witnessKnownNonFuncType (WordNType (Proxy :: Proxy n)) =+  KnownNonFuncTypeWitness (Proxy @(WordN n))+witnessKnownNonFuncType (IntNType (Proxy :: Proxy n)) =+  KnownNonFuncTypeWitness (Proxy @(IntN n))+witnessKnownNonFuncType (FPType (Proxy :: Proxy eb) (Proxy :: Proxy sb)) =+  KnownNonFuncTypeWitness (Proxy @(FP eb sb))+witnessKnownNonFuncType FPRoundingModeType =+  KnownNonFuncTypeWitness (Proxy @FPRoundingMode)+witnessKnownNonFuncType AlgRealType = KnownNonFuncTypeWitness (Proxy @AlgReal)++data KnownType where+  NonFuncType :: KnownNonFuncType -> KnownType+  TabularFunType :: [KnownNonFuncType] -> KnownType+  GeneralFunType :: [KnownNonFuncType] -> KnownType+  deriving (Eq, Generic, Hashable)++data KnownTypeWitness where+  KnownTypeWitness ::+    ( SupportedPrim a,+      Eq a,+      Show a,+      Hashable a,+      Typeable a,+      Serial a+    ) =>+    Proxy a ->+    KnownTypeWitness++witnessKnownType :: KnownType -> KnownTypeWitness+witnessKnownType (NonFuncType nf) = case witnessKnownNonFuncType nf of+  KnownNonFuncTypeWitness (Proxy :: Proxy a) -> KnownTypeWitness (Proxy @a)+witnessKnownType (TabularFunType [a, b]) =+  case (witnessKnownNonFuncType a, witnessKnownNonFuncType b) of+    ( KnownNonFuncTypeWitness (Proxy :: Proxy a),+      KnownNonFuncTypeWitness (Proxy :: Proxy b)+      ) -> KnownTypeWitness (Proxy @(a =-> b))+witnessKnownType (TabularFunType [a, b, c]) =+  case ( witnessKnownNonFuncType a,+         witnessKnownNonFuncType b,+         witnessKnownNonFuncType c+       ) of+    ( KnownNonFuncTypeWitness (Proxy :: Proxy a),+      KnownNonFuncTypeWitness (Proxy :: Proxy b),+      KnownNonFuncTypeWitness (Proxy :: Proxy c)+      ) -> KnownTypeWitness (Proxy @(a =-> b =-> c))+witnessKnownType (TabularFunType [a, b, c, d]) =+  case ( witnessKnownNonFuncType a,+         witnessKnownNonFuncType b,+         witnessKnownNonFuncType c,+         witnessKnownNonFuncType d+       ) of+    ( KnownNonFuncTypeWitness (Proxy :: Proxy a),+      KnownNonFuncTypeWitness (Proxy :: Proxy b),+      KnownNonFuncTypeWitness (Proxy :: Proxy c),+      KnownNonFuncTypeWitness (Proxy :: Proxy d)+      ) -> KnownTypeWitness (Proxy @(a =-> b =-> c =-> d))+witnessKnownType (TabularFunType [a, b, c, d, e]) =+  case ( witnessKnownNonFuncType a,+         witnessKnownNonFuncType b,+         witnessKnownNonFuncType c,+         witnessKnownNonFuncType d,+         witnessKnownNonFuncType e+       ) of+    ( KnownNonFuncTypeWitness (Proxy :: Proxy a),+      KnownNonFuncTypeWitness (Proxy :: Proxy b),+      KnownNonFuncTypeWitness (Proxy :: Proxy c),+      KnownNonFuncTypeWitness (Proxy :: Proxy d),+      KnownNonFuncTypeWitness (Proxy :: Proxy e)+      ) -> KnownTypeWitness (Proxy @(a =-> b =-> c =-> d =-> e))+witnessKnownType (TabularFunType [a, b, c, d, e, f]) =+  case ( witnessKnownNonFuncType a,+         witnessKnownNonFuncType b,+         witnessKnownNonFuncType c,+         witnessKnownNonFuncType d,+         witnessKnownNonFuncType e,+         witnessKnownNonFuncType f+       ) of+    ( KnownNonFuncTypeWitness (Proxy :: Proxy a),+      KnownNonFuncTypeWitness (Proxy :: Proxy b),+      KnownNonFuncTypeWitness (Proxy :: Proxy c),+      KnownNonFuncTypeWitness (Proxy :: Proxy d),+      KnownNonFuncTypeWitness (Proxy :: Proxy e),+      KnownNonFuncTypeWitness (Proxy :: Proxy f)+      ) -> KnownTypeWitness (Proxy @(a =-> b =-> c =-> d =-> e =-> f))+witnessKnownType (TabularFunType [a, b, c, d, e, f, g]) =+  case ( witnessKnownNonFuncType a,+         witnessKnownNonFuncType b,+         witnessKnownNonFuncType c,+         witnessKnownNonFuncType d,+         witnessKnownNonFuncType e,+         witnessKnownNonFuncType f,+         witnessKnownNonFuncType g+       ) of+    ( KnownNonFuncTypeWitness (Proxy :: Proxy a),+      KnownNonFuncTypeWitness (Proxy :: Proxy b),+      KnownNonFuncTypeWitness (Proxy :: Proxy c),+      KnownNonFuncTypeWitness (Proxy :: Proxy d),+      KnownNonFuncTypeWitness (Proxy :: Proxy e),+      KnownNonFuncTypeWitness (Proxy :: Proxy f),+      KnownNonFuncTypeWitness (Proxy :: Proxy g)+      ) -> KnownTypeWitness (Proxy @(a =-> b =-> c =-> d =-> e =-> f =-> g))+witnessKnownType (TabularFunType [a, b, c, d, e, f, g, h]) =+  case ( witnessKnownNonFuncType a,+         witnessKnownNonFuncType b,+         witnessKnownNonFuncType c,+         witnessKnownNonFuncType d,+         witnessKnownNonFuncType e,+         witnessKnownNonFuncType f,+         witnessKnownNonFuncType g,+         witnessKnownNonFuncType h+       ) of+    ( KnownNonFuncTypeWitness (Proxy :: Proxy a),+      KnownNonFuncTypeWitness (Proxy :: Proxy b),+      KnownNonFuncTypeWitness (Proxy :: Proxy c),+      KnownNonFuncTypeWitness (Proxy :: Proxy d),+      KnownNonFuncTypeWitness (Proxy :: Proxy e),+      KnownNonFuncTypeWitness (Proxy :: Proxy f),+      KnownNonFuncTypeWitness (Proxy :: Proxy g),+      KnownNonFuncTypeWitness (Proxy :: Proxy h)+      ) ->+        KnownTypeWitness (Proxy @(a =-> b =-> c =-> d =-> e =-> f =-> g =-> h))+witnessKnownType (GeneralFunType [a, b]) =+  case (witnessKnownNonFuncType a, witnessKnownNonFuncType b) of+    ( KnownNonFuncTypeWitness (Proxy :: Proxy a),+      KnownNonFuncTypeWitness (Proxy :: Proxy b)+      ) -> KnownTypeWitness (Proxy @(a --> b))+witnessKnownType (GeneralFunType [a, b, c]) =+  case ( witnessKnownNonFuncType a,+         witnessKnownNonFuncType b,+         witnessKnownNonFuncType c+       ) of+    ( KnownNonFuncTypeWitness (Proxy :: Proxy a),+      KnownNonFuncTypeWitness (Proxy :: Proxy b),+      KnownNonFuncTypeWitness (Proxy :: Proxy c)+      ) -> KnownTypeWitness (Proxy @(a --> b --> c))+witnessKnownType (GeneralFunType [a, b, c, d]) =+  case ( witnessKnownNonFuncType a,+         witnessKnownNonFuncType b,+         witnessKnownNonFuncType c,+         witnessKnownNonFuncType d+       ) of+    ( KnownNonFuncTypeWitness (Proxy :: Proxy a),+      KnownNonFuncTypeWitness (Proxy :: Proxy b),+      KnownNonFuncTypeWitness (Proxy :: Proxy c),+      KnownNonFuncTypeWitness (Proxy :: Proxy d)+      ) -> KnownTypeWitness (Proxy @(a --> b --> c --> d))+witnessKnownType (GeneralFunType [a, b, c, d, e]) =+  case ( witnessKnownNonFuncType a,+         witnessKnownNonFuncType b,+         witnessKnownNonFuncType c,+         witnessKnownNonFuncType d,+         witnessKnownNonFuncType e+       ) of+    ( KnownNonFuncTypeWitness (Proxy :: Proxy a),+      KnownNonFuncTypeWitness (Proxy :: Proxy b),+      KnownNonFuncTypeWitness (Proxy :: Proxy c),+      KnownNonFuncTypeWitness (Proxy :: Proxy d),+      KnownNonFuncTypeWitness (Proxy :: Proxy e)+      ) -> KnownTypeWitness (Proxy @(a --> b --> c --> d --> e))+witnessKnownType (GeneralFunType [a, b, c, d, e, f]) =+  case ( witnessKnownNonFuncType a,+         witnessKnownNonFuncType b,+         witnessKnownNonFuncType c,+         witnessKnownNonFuncType d,+         witnessKnownNonFuncType e,+         witnessKnownNonFuncType f+       ) of+    ( KnownNonFuncTypeWitness (Proxy :: Proxy a),+      KnownNonFuncTypeWitness (Proxy :: Proxy b),+      KnownNonFuncTypeWitness (Proxy :: Proxy c),+      KnownNonFuncTypeWitness (Proxy :: Proxy d),+      KnownNonFuncTypeWitness (Proxy :: Proxy e),+      KnownNonFuncTypeWitness (Proxy :: Proxy f)+      ) -> KnownTypeWitness (Proxy @(a --> b --> c --> d --> e --> f))+witnessKnownType (GeneralFunType [a, b, c, d, e, f, g]) =+  case ( witnessKnownNonFuncType a,+         witnessKnownNonFuncType b,+         witnessKnownNonFuncType c,+         witnessKnownNonFuncType d,+         witnessKnownNonFuncType e,+         witnessKnownNonFuncType f,+         witnessKnownNonFuncType g+       ) of+    ( KnownNonFuncTypeWitness (Proxy :: Proxy a),+      KnownNonFuncTypeWitness (Proxy :: Proxy b),+      KnownNonFuncTypeWitness (Proxy :: Proxy c),+      KnownNonFuncTypeWitness (Proxy :: Proxy d),+      KnownNonFuncTypeWitness (Proxy :: Proxy e),+      KnownNonFuncTypeWitness (Proxy :: Proxy f),+      KnownNonFuncTypeWitness (Proxy :: Proxy g)+      ) -> KnownTypeWitness (Proxy @(a --> b --> c --> d --> e --> f --> g))+witnessKnownType (GeneralFunType [a, b, c, d, e, f, g, h]) =+  case ( witnessKnownNonFuncType a,+         witnessKnownNonFuncType b,+         witnessKnownNonFuncType c,+         witnessKnownNonFuncType d,+         witnessKnownNonFuncType e,+         witnessKnownNonFuncType f,+         witnessKnownNonFuncType g,+         witnessKnownNonFuncType h+       ) of+    ( KnownNonFuncTypeWitness (Proxy :: Proxy a),+      KnownNonFuncTypeWitness (Proxy :: Proxy b),+      KnownNonFuncTypeWitness (Proxy :: Proxy c),+      KnownNonFuncTypeWitness (Proxy :: Proxy d),+      KnownNonFuncTypeWitness (Proxy :: Proxy e),+      KnownNonFuncTypeWitness (Proxy :: Proxy f),+      KnownNonFuncTypeWitness (Proxy :: Proxy g),+      KnownNonFuncTypeWitness (Proxy :: Proxy h)+      ) ->+        KnownTypeWitness (Proxy @(a --> b --> c --> d --> e --> f --> g --> h))+witnessKnownType l = error $ "witnessKnownType: unsupported type: " <> show l++instance Show KnownNonFuncType where+  show BoolType = "Bool"+  show IntegerType = "Integer"+  show (WordNType (_ :: p n)) = "WordN " <> show (natVal (Proxy @n))+  show (IntNType (_ :: p n)) = "IntN " <> show (natVal (Proxy @n))+  show (FPType (_ :: p eb) (_ :: q sb)) =+    "FP "+      <> show (natVal (Proxy @eb))+      <> " "+      <> show (natVal (Proxy @sb))+  show FPRoundingModeType = "FPRoundingMode"+  show AlgRealType = "AlgReal"++instance Show KnownType where+  show (NonFuncType t) = show t+  show (TabularFunType ts) = intercalate " =-> " $ show <$> ts+  show (GeneralFunType ts) = intercalate " --> " $ show <$> ts++knownNonFuncType ::+  forall a p. (SupportedNonFuncPrim a) => p a -> KnownNonFuncType+knownNonFuncType _ =+  case tr of+    _ | SomeTypeRep tr == someTypeRep (Proxy @Bool) -> BoolType+    _ | SomeTypeRep tr == someTypeRep (Proxy @Integer) -> IntegerType+    _+      | SomeTypeRep tr == someTypeRep (Proxy @FPRoundingMode) ->+          FPRoundingModeType+    _ | SomeTypeRep tr == someTypeRep (Proxy @AlgReal) -> AlgRealType+    App (ta@(Con _) :: TypeRep w) (_ :: TypeRep n) ->+      case ( eqTypeRep ta (typeRep @WordN),+             eqTypeRep ta (typeRep @IntN)+           ) of+        (Just HRefl, _) -> withPrim @a $ WordNType (Proxy @n)+        (_, Just HRefl) -> withPrim @a $ IntNType (Proxy @n)+        _ -> err+    App (App (tf :: TypeRep f) (_ :: TypeRep a0)) (_ :: TypeRep a1) ->+      case eqTypeRep tf (typeRep @FP) of+        Just HRefl -> withPrim @a $ FPType (Proxy @a0) (Proxy @a1)+        _ -> err+    _ -> err+  where+    tr = primTypeRep @a+    err = error $ "knownNonFuncType: unsupported type: " <> show tr++knownType ::+  forall a p. (SupportedPrim a) => p a -> KnownType+knownType _ =+  case tr of+    _ | SomeTypeRep tr == someTypeRep (Proxy @Bool) -> NonFuncType BoolType+    _+      | SomeTypeRep tr == someTypeRep (Proxy @Integer) ->+          NonFuncType IntegerType+    _+      | SomeTypeRep tr == someTypeRep (Proxy @FPRoundingMode) ->+          NonFuncType FPRoundingModeType+    _+      | SomeTypeRep tr == someTypeRep (Proxy @AlgReal) ->+          NonFuncType AlgRealType+    App (ta@(Con _) :: TypeRep w) (_ :: TypeRep n) ->+      case ( eqTypeRep ta (typeRep @WordN),+             eqTypeRep ta (typeRep @IntN)+           ) of+        (Just HRefl, _) -> withPrim @a $ NonFuncType $ WordNType (Proxy @n)+        (_, Just HRefl) -> withPrim @a $ NonFuncType $ IntNType (Proxy @n)+        _ -> err+    App (App (tf :: TypeRep f) (_ :: TypeRep a0)) (_ :: TypeRep a1) ->+      case ( eqTypeRep tf (typeRep @FP),+             eqTypeRep tf (typeRep @(=->)),+             eqTypeRep tf (typeRep @(-->))+           ) of+        (Just HRefl, _, _) ->+          withPrim @a $ NonFuncType $ FPType (Proxy @a0) (Proxy @a1)+        (_, Just HRefl, _) ->+          withPrim @a $+            let arg = knownType (Proxy @a0)+                ret = knownType (Proxy @a1)+             in case arg of+                  NonFuncType n -> case ret of+                    NonFuncType m -> TabularFunType [n, m]+                    TabularFunType ns -> TabularFunType (n : ns)+                    _ -> err+                  _ -> err+        (_, _, Just HRefl) ->+          withPrim @a $+            let arg = knownType (Proxy @a0)+                ret = knownType (Proxy @a1)+             in case arg of+                  NonFuncType n -> case ret of+                    NonFuncType m -> GeneralFunType [n, m]+                    GeneralFunType ns -> GeneralFunType (n : ns)+                    _ -> err+                  _ -> err+        _ -> err+    _ -> err+  where+    tr = primTypeRep @a+    err = error $ "knownType: unsupported type: " <> show tr++-- Bool: 0+-- Integer: 1+-- WordN: 2+-- IntN: 3+-- FP: 4+-- FPRoundingMode: 5+-- AlgReal: 6+serializeKnownNonFuncType :: (MonadPut m) => KnownNonFuncType -> m ()+serializeKnownNonFuncType BoolType = putWord8 0+serializeKnownNonFuncType IntegerType = putWord8 1+serializeKnownNonFuncType (WordNType (Proxy :: Proxy n)) =+  putWord8 2 >> serialize (natVal (Proxy @n))+serializeKnownNonFuncType (IntNType (Proxy :: Proxy n)) =+  putWord8 3 >> serialize (natVal (Proxy @n))+serializeKnownNonFuncType (FPType (Proxy :: Proxy eb) (Proxy :: Proxy sb)) =+  putWord8 4 >> serialize (natVal (Proxy @eb)) >> serialize (natVal (Proxy @sb))+serializeKnownNonFuncType FPRoundingModeType = putWord8 5+serializeKnownNonFuncType AlgRealType = putWord8 6++serializeKnownType :: (MonadPut m) => KnownType -> m ()+serializeKnownType (NonFuncType t) = putWord8 0 >> serializeKnownNonFuncType t+serializeKnownType (TabularFunType ts) =+  putWord8 1+    >> putWord8 (fromIntegral $ length ts)+    >> traverse_ serializeKnownNonFuncType ts+serializeKnownType (GeneralFunType ts) =+  putWord8 2+    >> putWord8 (fromIntegral $ length ts)+    >> traverse_ serializeKnownNonFuncType ts++deserializeKnownNonFuncType :: (MonadGet m) => m KnownNonFuncType+deserializeKnownNonFuncType = do+  tag <- getWord8+  case tag of+    0 -> return BoolType+    1 -> return IntegerType+    2 -> do+      n <- deserialize @Natural+      when (n == 0) $ fail "deserializeKnownNonFuncType: WordN 0 is not allowed"+      case mkPositiveNatRepr n of+        SomePositiveNatRepr (_ :: NatRepr n) -> return $ WordNType (Proxy @n)+    3 -> do+      n <- deserialize @Natural+      when (n == 0) $ fail "deserializeKnownNonFuncType: IntN 0 is not allowed"+      case mkPositiveNatRepr n of+        SomePositiveNatRepr (_ :: NatRepr n) -> return $ IntNType (Proxy @n)+    4 -> do+      eb <- deserialize @Natural+      sb <- deserialize @Natural+      unless (checkDynamicValidFP eb sb) $ fail invalidFPMessage+      case (mkPositiveNatRepr eb, mkPositiveNatRepr sb) of+        ( SomePositiveNatRepr (_ :: NatRepr eb),+          SomePositiveNatRepr (_ :: NatRepr sb)+          ) ->+            withUnsafeValidFP @eb @sb $ return $ FPType (Proxy @eb) (Proxy @sb)+    5 -> return FPRoundingModeType+    6 -> return AlgRealType+    _ -> fail "deserializeKnownNonFuncType: Unknown type tag"++deserializeKnownType :: (MonadGet m) => m KnownType+deserializeKnownType = do+  tag <- getWord8+  case tag of+    0 -> NonFuncType <$> deserializeKnownNonFuncType+    1 -> do+      n <- getWord8+      nfs <- replicateM (fromIntegral n) deserializeKnownNonFuncType+      return $ TabularFunType nfs+    2 -> do+      n <- getWord8+      nfs <- replicateM (fromIntegral n) deserializeKnownNonFuncType+      return $ GeneralFunType nfs+    _ -> fail "deserializeKnownType: Unknown type tag"++instance Serial KnownType where+  serialize = serializeKnownType+  deserialize = deserializeKnownType++instance Cereal.Serialize KnownType where+  put = serialize+  get = deserialize++instance Binary.Binary KnownType where+  put = serialize+  get = deserialize++instance Serial KnownNonFuncType where+  serialize = serializeKnownNonFuncType+  deserialize = deserializeKnownNonFuncType++instance Cereal.Serialize KnownNonFuncType where+  put = serialize+  get = deserialize++instance Binary.Binary KnownNonFuncType where+  put = serialize+  get = deserialize++instance (IsSymbolKind knd) => Serial (SomeTypedSymbol knd) where+  serialize (SomeTypedSymbol tsb@(TypedSymbol sb)) =+    case decideSymbolKind @knd of+      Left HRefl -> do+        serializeKnownNonFuncType $ knownNonFuncType tsb+        serialize sb+      Right HRefl -> do+        serializeKnownType $ knownType tsb+        serialize sb+  deserialize = case decideSymbolKind @knd of+    Left HRefl -> do+      kt <- deserializeKnownNonFuncType+      case witnessKnownNonFuncType kt of+        KnownNonFuncTypeWitness (Proxy :: Proxy a) -> do+          sb <- deserialize+          return $ SomeTypedSymbol $ TypedSymbol @a sb+    Right HRefl -> do+      kt <- deserializeKnownType+      case witnessKnownType kt of+        KnownTypeWitness (Proxy :: Proxy a) -> do+          sb <- deserialize+          return $ SomeTypedSymbol $ TypedSymbol @a sb++instance (IsSymbolKind knd) => Cereal.Serialize (SomeTypedSymbol knd) where+  put = serialize+  get = deserialize++instance (IsSymbolKind knd) => Binary.Binary (SomeTypedSymbol knd) where+  put = serialize+  get = deserialize++instance (IsSymbolKind knd, Typeable a) => Serial (TypedSymbol knd a) where+  serialize tsb = serialize $ someTypedSymbol tsb+  deserialize = do+    SomeTypedSymbol (tsb@TypedSymbol {} :: TypedSymbol knd b) <- deserialize+    case eqTypeRep (typeRep @a) (primTypeRep @b) of+      Just HRefl -> return tsb+      Nothing -> fail "deserialize TypedSymbol: type mismatch"++instance+  (IsSymbolKind knd, Typeable a) =>+  Cereal.Serialize (TypedSymbol knd a)+  where+  put = serialize+  get = deserialize++instance+  (IsSymbolKind knd, Typeable a) =>+  Binary.Binary (TypedSymbol knd a)+  where+  put = serialize+  get = deserialize++conTermTag :: Word8+conTermTag = 0++symTermTag :: Word8+symTermTag = 1++forallTermTag :: Word8+forallTermTag = 2++existsTermTag :: Word8+existsTermTag = 3++notTermTag :: Word8+notTermTag = 4++orTermTag :: Word8+orTermTag = 5++andTermTag :: Word8+andTermTag = 6++eqTermTag :: Word8+eqTermTag = 7++distinctTermTag :: Word8+distinctTermTag = 8++iteTermTag :: Word8+iteTermTag = 9++addNumTermTag :: Word8+addNumTermTag = 10++negNumTermTag :: Word8+negNumTermTag = 11++mulNumTermTag :: Word8+mulNumTermTag = 12++absNumTermTag :: Word8+absNumTermTag = 13++signumNumTermTag :: Word8+signumNumTermTag = 14++ltOrdTermTag :: Word8+ltOrdTermTag = 15++leOrdTermTag :: Word8+leOrdTermTag = 16++andBitsTermTag :: Word8+andBitsTermTag = 17++orBitsTermTag :: Word8+orBitsTermTag = 18++xorBitsTermTag :: Word8+xorBitsTermTag = 19++complementBitsTermTag :: Word8+complementBitsTermTag = 20++shiftLeftTermTag :: Word8+shiftLeftTermTag = 21++shiftRightTermTag :: Word8+shiftRightTermTag = 22++rotateLeftTermTag :: Word8+rotateLeftTermTag = 23++rotateRightTermTag :: Word8+rotateRightTermTag = 24++bitCastTermTag :: Word8+bitCastTermTag = 25++bitCastOrTermTag :: Word8+bitCastOrTermTag = 26++bvConcatTermTag :: Word8+bvConcatTermTag = 27++bvSelectTermTag :: Word8+bvSelectTermTag = 28++bvExtendTermTag :: Word8+bvExtendTermTag = 29++applyTermTag :: Word8+applyTermTag = 30++divIntegralTermTag :: Word8+divIntegralTermTag = 31++modIntegralTermTag :: Word8+modIntegralTermTag = 32++quotIntegralTermTag :: Word8+quotIntegralTermTag = 33++remIntegralTermTag :: Word8+remIntegralTermTag = 34++fpTraitTermTag :: Word8+fpTraitTermTag = 35++fdivTermTag :: Word8+fdivTermTag = 36++recipTermTag :: Word8+recipTermTag = 37++floatingUnaryTermTag :: Word8+floatingUnaryTermTag = 38++powerTermTag :: Word8+powerTermTag = 39++fpUnaryTermTag :: Word8+fpUnaryTermTag = 40++fpBinaryTermTag :: Word8+fpBinaryTermTag = 41++fpRoundingUnaryTermTag :: Word8+fpRoundingUnaryTermTag = 42++fpRoundingBinaryTermTag :: Word8+fpRoundingBinaryTermTag = 43++fpFMATermTag :: Word8+fpFMATermTag = 44++fromIntegralTermTag :: Word8+fromIntegralTermTag = 45++fromFPOrTermTag :: Word8+fromFPOrTermTag = 46++toFPTermTag :: Word8+toFPTermTag = 47++terminalTag :: Word8+terminalTag = 255++asBoolTerm :: (HasCallStack) => SomeTerm -> Term Bool+asBoolTerm (SomeTerm (t :: Term a)) =+  case eqTypeRep (primTypeRep @Bool) (primTypeRep @a) of+    Just HRefl -> t+    Nothing -> error "asBoolTerm: type mismatch"++asSameTypeNonEmptyTermList ::+  (HasCallStack) =>+  NonEmpty SomeTerm ->+  (forall b. NonEmpty (Term b) -> r) ->+  r+asSameTypeNonEmptyTermList (SomeTerm (t :: Term a) :| ts) f =+  f $ t :| fmap (unsafeCastTerm t) ts+  where+    unsafeCastTerm :: Term a -> SomeTerm -> Term a+    unsafeCastTerm t (SomeTerm b) =+      introSupportedPrimConstraint t $+        case castTerm b of+          Just r -> r+          Nothing -> error "asSameTypeNonEmptyTermList: type mismatch"++asNumTypeTerm ::+  (HasCallStack) =>+  SomeTerm ->+  (forall n. (PEvalNumTerm n, PEvalIEEEFPConvertibleTerm n) => Term n -> r) ->+  r+asNumTypeTerm (SomeTerm (t1 :: Term a)) f =+  case ( eqTypeRep ta (typeRep @Integer),+         eqTypeRep ta (typeRep @AlgReal)+       ) of+    (Just HRefl, _) -> f t1+    (_, Just HRefl) -> f t1+    _ ->+      case ta of+        App (ta@(Con _) :: TypeRep w) (_ :: TypeRep n) ->+          case ( eqTypeRep ta (typeRep @WordN),+                 eqTypeRep ta (typeRep @IntN)+               ) of+            (Just HRefl, _) -> withPrim @a $ f t1+            (_, Just HRefl) -> withPrim @a $ f t1+            _ -> err+        App (App (tf :: TypeRep f) (_ :: TypeRep a0)) (_ :: TypeRep a1) ->+          case eqTypeRep tf (typeRep @FP) of+            Just HRefl ->+              withPrim @a $ withPrim @a $ f t1+            _ -> err+        _ -> err+  where+    ta = primTypeRep @a+    err = error $ "asNumTypeTerm: unsupported type: " <> show ta++asOrdTypeTerm ::+  (HasCallStack) => SomeTerm -> (forall n. (PEvalOrdTerm n) => Term n -> r) -> r+asOrdTypeTerm (SomeTerm (t1 :: Term a)) f =+  case ( eqTypeRep ta (typeRep @Integer),+         eqTypeRep ta (typeRep @AlgReal),+         eqTypeRep ta (typeRep @FPRoundingMode)+       ) of+    (Just HRefl, _, _) -> f t1+    (_, Just HRefl, _) -> f t1+    (_, _, Just HRefl) -> f t1+    _ ->+      case ta of+        App (ta@(Con _) :: TypeRep w) (_ :: TypeRep n) ->+          case ( eqTypeRep ta (typeRep @WordN),+                 eqTypeRep ta (typeRep @IntN)+               ) of+            (Just HRefl, _) -> withPrim @a $ f t1+            (_, Just HRefl) -> withPrim @a $ f t1+            _ -> err+        App (App (tf :: TypeRep f) (_ :: TypeRep a0)) (_ :: TypeRep a1) ->+          case eqTypeRep tf (typeRep @FP) of+            Just HRefl ->+              withPrim @a $ withPrim @a $ f t1+            _ -> err+        _ -> err+  where+    ta = primTypeRep @a+    err = error $ "asOrdTypeTerm: unsupported type: " <> show ta++asBitsTypeTerm ::+  (HasCallStack) =>+  SomeTerm ->+  ( forall n.+    (PEvalBitwiseTerm n, PEvalShiftTerm n, PEvalRotateTerm n) =>+    Term n ->+    r+  ) ->+  r+asBitsTypeTerm (SomeTerm (t1 :: Term a)) f =+  case ta of+    App (ta@(Con _) :: TypeRep w) (_ :: TypeRep n) ->+      case ( eqTypeRep ta (typeRep @WordN),+             eqTypeRep ta (typeRep @IntN)+           ) of+        (Just HRefl, _) -> withPrim @a $ f t1+        (_, Just HRefl) -> withPrim @a $ f t1+        _ -> err+    _ -> err+  where+    ta = primTypeRep @a+    err = error $ "asBitsTypeTerm: unsupported type: " <> show ta++asIntegralTypeTerm ::+  (HasCallStack) =>+  SomeTerm ->+  (forall n. (PEvalDivModIntegralTerm n) => Term n -> r) ->+  r+asIntegralTypeTerm (SomeTerm (t1 :: Term a)) f =+  case eqTypeRep ta (typeRep @Integer) of+    Just HRefl -> f t1+    _ -> case ta of+      App (ta@(Con _) :: TypeRep w) (_ :: TypeRep n) ->+        case (eqTypeRep ta (typeRep @WordN), eqTypeRep ta (typeRep @IntN)) of+          (Just HRefl, _) -> withPrim @a $ f t1+          (_, Just HRefl) -> withPrim @a $ f t1+          _ -> err+      _ -> err+  where+    ta = primTypeRep @a+    err = error $ "asOrdTypeTerm: unsupported type: " <> show ta++asFloatingFractionalTypeTerm ::+  (HasCallStack) =>+  SomeTerm ->+  (forall n. (PEvalFloatingTerm n, PEvalFractionalTerm n) => Term n -> r) ->+  r+asFloatingFractionalTypeTerm (SomeTerm (t1 :: Term a)) f =+  case eqTypeRep ta (typeRep @AlgReal) of+    Just HRefl -> f t1+    _ -> case ta of+      App (App (tf :: TypeRep f) (_ :: TypeRep a0)) (_ :: TypeRep a1) ->+        case eqTypeRep tf (typeRep @FP) of+          Just HRefl -> withPrim @a $ f t1+          _ -> err+      _ -> err+  where+    ta = primTypeRep @a+    err = error $ "asFloatingFractionalTypeTerm: unsupported type: " <> show ta++asFPTypeTerm ::+  (HasCallStack) =>+  SomeTerm ->+  (forall eb sb. (ValidFP eb sb) => Term (FP eb sb) -> r) ->+  r+asFPTypeTerm (SomeTerm (t1 :: Term a)) f =+  case ta of+    App (App (tf :: TypeRep f) (_ :: TypeRep a0)) (_ :: TypeRep a1) ->+      case eqTypeRep tf (typeRep @FP) of+        Just HRefl -> withPrim @a $ f t1+        _ -> err+    _ -> err+  where+    ta = primTypeRep @a+    err = error $ "asFPTypeTerm: unsupported type: " <> show ta++asSameType ::+  (HasCallStack) => Term a -> SomeTerm -> (Term a -> r) -> r+asSameType (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"++asFPRoundingTerm ::+  (HasCallStack) => SomeTerm -> (Term FPRoundingMode -> r) -> r+asFPRoundingTerm (SomeTerm (t1 :: Term a)) f =+  case eqTypeRep ta (typeRep @FPRoundingMode) of+    Just HRefl -> f t1+    _ -> err+  where+    ta = primTypeRep @a+    err = error $ "asFPRoundingTerm: unsupported type: " <> show ta++constructBitCastOrTerm :: (HasCallStack) => SomeTerm -> SomeTerm -> SomeTerm+constructBitCastOrTerm (SomeTerm (td :: Term d)) (SomeTerm (tv :: Term v)) =+  withPrim @d $+    withPrim @v $+      case (trv, trd) of+        ( App+            (App (trfp@(Con _) :: TypeRep fp) (treb :: TypeRep eb))+            (trsb :: TypeRep sb),+          App (trbv@(Con _) :: TypeRep bv) (trn :: TypeRep n)+          ) ->+            case ( eqTypeRep trfp (typeRep @FP),+                   eqTypeRep trbv (typeRep @WordN),+                   eqTypeRep trbv (typeRep @IntN)+                 ) of+              (Just HRefl, Just HRefl, _) ->+                if natVal treb + natVal trsb == natVal trn+                  then case unsafeAxiom @n @(eb + sb) of+                    Refl -> someTerm (bitCastOrTerm td tv :: Term d)+                  else err+              (Just HRefl, _, Just HRefl) ->+                if natVal treb + natVal trsb == natVal trn+                  then case unsafeAxiom @n @(eb + sb) of+                    Refl -> someTerm (bitCastOrTerm td tv :: Term d)+                  else err+              _ -> err+        _ -> err+  where+    trd = primTypeRep @d+    trv = primTypeRep @v+    err :: r+    err =+      error $+        "constructBitCastOrTerm: unsupported type: " <> show trd <> show trv++constructBitCastTerm :: (HasCallStack) => SomeTerm -> KnownType -> SomeTerm+constructBitCastTerm (SomeTerm (t1 :: Term a)) retType =+  case witnessKnownType retType of+    KnownTypeWitness (_ :: Proxy b) -> do+      let tb = primTypeRep @b+      withPrim @a $ withPrim @b $ case (eqTypeRep ta (typeRep @Bool), ta) of+        (Just HRefl, _) -> case tb of+          App (tw@(Con _) :: TypeRep w) (tn :: TypeRep n) ->+            case ( eqTypeRep tw (typeRep @WordN),+                   eqTypeRep tw (typeRep @IntN),+                   eqTypeRep tn (typeRep @1)+                 ) of+              (Just HRefl, _, Just HRefl) -> someTerm (bitCastTerm t1 :: Term b)+              (_, Just HRefl, Just HRefl) -> someTerm (bitCastTerm t1 :: Term b)+              _ -> err+          _ -> err+        (_, App (tw@(Con _) :: TypeRep w) (tn :: TypeRep n)) ->+          case (eqTypeRep tw (typeRep @WordN), eqTypeRep tw (typeRep @IntN)) of+            (Just HRefl, _) -> fromBV t1 tn tb (typeRep @IntN)+            (_, Just HRefl) -> fromBV t1 tn tb (typeRep @WordN)+            _ -> err+        _ -> err+  where+    ta = primTypeRep @a+    err :: r+    err =+      error $+        "constructBitCastTerm: unsupported type: "+          <> show ta+          <> show retType+    fromBV ::+      forall bv n b bv2.+      ( forall n. (KnownNat n, 1 <= n) => PEvalBitCastTerm (bv n) (bv2 n),+        PEvalBitCastTerm (bv 1) Bool,+        forall n eb sb.+        (KnownNat n, 1 <= n, ValidFP eb sb, (eb + sb) ~ n) =>+        PEvalBitCastTerm (bv n) (FP eb sb),+        KnownNat n,+        1 <= n,+        SupportedPrim b,+        forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv2 n)+      ) =>+      Term (bv n) ->+      TypeRep n ->+      TypeRep b ->+      TypeRep bv2 ->+      SomeTerm+    fromBV t1 tn tb tbv2 =+      case (eqTypeRep tn (typeRep @1), eqTypeRep tb (typeRep @Bool)) of+        (Just HRefl, Just HRefl) -> someTerm (bitCastTerm t1 :: Term b)+        _ -> case tb of+          (App (tw'@(Con _) :: TypeRep w') (tn' :: TypeRep n')) ->+            case ( eqTypeRep tw' tbv2,+                   eqTypeRep tn tn'+                 ) of+              (Just HRefl, Just HRefl) ->+                someTerm (bitCastTerm t1 :: Term b)+              _ -> err+          ( App+              (App (tw' :: TypeRep f) (teb :: TypeRep eb))+              (tsb :: TypeRep sb)+            ) ->+              withPrim @b $+                case (eqTypeRep tw' (typeRep @FP)) of+                  Just HRefl ->+                    if natVal teb + natVal tsb == natVal tn+                      then case unsafeAxiom @n @(eb + sb) of+                        Refl -> someTerm (bitCastTerm t1 :: Term b)+                      else err+                  _ -> err+          _ -> err++constructBVConcatTerm :: (HasCallStack) => SomeTerm -> SomeTerm -> SomeTerm+constructBVConcatTerm (SomeTerm (ta :: Term a)) (SomeTerm (tb :: Term b)) =+  withPrim @a $+    withPrim @b $+      case (tra, trb) of+        ( App (trbv0@(Con _) :: TypeRep bv0) (trn0 :: TypeRep n0),+          App (trbv1@(Con _) :: TypeRep bv1) (trn1 :: TypeRep n1)+          ) ->+            case ( eqTypeRep trbv0 trbv1,+                   eqTypeRep trbv0 (typeRep @WordN),+                   eqTypeRep trbv0 (typeRep @IntN)+                 ) of+              (Just HRefl, Just HRefl, _) ->+                case ( unsafeLeqProof @1 @(n0 + n1),+                       unsafeKnownProof @(n0 + n1) (natVal trn0 + natVal trn1)+                     ) of+                  (LeqProof, KnownProof) -> someTerm $ bvConcatTerm ta tb+              (Just HRefl, _, Just HRefl) ->+                case ( unsafeLeqProof @1 @(n0 + n1),+                       unsafeKnownProof @(n0 + n1) (natVal trn0 + natVal trn1)+                     ) of+                  (LeqProof, KnownProof) -> someTerm $ bvConcatTerm ta tb+              _ -> err+        _ -> err+  where+    tra = primTypeRep @a+    trb = primTypeRep @b+    err :: SomeTerm+    err =+      error $+        "constructBVConcatTerm: unsupported type: "+          <> show (primTypeRep @a)++constructBVSelectTerm ::+  (HasCallStack) => Natural -> Natural -> SomeTerm -> SomeTerm+constructBVSelectTerm ix w (SomeTerm (ta :: Term a)) =+  withPrim @a $+    case tra of+      (App (trbv@(Con _) :: TypeRep bv) (trn :: TypeRep n)) ->+        case ( eqTypeRep trbv (typeRep @WordN),+               eqTypeRep trbv (typeRep @IntN)+             ) of+          (Just HRefl, _) -> case (mkNatRepr ix, mkPositiveNatRepr w) of+            ( SomeNatRepr (nix :: NatRepr ix),+              SomePositiveNatRepr (nw :: NatRepr w)+              ) ->+                if ix + w <= natVal trn+                  then case unsafeLeqProof @(ix + w) @n of+                    LeqProof -> someTerm $ bvSelectTerm nix nw ta+                  else err+          (_, Just HRefl) -> case (mkNatRepr ix, mkPositiveNatRepr w) of+            ( SomeNatRepr (nix :: NatRepr ix),+              SomePositiveNatRepr (nw :: NatRepr w)+              ) ->+                if ix + w <= natVal trn+                  then case unsafeLeqProof @(ix + w) @n of+                    LeqProof -> someTerm $ bvSelectTerm nix nw ta+                  else err+          _ -> err+      _ -> err+  where+    tra = primTypeRep @a+    err :: SomeTerm+    err =+      error $+        "constructBVSelectTerm: unsupported type: "+          <> show (primTypeRep @a)++constructBVExtendTerm ::+  (HasCallStack) => Bool -> Natural -> SomeTerm -> SomeTerm+constructBVExtendTerm signed r (SomeTerm (ta :: Term a)) =+  withPrim @a $+    case tra of+      (App (trbv@(Con _) :: TypeRep bv) (trn :: TypeRep n)) ->+        case ( eqTypeRep trbv (typeRep @WordN),+               eqTypeRep trbv (typeRep @IntN)+             ) of+          (Just HRefl, _) -> case (mkPositiveNatRepr r) of+            (SomePositiveNatRepr (nr :: NatRepr r)) ->+              if natVal trn <= r+                then case unsafeLeqProof @n @r of+                  LeqProof -> someTerm $ bvExtendTerm signed nr ta+                else err+          (_, Just HRefl) -> case (mkPositiveNatRepr r) of+            (SomePositiveNatRepr (nr :: NatRepr r)) ->+              if natVal trn <= r+                then case unsafeLeqProof @n @r of+                  LeqProof -> someTerm $ bvExtendTerm signed nr ta+                else err+          _ -> err+      _ -> err+  where+    tra = primTypeRep @a+    err :: SomeTerm+    err =+      error $+        "constructBVExtendTerm: unsupported type: "+          <> show (primTypeRep @a)++constructApplyTerm ::+  (HasCallStack) => SomeTerm -> SomeTerm -> SomeTerm+constructApplyTerm (SomeTerm (tf :: Term f)) (SomeTerm (ta :: Term a)) =+  withPrim @f $+    withPrim @a $+      case trf of+        (App (App (trft :: TypeRep ft) (trarg :: TypeRep arg)) _) ->+          case ( eqTypeRep trft (typeRep @(=->)),+                 eqTypeRep trft (typeRep @(-->))+               ) of+            (Just HRefl, _) -> case eqTypeRep trarg tra of+              Just HRefl -> someTerm $ applyTerm tf ta+              Nothing -> err+            (_, Just HRefl) -> case eqTypeRep trarg tra of+              Just HRefl -> someTerm $ applyTerm tf ta+              Nothing -> err+            _ -> err+        _ -> err+  where+    trf = primTypeRep @f+    tra = primTypeRep @a+    err :: SomeTerm+    err =+      error $+        "constructApplyTerm: unsupported type: " <> show trf <> show tra++constructFromIntegralTerm' ::+  forall a.+  ( HasCallStack,+    PEvalFromIntegralTerm a Integer,+    PEvalFromIntegralTerm a AlgReal,+    forall n. (KnownNat n, 1 <= n) => PEvalFromIntegralTerm a (WordN n),+    forall n. (KnownNat n, 1 <= n) => PEvalFromIntegralTerm a (IntN n),+    forall eb sb. (ValidFP eb sb) => PEvalFromIntegralTerm a (FP eb sb)+  ) =>+  Term a ->+  KnownType ->+  SomeTerm+constructFromIntegralTerm' ta 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+  where+    err :: SomeTerm+    err =+      introSupportedPrimConstraint ta $+        error $+          "constructFromIntegralTerm: unsupported type: "+            <> show (primTypeRep @a)+            <> show retType++constructFromIntegralTerm ::+  (HasCallStack) => SomeTerm -> KnownType -> SomeTerm+constructFromIntegralTerm (SomeTerm (t1 :: Term a)) retType =+  withPrim @a $+    case (eqTypeRep tra (typeRep @Integer), tra) of+      (Just HRefl, _) -> constructFromIntegralTerm' t1 retType+      (_, App (trbv :: TypeRep bv) _) ->+        case ( eqTypeRep trbv (typeRep @WordN),+               eqTypeRep trbv (typeRep @IntN)+             ) of+          (Just HRefl, _) -> constructFromIntegralTerm' t1 retType+          (_, Just HRefl) -> constructFromIntegralTerm' t1 retType+          _ -> err+      _ -> err+  where+    tra = primTypeRep @a+    err :: SomeTerm+    err = error $ "constructFromIntegralTerm: unsupported type: " <> show tra++knownTypeTermId :: Term a -> (KnownType, Id)+knownTypeTermId t = introSupportedPrimConstraint t (knownType t, termId t)++statefulDeserializeSomeTerm ::+  (MonadGet m) =>+  StateT (HM.HashMap (KnownType, Id) SomeTerm, SomeTerm) m SomeTerm+statefulDeserializeSomeTerm = do+  r <- do+    ktTmId <- deserialize+    tag <- getWord8+    if+      | tag == conTermTag -> do+          knownType <- deserializeKnownType+          case witnessKnownType knownType of+            KnownTypeWitness (Proxy :: Proxy a) -> do+              tm <- someTerm . conTerm <$> deserialize @a+              return $ Just (tm, ktTmId)+      | tag == symTermTag -> do+          SomeTypedSymbol sb <- deserialize @SomeTypedAnySymbol+          return $ Just (someTerm $ symTerm sb, ktTmId)+      | tag == forallTermTag -> deserializeQuantified ktTmId forallTerm+      | tag == existsTermTag -> deserializeQuantified ktTmId existsTerm+      | tag == notTermTag -> do+          t <- deserializeTerm+          return $ Just (someTerm $ notTerm $ asBoolTerm t, ktTmId)+      | tag == orTermTag -> deserializeBoolBinary ktTmId orTerm+      | tag == andTermTag -> deserializeBoolBinary ktTmId andTerm+      | tag == eqTermTag -> do+          SomeTerm t1' <- deserializeTerm+          t2 <- deserializeTerm+          asSameType t1' t2 $ \t2' ->+            return $ Just (someTerm $ eqTerm t1' t2', ktTmId)+      | tag == distinctTermTag -> do+          ts <- deserializeNonEmptyTermList+          asSameTypeNonEmptyTermList ts $ \ts' ->+            return $ Just (someTerm $ distinctTerm ts', ktTmId)+      | tag == iteTermTag -> do+          t1 <- deserializeTerm+          SomeTerm t2' <- deserializeTerm+          t3 <- deserializeTerm+          asSameType t2' t3 $ \t3' ->+            return $ Just (someTerm $ iteTerm (asBoolTerm t1) t2' t3', ktTmId)+      | tag == addNumTermTag -> deserializeNumBinary ktTmId addNumTerm+      | tag == negNumTermTag -> deserializeNumUnary ktTmId negNumTerm+      | tag == mulNumTermTag -> deserializeNumBinary ktTmId mulNumTerm+      | tag == absNumTermTag -> deserializeNumUnary ktTmId absNumTerm+      | tag == signumNumTermTag -> deserializeNumUnary ktTmId signumNumTerm+      | tag == ltOrdTermTag -> deserializeOrdBinary ktTmId ltOrdTerm+      | tag == leOrdTermTag -> deserializeOrdBinary ktTmId leOrdTerm+      | tag == andBitsTermTag -> deserializeBitsBinary ktTmId andBitsTerm+      | tag == orBitsTermTag -> deserializeBitsBinary ktTmId orBitsTerm+      | tag == xorBitsTermTag -> deserializeBitsBinary ktTmId xorBitsTerm+      | tag == complementBitsTermTag ->+          deserializeBitsUnary ktTmId complementBitsTerm+      | tag == shiftLeftTermTag -> deserializeBitsBinary ktTmId shiftLeftTerm+      | tag == shiftRightTermTag -> deserializeBitsBinary ktTmId shiftRightTerm+      | tag == rotateLeftTermTag -> deserializeBitsBinary ktTmId rotateLeftTerm+      | tag == rotateRightTermTag -> deserializeBitsBinary ktTmId rotateRightTerm+      | tag == bitCastTermTag -> do+          kt <- deserializeKnownType+          t1 <- deserializeTerm+          return $ Just (constructBitCastTerm t1 kt, ktTmId)+      | tag == bitCastOrTermTag -> do+          td <- deserializeTerm+          tv <- deserializeTerm+          return $ Just (constructBitCastOrTerm td tv, ktTmId)+      | tag == bvConcatTermTag -> do+          t1 <- deserializeTerm+          t2 <- deserializeTerm+          return $ Just (constructBVConcatTerm t1 t2, ktTmId)+      | tag == bvSelectTermTag -> do+          ix <- deserialize @Natural+          w <- deserialize @Natural+          t1 <- deserializeTerm+          return $ Just (constructBVSelectTerm ix w t1, ktTmId)+      | tag == bvExtendTermTag -> do+          signed <- deserialize @Bool+          r <- deserialize @Natural+          t1 <- deserializeTerm+          return $ Just (constructBVExtendTerm signed r t1, ktTmId)+      | tag == applyTermTag -> do+          tf <- deserializeTerm+          ta <- deserializeTerm+          return $ Just (constructApplyTerm tf ta, ktTmId)+      | tag == divIntegralTermTag ->+          deserializeIntegralBinary ktTmId divIntegralTerm+      | tag == modIntegralTermTag ->+          deserializeIntegralBinary ktTmId modIntegralTerm+      | tag == quotIntegralTermTag ->+          deserializeIntegralBinary ktTmId quotIntegralTerm+      | tag == remIntegralTermTag ->+          deserializeIntegralBinary ktTmId remIntegralTerm+      | tag == terminalTag -> return Nothing+      | tag == fpTraitTermTag -> do+          trait <- deserialize @FPTrait+          t <- deserializeTerm+          asFPTypeTerm t $ \t' ->+            return $ Just (someTerm $ fpTraitTerm trait t', ktTmId)+      | tag == fdivTermTag -> do+          t1 <- deserializeTerm+          t2 <- deserializeTerm+          asFloatingFractionalTypeTerm t1 $ \t1' -> asSameType t1' t2 $ \t2' ->+            return $ Just (someTerm $ fdivTerm t1' t2', ktTmId)+      | tag == recipTermTag -> do+          t <- deserializeTerm+          asFloatingFractionalTypeTerm t $ \t' ->+            return $ Just (someTerm $ recipTerm t', ktTmId)+      | tag == floatingUnaryTermTag -> do+          op <- deserialize+          t <- deserializeTerm+          asFloatingFractionalTypeTerm t $ \t' ->+            return $ Just (someTerm $ floatingUnaryTerm op t', ktTmId)+      | tag == powerTermTag -> do+          t1 <- deserializeTerm+          t2 <- deserializeTerm+          asFloatingFractionalTypeTerm t1 $ \t1' -> asSameType t1' t2 $ \t2' ->+            return $ Just (someTerm $ powerTerm t1' t2', ktTmId)+      | tag == fpUnaryTermTag -> do+          op <- deserialize @FPUnaryOp+          t <- deserializeTerm+          asFPTypeTerm t $ \t' ->+            return $ Just (someTerm $ fpUnaryTerm op t', ktTmId)+      | tag == fpBinaryTermTag -> do+          op <- deserialize @FPBinaryOp+          t1 <- deserializeTerm+          t2 <- deserializeTerm+          asFPTypeTerm t1 $ \t1' -> asSameType t1' t2 $ \t2' ->+            return $ Just (someTerm $ fpBinaryTerm op t1' t2', ktTmId)+      | tag == fpRoundingUnaryTermTag -> do+          op <- deserialize @FPRoundingUnaryOp+          trd <- deserializeTerm+          t <- deserializeTerm+          asFPRoundingTerm trd $ \trd' ->+            asFPTypeTerm t $ \t' ->+              return $ Just (someTerm $ fpRoundingUnaryTerm op trd' t', ktTmId)+      | tag == fpRoundingBinaryTermTag -> do+          op <- deserialize @FPRoundingBinaryOp+          trd <- deserializeTerm+          t1 <- deserializeTerm+          t2 <- deserializeTerm+          asFPRoundingTerm trd $ \trd' ->+            asFPTypeTerm t1 $ \t1' -> asSameType t1' t2 $ \t2' ->+              return $+                Just (someTerm $ fpRoundingBinaryTerm op trd' t1' t2', ktTmId)+      | tag == fpFMATermTag -> do+          trd <- deserializeTerm+          t1 <- deserializeTerm+          t2 <- deserializeTerm+          t3 <- deserializeTerm+          asFPRoundingTerm trd $ \trd' -> asFPTypeTerm t1 $ \t1' ->+            asSameType t1' t2 $ \t2' -> asSameType t1' t3 $ \t3' ->+              return $ Just (someTerm $ fpFMATerm trd' t1' t2' t3', ktTmId)+      | tag == fromIntegralTermTag -> do+          kt <- deserializeKnownType+          t <- deserializeTerm+          return $ Just (constructFromIntegralTerm t kt, ktTmId)+      | tag == fromFPOrTermTag -> do+          td <- deserializeTerm+          trd <- deserializeTerm+          tt <- deserializeTerm+          asNumTypeTerm td $ \td' -> asFPRoundingTerm trd $ \trd' ->+            asFPTypeTerm tt $ \tt' ->+              return $ Just (someTerm $ fromFPOrTerm td' trd' tt', ktTmId)+      | tag == toFPTermTag -> do+          eb <- deserialize @Natural+          sb <- deserialize @Natural+          trd <- deserializeTerm+          tt <- deserializeTerm+          if checkDynamicValidFP eb sb+            then case (mkNatRepr eb, mkNatRepr sb) of+              ( SomeNatRepr (_ :: NatRepr eb),+                SomeNatRepr (_ :: NatRepr sb)+                ) ->+                  withUnsafeValidFP @eb @sb $+                    asFPRoundingTerm trd $ \trd' -> asNumTypeTerm tt $ \tt' ->+                      return $+                        Just+                          ( someTerm (toFPTerm trd' tt' :: Term (FP eb sb)),+                            ktTmId+                          )+            else error "statefulDeserializeSomeTerm: invalid FP type"+      | otherwise ->+          error $ "statefulDeserializeSomeTerm: unknown tag: " <> show tag+  case r of+    Just (tm, ktTmId) -> do+      State.modify' $ \(m, _) -> (HM.insert ktTmId tm m, tm)+      statefulDeserializeSomeTerm+    Nothing -> State.gets snd+  where+    deserializeNonEmptyTermList ::+      (MonadGet m) =>+      StateT+        (HM.HashMap (KnownType, Id) SomeTerm, SomeTerm)+        m+        (NonEmpty SomeTerm)+    deserializeNonEmptyTermList = do+      ids <- deserialize @[(KnownType, Id)]+      case ids of+        [] -> fail "statefulDeserializeSomeTerm: empty list"+        (x : xs) -> do+          x' <- queryTerm x+          xs' <- traverse queryTerm xs+          return $ x' :| xs'+    deserializeTerm ::+      (MonadGet m) =>+      StateT (HM.HashMap (KnownType, Id) SomeTerm, SomeTerm) m SomeTerm+    deserializeTerm = do+      ktTmId <- deserialize+      queryTerm ktTmId+    queryTerm ::+      (MonadGet m) =>+      (KnownType, Id) ->+      StateT (HM.HashMap (KnownType, Id) SomeTerm, SomeTerm) m SomeTerm+    queryTerm ktTmId = do+      tm <- State.gets $ HM.lookup ktTmId . fst+      case tm of+        Nothing -> fail "statefulDeserializeSomeTerm: unknown term id"+        Just tm' -> return tm'+    deserializeBoolBinary tmId f = do+      t1 <- deserializeTerm+      t2 <- deserializeTerm+      return $+        Just (someTerm $ f (asBoolTerm t1) (asBoolTerm t2), tmId)+    deserializeQuantified+      tmId+      (f :: forall t. TypedConstantSymbol t -> Term Bool -> Term Bool) = do+        SomeTypedSymbol sb <- deserialize+        t <- deserializeTerm+        return $ Just (someTerm $ f sb $ asBoolTerm t, tmId)+    deserializeNumUnary+      tmId+      (f :: forall t. (PEvalNumTerm t) => Term t -> Term t) = do+        t1 <- deserializeTerm+        asNumTypeTerm t1 $ \t1' -> return $ Just (someTerm $ f t1', tmId)+    deserializeBitsUnary+      tmId+      (f :: forall t. (PEvalBitwiseTerm t) => Term t -> Term t) = do+        t1 <- deserializeTerm+        asBitsTypeTerm t1 $ \t1' -> return $ Just (someTerm $ f t1', tmId)+    deserializeNumBinary+      tmId+      (f :: forall t. (PEvalNumTerm t) => Term t -> Term t -> Term t) = do+        t1 <- deserializeTerm+        t2 <- deserializeTerm+        asNumTypeTerm t1 $ \t1' -> asSameType t1' t2 $ \t2' ->+          return $ Just (someTerm $ f t1' t2', tmId)+    deserializeOrdBinary+      tmId+      (f :: forall t. (PEvalOrdTerm t) => Term t -> Term t -> Term Bool) = do+        t1 <- deserializeTerm+        t2 <- deserializeTerm+        asOrdTypeTerm t1 $ \t1' -> asSameType t1' t2 $ \t2' ->+          return $ Just (someTerm $ f t1' t2', tmId)+    deserializeBitsBinary+      tmId+      ( f ::+          forall t.+          ( PEvalBitwiseTerm t,+            PEvalShiftTerm t,+            PEvalRotateTerm t+          ) =>+          Term t ->+          Term t ->+          Term t+        ) = do+        t1 <- deserializeTerm+        t2 <- deserializeTerm+        asBitsTypeTerm t1 $ \t1' -> asSameType t1' t2 $ \t2' ->+          return $ Just (someTerm $ f t1' t2', tmId)+    deserializeIntegralBinary+      tmId+      ( f ::+          forall t.+          (PEvalDivModIntegralTerm t) =>+          Term t ->+          Term t ->+          Term t+        ) = do+        t1 <- deserializeTerm+        t2 <- deserializeTerm+        asIntegralTypeTerm t1 $ \t1' -> asSameType t1' t2 $ \t2' ->+          return $ Just (someTerm $ f t1' t2', tmId)++deserializeSomeTerm :: (MonadGet m) => m SomeTerm+deserializeSomeTerm =+  evalStateT+    statefulDeserializeSomeTerm+    ( HM.empty,+      error $+        "deserializeSomeTerm: should not happen: started with the terminal "+          <> "value"+    )++serializeSingleSomeTerm ::+  (MonadPut m) => SomeTerm -> StateT (HS.HashSet (KnownType, Id)) m ()+serializeSingleSomeTerm (SomeTerm (tm :: Term t)) = do+  st <- State.get+  let kt = knownType tm+  let tmId = termId tm+  let ktTmId = (kt, tmId)+  if HS.member ktTmId st+    then return ()+    else do+      case tm of+        ConTerm _ _ _ _ (v :: v) -> do+          serialize ktTmId+          putWord8 conTermTag+          let kt = knownType (Proxy @v)+          case witnessKnownType kt of+            KnownTypeWitness (Proxy :: Proxy v1) ->+              case eqTypeRep (primTypeRep @v) (typeRep @v1) of+                Just HRefl -> do+                  serializeKnownType kt+                  serialize v+                Nothing ->+                  error+                    "serializeSingleSomeTerm: should not happen: type mismatch"+        SymTerm _ _ _ _ (v :: TypedAnySymbol v) -> do+          serialize ktTmId+          putWord8 symTermTag+          serialize $ someTypedSymbol v+        ForallTerm _ _ _ _ ts t -> serializeQuantified ktTmId forallTermTag ts t+        ExistsTerm _ _ _ _ ts t -> serializeQuantified ktTmId existsTermTag ts t+        NotTerm _ _ _ _ t -> do+          serializeSingleSomeTerm $ someTerm t+          serialize ktTmId+          putWord8 notTermTag+          serialize $ knownTypeTermId t+        OrTerm _ _ _ _ t1 t2 -> serializeBinary ktTmId orTermTag t1 t2+        AndTerm _ _ _ _ t1 t2 -> serializeBinary ktTmId andTermTag t1 t2+        EqTerm _ _ _ _ t1 t2 -> serializeBinary ktTmId eqTermTag t1 t2+        DistinctTerm _ _ _ _ ts -> do+          traverse_ (serializeSingleSomeTerm . someTerm) ts+          serialize ktTmId+          putWord8 distinctTermTag+          serialize $ fmap knownTypeTermId ts+        ITETerm _ _ _ _ t1 t2 t3 -> serializeTernary ktTmId iteTermTag t1 t2 t3+        AddNumTerm _ _ _ _ t1 t2 -> serializeBinary ktTmId addNumTermTag t1 t2+        NegNumTerm _ _ _ _ t -> serializeUnary ktTmId negNumTermTag t+        MulNumTerm _ _ _ _ t1 t2 -> serializeBinary ktTmId mulNumTermTag t1 t2+        AbsNumTerm _ _ _ _ t -> serializeUnary ktTmId absNumTermTag t+        SignumNumTerm _ _ _ _ t -> serializeUnary ktTmId signumNumTermTag t+        LtOrdTerm _ _ _ _ t1 t2 -> serializeBinary ktTmId ltOrdTermTag t1 t2+        LeOrdTerm _ _ _ _ t1 t2 -> serializeBinary ktTmId leOrdTermTag t1 t2+        AndBitsTerm _ _ _ _ t1 t2 -> serializeBinary ktTmId andBitsTermTag t1 t2+        OrBitsTerm _ _ _ _ t1 t2 -> serializeBinary ktTmId orBitsTermTag t1 t2+        XorBitsTerm _ _ _ _ t1 t2 -> serializeBinary ktTmId xorBitsTermTag t1 t2+        ComplementBitsTerm _ _ _ _ t ->+          serializeUnary ktTmId complementBitsTermTag t+        ShiftLeftTerm _ _ _ _ t1 t2 ->+          serializeBinary ktTmId shiftLeftTermTag t1 t2+        ShiftRightTerm _ _ _ _ t1 t2 ->+          serializeBinary ktTmId shiftRightTermTag t1 t2+        RotateLeftTerm _ _ _ _ t1 t2 ->+          serializeBinary ktTmId rotateLeftTermTag t1 t2+        RotateRightTerm _ _ _ _ t1 t2 ->+          serializeBinary ktTmId rotateRightTermTag t1 t2+        BitCastTerm _ _ _ _ t -> do+          serializeSingleSomeTerm $ someTerm t+          serialize ktTmId+          serialize bitCastTermTag+          let kt = knownType (Proxy @t)+          serializeKnownType kt+          serialize $ knownTypeTermId t+        BitCastOrTerm _ _ _ _ d t -> serializeBinary ktTmId bitCastOrTermTag d t+        BVConcatTerm _ _ _ _ t1 t2 -> serializeBinary ktTmId bvConcatTermTag t1 t2+        BVSelectTerm _ _ _ _ ix w t -> do+          serializeSingleSomeTerm $ someTerm t+          serialize ktTmId+          serialize bvSelectTermTag+          serialize $ natVal ix+          serialize $ natVal w+          serialize $ knownTypeTermId t+        BVExtendTerm _ _ _ _ signed r t -> do+          serializeSingleSomeTerm $ someTerm t+          serialize ktTmId+          serialize bvExtendTermTag+          serialize signed+          serialize $ natVal r+          serialize $ knownTypeTermId t+        ApplyTerm _ _ _ _ f ts -> serializeBinary ktTmId applyTermTag f ts+        DivIntegralTerm _ _ _ _ t1 t2 ->+          serializeBinary ktTmId divIntegralTermTag t1 t2+        ModIntegralTerm _ _ _ _ t1 t2 ->+          serializeBinary ktTmId modIntegralTermTag t1 t2+        QuotIntegralTerm _ _ _ _ t1 t2 ->+          serializeBinary ktTmId quotIntegralTermTag t1 t2+        RemIntegralTerm _ _ _ _ t1 t2 ->+          serializeBinary ktTmId remIntegralTermTag t1 t2+        FPTraitTerm _ _ _ _ trait t -> do+          serializeSingleSomeTerm $ someTerm t+          serialize ktTmId+          serialize fpTraitTermTag+          serialize trait+          serialize $ knownTypeTermId t+        FdivTerm _ _ _ _ t1 t2 -> serializeBinary ktTmId fdivTermTag t1 t2+        RecipTerm _ _ _ _ t -> serializeUnary ktTmId recipTermTag t+        FloatingUnaryTerm _ _ _ _ op t -> do+          serializeSingleSomeTerm $ someTerm t+          serialize ktTmId+          serialize floatingUnaryTermTag+          serialize op+          serialize $ knownTypeTermId t+        PowerTerm _ _ _ _ t1 t2 -> serializeBinary ktTmId powerTermTag t1 t2+        FPUnaryTerm _ _ _ _ op t -> do+          serializeSingleSomeTerm $ someTerm t+          serialize ktTmId+          serialize fpUnaryTermTag+          serialize op+          serialize $ knownTypeTermId t+        FPBinaryTerm _ _ _ _ op t1 t2 -> do+          serializeSingleSomeTerm $ someTerm t1+          serializeSingleSomeTerm $ someTerm t2+          serialize ktTmId+          serialize fpBinaryTermTag+          serialize op+          serialize $ knownTypeTermId t1+          serialize $ knownTypeTermId t2+        FPRoundingUnaryTerm _ _ _ _ op rd t -> do+          serializeSingleSomeTerm $ someTerm rd+          serializeSingleSomeTerm $ someTerm t+          serialize ktTmId+          serialize fpRoundingUnaryTermTag+          serialize op+          serialize $ knownTypeTermId rd+          serialize $ knownTypeTermId t+        FPRoundingBinaryTerm _ _ _ _ op rd t1 t2 -> do+          serializeSingleSomeTerm $ someTerm rd+          serializeSingleSomeTerm $ someTerm t1+          serializeSingleSomeTerm $ someTerm t2+          serialize ktTmId+          serialize fpRoundingBinaryTermTag+          serialize op+          serialize $ knownTypeTermId rd+          serialize $ knownTypeTermId t1+          serialize $ knownTypeTermId t2+        FPFMATerm _ _ _ _ rd t1 t2 t3 -> do+          serializeSingleSomeTerm $ someTerm rd+          serializeSingleSomeTerm $ someTerm t1+          serializeSingleSomeTerm $ someTerm t2+          serializeSingleSomeTerm $ someTerm t3+          serialize ktTmId+          serialize fpFMATermTag+          serialize $ knownTypeTermId rd+          serialize $ knownTypeTermId t1+          serialize $ knownTypeTermId t2+          serialize $ knownTypeTermId t3+        FromIntegralTerm _ _ _ _ t -> do+          serializeSingleSomeTerm $ someTerm t+          serialize ktTmId+          serialize fromIntegralTermTag+          let kt = knownType (Proxy @t)+          serializeKnownType kt+          serialize $ knownTypeTermId t+        FromFPOrTerm _ _ _ _ d rd t ->+          serializeTernary ktTmId fromFPOrTermTag d rd t+        ToFPTerm _ _ _ _ rd t eb sb -> do+          serializeSingleSomeTerm $ someTerm rd+          serializeSingleSomeTerm $ someTerm t+          serialize ktTmId+          serialize toFPTermTag+          serialize $ natVal eb+          serialize $ natVal sb+          serialize $ knownTypeTermId rd+          serialize $ knownTypeTermId t+  State.put $ HS.insert ktTmId st+  where+    serializeQuantified ::+      (MonadPut m) =>+      (KnownType, Id) ->+      Word8 ->+      TypedConstantSymbol v ->+      Term b ->+      StateT (HS.HashSet (KnownType, Id)) m ()+    serializeQuantified ktTmId tag v t = do+      serializeSingleSomeTerm $ someTerm t+      serialize ktTmId+      serialize tag+      serialize $ someTypedSymbol v+      serialize $ knownTypeTermId t+    serializeUnary ktTmId tag t1 = do+      serializeSingleSomeTerm $ someTerm t1+      serialize ktTmId+      serialize tag+      serialize $ knownTypeTermId t1+    serializeBinary ktTmId tag t1 t2 = do+      serializeSingleSomeTerm $ someTerm t1+      serializeSingleSomeTerm $ someTerm t2+      serialize ktTmId+      serialize tag+      serialize $ knownTypeTermId t1+      serialize $ knownTypeTermId t2+    serializeTernary ktTmId tag t1 t2 t3 = do+      serializeSingleSomeTerm $ someTerm t1+      serializeSingleSomeTerm $ someTerm t2+      serializeSingleSomeTerm $ someTerm t3+      serialize ktTmId+      serialize tag+      serialize $ knownTypeTermId t1+      serialize $ knownTypeTermId t2+      serialize $ knownTypeTermId t3++serializeSomeTerm :: (MonadPut m) => SomeTerm -> m ()+serializeSomeTerm t = do+  flip evalStateT HS.empty $ serializeSingleSomeTerm t+  serialize (NonFuncType BoolType, 0 :: Id)+  putWord8 terminalTag++instance Serial SomeTerm where+  serialize = serializeSomeTerm+  deserialize = deserializeSomeTerm++instance Cereal.Serialize SomeTerm where+  put = serializeSomeTerm+  get = deserializeSomeTerm++instance Binary.Binary SomeTerm where+  put = serializeSomeTerm+  get = deserializeSomeTerm++instance (SupportedPrim a) => Serial (Term a) where+  serialize = serializeSomeTerm . someTerm+  deserialize = do+    SomeTerm tm <- deserialize+    withSupportedPrimTypeable @a $ case castTerm tm of+      Just r -> return r+      Nothing -> fail "deserialize Term: type mismatch"++instance (SupportedPrim a) => Cereal.Serialize (Term a) where+  put = serialize+  get = deserialize++instance (SupportedPrim a) => Binary.Binary (Term a) where+  put = serialize+  get = deserialize++instance Serial ModelValue where+  serialize (ModelValue (v :: v)) = do+    let kt = knownType (Proxy @v)+    serializeKnownType kt+    case witnessKnownType kt of+      KnownTypeWitness (Proxy :: Proxy v1) ->+        case eqTypeRep (primTypeRep @v) (typeRep @v1) of+          Just HRefl -> serialize v+          Nothing ->+            error+              "serialize ModelValue: should not happen: type mismatch"+  deserialize = do+    kt <- deserializeKnownType+    case witnessKnownType kt of+      KnownTypeWitness (Proxy :: Proxy v) -> do+        v <- deserialize @v+        return $ ModelValue v++instance Cereal.Serialize ModelValue where+  put = serialize+  get = deserialize++instance Binary.Binary ModelValue where+  put = serialize+  get = deserialize++instance (GeneralFunArg a, GeneralFunArg b) => Serial (a --> b) where+  serialize (GeneralFun ts tm) = serialize ts >> serialize tm+  deserialize = GeneralFun <$> deserialize <*> deserialize++instance (GeneralFunArg a, GeneralFunArg b) => Cereal.Serialize (a --> b) where+  put = serialize+  get = deserialize++instance (GeneralFunArg a, GeneralFunArg b) => Binary.Binary (a --> b) where+  put = serialize+  get = deserialize++type GeneralFunArg t = (SupportedNonFuncPrim t, Typeable t, Show t, Hashable t)++instance+  {-# OVERLAPPING #-}+  (GeneralFunArg a, GeneralFunArg b, GeneralFunArg c) =>+  Serial (a --> b --> c)+  where+  serialize (GeneralFun ts tm) = serialize ts >> serialize tm+  deserialize = GeneralFun <$> deserialize <*> deserialize++instance+  {-# OVERLAPPING #-}+  (GeneralFunArg a, GeneralFunArg b, GeneralFunArg c) =>+  Cereal.Serialize (a --> b --> c)+  where+  put = serialize+  get = deserialize++instance+  {-# OVERLAPPING #-}+  (GeneralFunArg a, GeneralFunArg b, GeneralFunArg c) =>+  Binary.Binary (a --> b --> c)+  where+  put = serialize+  get = deserialize++instance+  {-# OVERLAPPING #-}+  (GeneralFunArg a, GeneralFunArg b, GeneralFunArg c, GeneralFunArg d) =>+  Serial (a --> b --> c --> d)+  where+  serialize (GeneralFun ts tm) = serialize ts >> serialize tm+  deserialize = GeneralFun <$> deserialize <*> deserialize++instance+  {-# OVERLAPPING #-}+  (GeneralFunArg a, GeneralFunArg b, GeneralFunArg c, GeneralFunArg d) =>+  Cereal.Serialize (a --> b --> c --> d)+  where+  put = serialize+  get = deserialize++instance+  {-# OVERLAPPING #-}+  (GeneralFunArg a, GeneralFunArg b, GeneralFunArg c, GeneralFunArg d) =>+  Binary.Binary (a --> b --> c --> d)+  where+  put = serialize+  get = deserialize++instance+  {-# OVERLAPPING #-}+  ( GeneralFunArg a,+    GeneralFunArg b,+    GeneralFunArg c,+    GeneralFunArg d,+    GeneralFunArg e+  ) =>+  Serial (a --> b --> c --> d --> e)+  where+  serialize (GeneralFun ts tm) = serialize ts >> serialize tm+  deserialize = GeneralFun <$> deserialize <*> deserialize++instance+  {-# OVERLAPPING #-}+  ( GeneralFunArg a,+    GeneralFunArg b,+    GeneralFunArg c,+    GeneralFunArg d,+    GeneralFunArg e+  ) =>+  Cereal.Serialize (a --> b --> c --> d --> e)+  where+  put = serialize+  get = deserialize++instance+  {-# OVERLAPPING #-}+  ( GeneralFunArg a,+    GeneralFunArg b,+    GeneralFunArg c,+    GeneralFunArg d,+    GeneralFunArg e+  ) =>+  Binary.Binary (a --> b --> c --> d --> e)+  where+  put = serialize+  get = deserialize++instance+  {-# OVERLAPPING #-}+  ( GeneralFunArg a,+    GeneralFunArg b,+    GeneralFunArg c,+    GeneralFunArg d,+    GeneralFunArg e,+    GeneralFunArg f+  ) =>+  Serial (a --> b --> c --> d --> e --> f)+  where+  serialize (GeneralFun ts tm) = serialize ts >> serialize tm+  deserialize = GeneralFun <$> deserialize <*> deserialize++instance+  {-# OVERLAPPING #-}+  ( GeneralFunArg a,+    GeneralFunArg b,+    GeneralFunArg c,+    GeneralFunArg d,+    GeneralFunArg e,+    GeneralFunArg f+  ) =>+  Cereal.Serialize (a --> b --> c --> d --> e --> f)+  where+  put = serialize+  get = deserialize++instance+  {-# OVERLAPPING #-}+  ( GeneralFunArg a,+    GeneralFunArg b,+    GeneralFunArg c,+    GeneralFunArg d,+    GeneralFunArg e,+    GeneralFunArg f+  ) =>+  Binary.Binary (a --> b --> c --> d --> e --> f)+  where+  put = serialize+  get = deserialize++instance+  {-# OVERLAPPING #-}+  ( GeneralFunArg a,+    GeneralFunArg b,+    GeneralFunArg c,+    GeneralFunArg d,+    GeneralFunArg e,+    GeneralFunArg f,+    GeneralFunArg g+  ) =>+  Serial (a --> b --> c --> d --> e --> f --> g)+  where+  serialize (GeneralFun ts tm) = serialize ts >> serialize tm+  deserialize = GeneralFun <$> deserialize <*> deserialize++instance+  {-# OVERLAPPING #-}+  ( GeneralFunArg a,+    GeneralFunArg b,+    GeneralFunArg c,+    GeneralFunArg d,+    GeneralFunArg e,+    GeneralFunArg f,+    GeneralFunArg g+  ) =>+  Cereal.Serialize (a --> b --> c --> d --> e --> f --> g)+  where+  put = serialize+  get = deserialize++instance+  {-# OVERLAPPING #-}+  ( GeneralFunArg a,+    GeneralFunArg b,+    GeneralFunArg c,+    GeneralFunArg d,+    GeneralFunArg e,+    GeneralFunArg f,+    GeneralFunArg g+  ) =>+  Binary.Binary (a --> b --> c --> d --> e --> f --> g)+  where+  put = serialize+  get = deserialize++instance+  {-# OVERLAPPING #-}+  ( GeneralFunArg a,+    GeneralFunArg b,+    GeneralFunArg c,+    GeneralFunArg d,+    GeneralFunArg e,+    GeneralFunArg f,+    GeneralFunArg g,+    GeneralFunArg h+  ) =>+  Serial (a --> b --> c --> d --> e --> f --> g --> h)+  where+  serialize (GeneralFun ts tm) = serialize ts >> serialize tm+  deserialize = GeneralFun <$> deserialize <*> deserialize++instance+  {-# OVERLAPPING #-}+  ( GeneralFunArg a,+    GeneralFunArg b,+    GeneralFunArg c,+    GeneralFunArg d,+    GeneralFunArg e,+    GeneralFunArg f,+    GeneralFunArg g,+    GeneralFunArg h+  ) =>+  Cereal.Serialize (a --> b --> c --> d --> e --> f --> g --> h)+  where+  put = serialize+  get = deserialize++instance+  {-# OVERLAPPING #-}+  ( GeneralFunArg a,+    GeneralFunArg b,+    GeneralFunArg c,+    GeneralFunArg d,+    GeneralFunArg e,+    GeneralFunArg f,+    GeneralFunArg g,+    GeneralFunArg h+  ) =>+  Binary.Binary (a --> b --> c --> d --> e --> f --> g --> h)+  where+  put = serialize+  get = deserialize++instance+  {-# OVERLAPPING #-}+  ( GeneralFunArg a,+    GeneralFunArg b,+    GeneralFunArg c,+    GeneralFunArg d,+    GeneralFunArg e,+    GeneralFunArg f,+    GeneralFunArg g,+    GeneralFunArg h,+    GeneralFunArg i+  ) =>+  Serial (a --> b --> c --> d --> e --> f --> g --> h --> i)+  where+  serialize (GeneralFun ts tm) = serialize ts >> serialize tm+  deserialize = GeneralFun <$> deserialize <*> deserialize++instance+  {-# OVERLAPPING #-}+  ( GeneralFunArg a,+    GeneralFunArg b,+    GeneralFunArg c,+    GeneralFunArg d,+    GeneralFunArg e,+    GeneralFunArg f,+    GeneralFunArg g,+    GeneralFunArg h,+    GeneralFunArg i+  ) =>+  Cereal.Serialize (a --> b --> c --> d --> e --> f --> g --> h --> i)+  where+  put = serialize+  get = deserialize++instance+  {-# OVERLAPPING #-}+  ( GeneralFunArg a,+    GeneralFunArg b,+    GeneralFunArg c,+    GeneralFunArg d,+    GeneralFunArg e,+    GeneralFunArg f,+    GeneralFunArg g,+    GeneralFunArg h,+    GeneralFunArg i+  ) =>+  Binary.Binary (a --> b --> c --> d --> e --> f --> g --> h --> i)+  where+  put = serialize+  get = deserialize