diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -3,61 +3,170 @@ All notable changes to this project will be documented in this file. The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), -and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). +and this project adheres to [Semantic +Versioning](https://semver.org/spec/v2.0.0.html). +## [Unreleased] + +## [0.5.0.0] -- 2024-04-18 + +### Added + +- Added the creation of unparameterized bit vectors from run-time bit-widths. + ([#168](https://github.com/lsrcz/grisette/pull/168), + [#177](https://github.com/lsrcz/grisette/pull/177)) +- Added all the functions available for the exception transformer in + `transformers` and `mtl` packages. + ([#171](https://github.com/lsrcz/grisette/pull/171)) +- Improved the partial evaluation for bit vectors. + ([#176](https://github.com/lsrcz/grisette/pull/176)) +- Added `symRotateNegated` and `symShiftNegated`. + ([#181](https://github.com/lsrcz/grisette/pull/181)) +- Added `mrg` and `sym` variants for all reasonable operations from + `Control.Monad`, `Control.Applicative`, `Data.Foldable`, `Data.List`, and + `Data.Traversable`. ([#182](https://github.com/lsrcz/grisette/pull/182)) +- Added `mrgIfPropagatedStrategy`. + ([#184](https://github.com/lsrcz/grisette/pull/184)) +- Added `freshString`. ([#188](https://github.com/lsrcz/grisette/pull/188)) +- Added `localFreshIdent`. ([#190](https://github.com/lsrcz/grisette/pull/190)) +- Added deriving for void types for builtin type classes. + ([#191](https://github.com/lsrcz/grisette/pull/191)) + +### Fixed + +- Fixed the merging for safe division. + ([#173](https://github.com/lsrcz/grisette/pull/173)) +- Fixed the behavior for safe `mod` and `rem` for signed, bounded concrete + types. ([#173](https://github.com/lsrcz/grisette/pull/173)) +- Fixed merging in `mrg*` operations for monad transformers to ensure that they + merge the results. ([#187](https://github.com/lsrcz/grisette/pull/187)) + +### Changed + +- [Breaking] Removed the `UnionLike` and `UnionPrjOp` interface, added the + `TryMerge` and `PlainUnion` interface. This allows `mrg*` operations to be + used with non-union programs. + ([#170](https://github.com/lsrcz/grisette/pull/170)) +- [Breaking] Refined the safe operations interface using `TryMerge`. + ([#172](https://github.com/lsrcz/grisette/pull/172)) +- [Breaking] Renamed `safeMinus` to `safeSub` to be more consistent. + ([#172](https://github.com/lsrcz/grisette/pull/172)) +- [Breaking] Unifies the implementation for all symbolic non-indexed + bit-vectors. The legacy types are now type and pattern synonyms. + ([#174](https://github.com/lsrcz/grisette/pull/174), + [#179](https://github.com/lsrcz/grisette/pull/179), + [#180](https://github.com/lsrcz/grisette/pull/180)) +- [Breaking] Use functional dependency instead of type family for the `Function` + class. ([#178](https://github.com/lsrcz/grisette/pull/178)) +- [Breaking] Added `Mergeable` constraints to some `mrg*` list operators + ([#182](https://github.com/lsrcz/grisette/pull/182)) +- [Breaking] Refactored the `mrg*` constructor related template haskell code. + ([#185](https://github.com/lsrcz/grisette/pull/185)) +- [Breaking] Dropped symbols with extra information. + ([#188](https://github.com/lsrcz/grisette/pull/188)) +- [Breaking] The `FreshIdent` is removed. It is now changed to `Identifier` and + `Symbol` types. ([#192](https://github.com/lsrcz/grisette/pull/192)) +- Changed the internal representation of the terms. + ([#193](https://github.com/lsrcz/grisette/pull/193)) +- [Breaking] Refactored the project structures. + ([#194](https://github.com/lsrcz/grisette/pull/194)) + ## [0.4.1.0] -- 2024-01-10 ### Added -- Added `cegisForAll` interfaces. ([#165])(https://github.com/lsrcz/grisette/pull/165) +- Added `cegisForAll` interfaces. + ([#165](https://github.com/lsrcz/grisette/pull/165)) ## [0.4.0.0] -- 2024-01-08 ### Added -- Added wrappers for state transformers. ([#132](https://github.com/lsrcz/grisette/pull/132)) -- Added `toGuardList` function. ([#137](https://github.com/lsrcz/grisette/pull/137)) -- Exported some previously hidden API (`BVSignConversion`, `runFreshTFromIndex`) that we found useful or forgot to export. ([#138](https://github.com/lsrcz/grisette/pull/138), [#139](https://github.com/lsrcz/grisette/pull/139)) -- Provided `mrgRunFreshT` to run `FreshT` with merging. ([#140](https://github.com/lsrcz/grisette/pull/140)) -- Added `Grisette.Data.Class.SignConversion.SignConversion` for types from `Data.Int` and `Data.Word`. ([#142](https://github.com/lsrcz/grisette/pull/142)) -- Added shift functions by symbolic shift amounts. ([#151](https://github.com/lsrcz/grisette/pull/151)) -- Added `apply` for uninterpreted functions. ([#155](https://github.com/lsrcz/grisette/pull/155)) -- Added `liftFresh` to lift a `Fresh` into `MonadFresh`. ([#156](https://github.com/lsrcz/grisette/pull/156)) -- Added a handle types for SBV solvers. This allows users to use SBV solvers without the need to wrap everything in the SBV monads. ([#159](https://github.com/lsrcz/grisette/pull/159)) -- Added a new generic CEGIS interface. This allows any verifier/fuzzer to be used in the CEGIS loop. ([#159](https://github.com/lsrcz/grisette/pull/159)) +- Added wrappers for state transformers. + ([#132](https://github.com/lsrcz/grisette/pull/132)) +- Added `toGuardList` function. + ([#137](https://github.com/lsrcz/grisette/pull/137)) +- Exported some previously hidden API (`BVSignConversion`, `runFreshTFromIndex`) + that we found useful or forgot to export. + ([#138](https://github.com/lsrcz/grisette/pull/138), + [#139](https://github.com/lsrcz/grisette/pull/139)) +- Provided `mrgRunFreshT` to run `FreshT` with merging. + ([#140](https://github.com/lsrcz/grisette/pull/140)) +- Added `Grisette.Data.Class.SignConversion.SignConversion` for types from + `Data.Int` and `Data.Word`. + ([#142](https://github.com/lsrcz/grisette/pull/142)) +- Added shift functions by symbolic shift amounts. + ([#151](https://github.com/lsrcz/grisette/pull/151)) +- Added `apply` for uninterpreted functions. + ([#155](https://github.com/lsrcz/grisette/pull/155)) +- Added `liftFresh` to lift a `Fresh` into `MonadFresh`. + ([#156](https://github.com/lsrcz/grisette/pull/156)) +- Added a handle types for SBV solvers. This allows users to use SBV solvers + without the need to wrap everything in the SBV monads. + ([#159](https://github.com/lsrcz/grisette/pull/159)) +- Added a new generic CEGIS interface. This allows any verifier/fuzzer to be + used in the CEGIS loop. ([#159](https://github.com/lsrcz/grisette/pull/159)) ### Removed -- [Breaking] Removed the `Grisette.Lib.Mtl` module. ([#132](https://github.com/lsrcz/grisette/pull/132)) -- [Breaking] Removed `SymBoolOp` and `SymIntegerOp`. ([#146](https://github.com/lsrcz/grisette/pull/146)) -- [Breaking] Removed `ExtractSymbolics` instance for `SymbolSet`. ([#146](https://github.com/lsrcz/grisette/pull/146)) +- [Breaking] Removed the `Grisette.Lib.Mtl` module. + ([#132](https://github.com/lsrcz/grisette/pull/132)) +- [Breaking] Removed `SymBoolOp` and `SymIntegerOp`. + ([#146](https://github.com/lsrcz/grisette/pull/146)) +- [Breaking] Removed `ExtractSymbolics` instance for `SymbolSet`. + ([#146](https://github.com/lsrcz/grisette/pull/146)) ### Fixed -- Removed the quotation marks around the pretty printed results for string-like data types. ([#127](https://github.com/lsrcz/grisette/pull/127)) -- Fixed the `SOrd` instance for `VerificationConditions`. ([#131](https://github.com/lsrcz/grisette/pull/131)) -- Fixed the missing `SubstituteSym` instance for `UnionM`. ([#131](https://github.com/lsrcz/grisette/pull/131)) -- Fixed the symbolic generation order for `Maybe`. ([#131](https://github.com/lsrcz/grisette/pull/131)) -- Fixed the `toInteger` function for `IntN 1`. ([#143](https://github.com/lsrcz/grisette/pull/143)) -- Fixed the `abs` function for `WordN`. ([#144](https://github.com/lsrcz/grisette/pull/143)) -- Fixed the QuickCheck shrink function for `WordN 1` and `IntN 1`. ([#149](https://github.com/lsrcz/grisette/pull/149)) -- Fixed the heap overflow bug for `shiftL` for `WordN` and `IntN` by large numbers. ([#150](https://github.com/lsrcz/grisette/pull/150)) +- Removed the quotation marks around the pretty printed results for string-like + data types. ([#127](https://github.com/lsrcz/grisette/pull/127)) +- Fixed the `SOrd` instance for `VerificationConditions`. + ([#131](https://github.com/lsrcz/grisette/pull/131)) +- Fixed the missing `SubstituteSym` instance for `UnionM`. + ([#131](https://github.com/lsrcz/grisette/pull/131)) +- Fixed the symbolic generation order for `Maybe`. + ([#131](https://github.com/lsrcz/grisette/pull/131)) +- Fixed the `toInteger` function for `IntN 1`. + ([#143](https://github.com/lsrcz/grisette/pull/143)) +- Fixed the `abs` function for `WordN`. + ([#144](https://github.com/lsrcz/grisette/pull/143)) +- Fixed the QuickCheck shrink function for `WordN 1` and `IntN 1`. + ([#149](https://github.com/lsrcz/grisette/pull/149)) +- Fixed the heap overflow bug for `shiftL` for `WordN` and `IntN` by large + numbers. ([#150](https://github.com/lsrcz/grisette/pull/150)) ### Changed -- Reorganized the files for `MonadTrans`. ([#132](https://github.com/lsrcz/grisette/pull/132)) -- [Breaking] Changed the name of `Union` constructors and patterns. ([#133](https://github.com/lsrcz/grisette/pull/133)) -- The `Union` patterns, when used as constructors, now merges the result. ([#133](https://github.com/lsrcz/grisette/pull/133)) -- Changed the symbolic identifier type from `String` to `Data.Text.Text`. ([#141](https://github.com/lsrcz/grisette/pull/141)) -- [Breaking] `Grisette.Data.Class.BitVector.BVSignConversion` is now `Grisette.Data.Class.SignConversion.SignConversion`. ([#142](https://github.com/lsrcz/grisette/pull/142)) -- [Breaking] Moved the `ITEOp`, `LogicalOp`, and `SEq` type classes to dedicated modules. ([#146](https://github.com/lsrcz/grisette/pull/146)) -- [Breaking] Moved `Grisette.Data.Class.Evaluate` to `Grisette.Data.Class.EvaluateSym`. ([#146](https://github.com/lsrcz/grisette/pull/146)) -- [Breaking] Moved `Grisette.Data.Class.Substitute` to `Grisette.Data.Class.SubstituteSym`. ([#146](https://github.com/lsrcz/grisette/pull/146)) -- [Breaking] Split the `Grisette.Data.Class.SafeArith` module to `Grisette.Data.Class.SafeDivision` and `Grisette.Data.Class.SafeLinearArith`. ([#146](https://github.com/lsrcz/grisette/pull/146)) -- [Breaking] Changed the API to `MonadFresh`. ([#156](https://github.com/lsrcz/grisette/pull/156)) -- [Breaking] Renamed multiple symbolic operators. ([#158](https://github.com/lsrcz/grisette/pull/158)) -- [Breaking] Changed the solver interface. ([#159](https://github.com/lsrcz/grisette/pull/159)) -- [Breaking] Changed the CEGIS solver interface. ([#159](https://github.com/lsrcz/grisette/pull/159)) +- Reorganized the files for `MonadTrans`. + ([#132](https://github.com/lsrcz/grisette/pull/132)) +- [Breaking] Changed the name of `Union` constructors and patterns. + ([#133](https://github.com/lsrcz/grisette/pull/133)) +- The `Union` patterns, when used as constructors, now merges the result. + ([#133](https://github.com/lsrcz/grisette/pull/133)) +- Changed the symbolic identifier type from `String` to `Data.Text.Text`. + ([#141](https://github.com/lsrcz/grisette/pull/141)) +- [Breaking] `Grisette.Data.Class.BitVector.BVSignConversion` is now + `Grisette.Data.Class.SignConversion.SignConversion`. + ([#142](https://github.com/lsrcz/grisette/pull/142)) +- [Breaking] Moved the `ITEOp`, `LogicalOp`, and `SEq` type classes to dedicated + modules. ([#146](https://github.com/lsrcz/grisette/pull/146)) +- [Breaking] Moved `Grisette.Data.Class.Evaluate` to + `Grisette.Data.Class.EvaluateSym`. + ([#146](https://github.com/lsrcz/grisette/pull/146)) +- [Breaking] Moved `Grisette.Data.Class.Substitute` to + `Grisette.Data.Class.SubstituteSym`. + ([#146](https://github.com/lsrcz/grisette/pull/146)) +- [Breaking] Split the `Grisette.Data.Class.SafeArith` module to + `Grisette.Data.Class.SafeDivision` and `Grisette.Data.Class.SafeLinearArith`. + ([#146](https://github.com/lsrcz/grisette/pull/146)) +- [Breaking] Changed the API to `MonadFresh`. + ([#156](https://github.com/lsrcz/grisette/pull/156)) +- [Breaking] Renamed multiple symbolic operators. + ([#158](https://github.com/lsrcz/grisette/pull/158)) +- [Breaking] Changed the solver interface. + ([#159](https://github.com/lsrcz/grisette/pull/159)) +- [Breaking] Changed the CEGIS solver interface. + ([#159](https://github.com/lsrcz/grisette/pull/159)) ## [0.3.1.1] -- 2023-09-29 @@ -67,63 +176,98 @@ ### Added -- Added support to `Data.Text`. ([#95](https://github.com/lsrcz/grisette/pull/95)) -- Added `Arbitrary` instances for bit vectors. ([#97](https://github.com/lsrcz/grisette/pull/97)) -- Added pretty printers for Grisette data types. ([#101](https://github.com/lsrcz/grisette/pull/101)) -- Added `ExtractSymbolics` instances for tuples longer than 2. ([#103](https://github.com/lsrcz/grisette/pull/103)) +- Added support to `Data.Text`. + ([#95](https://github.com/lsrcz/grisette/pull/95)) +- Added `Arbitrary` instances for bit vectors. + ([#97](https://github.com/lsrcz/grisette/pull/97)) +- Added pretty printers for Grisette data types. + ([#101](https://github.com/lsrcz/grisette/pull/101)) +- Added `ExtractSymbolics` instances for tuples longer than 2. + ([#103](https://github.com/lsrcz/grisette/pull/103)) ### Fixed -- Fixed the `Read` instance for bit vectors. ([#99](https://github.com/lsrcz/grisette/pull/99), [#100](https://github.com/lsrcz/grisette/pull/100)) +- Fixed the `Read` instance for bit vectors. + ([#99](https://github.com/lsrcz/grisette/pull/99), + [#100](https://github.com/lsrcz/grisette/pull/100)) ## [0.3.0.0] -- 2023-07-07 ### Added -- Added the conversion between signed and unsigned bit vectors. ([#69](https://github.com/lsrcz/grisette/pull/69)) -- Added the generation of `SomeSymIntN` and `SomeSymWordN` from a single `Int` for bit width. ([#73](https://github.com/lsrcz/grisette/pull/73)) -- Added the `FiniteBits` instance for `SomeSymIntN` and `SomeSymWordN`. ([#83](https://github.com/lsrcz/grisette/pull/83)) -- Added more flexible instances for symbolic generation for `Either`, `Maybe` and list types. ([#84](https://github.com/lsrcz/grisette/pull/84)) -- Added an experimental `GenSymConstrained` type class. ([#89](https://github.com/lsrcz/grisette/pull/89)) +- Added the conversion between signed and unsigned bit vectors. + ([#69](https://github.com/lsrcz/grisette/pull/69)) +- Added the generation of `SomeSymIntN` and `SomeSymWordN` from a single `Int` + for bit width. ([#73](https://github.com/lsrcz/grisette/pull/73)) +- Added the `FiniteBits` instance for `SomeSymIntN` and `SomeSymWordN`. + ([#83](https://github.com/lsrcz/grisette/pull/83)) +- Added more flexible instances for symbolic generation for `Either`, `Maybe` + and list types. ([#84](https://github.com/lsrcz/grisette/pull/84)) +- Added an experimental `GenSymConstrained` type class. + ([#89](https://github.com/lsrcz/grisette/pull/89)) ### Changed -- Changed the operations for `SomeIntN` and `SomeWordN` to accepting dynamic runtime integers rather than compile-time integers. ([#71](https://github.com/lsrcz/grisette/pull/71)) -- Comparing the equality of `SomeIntN`/`SomeWordN`/`SomeSymIntN`/`SomeSymWordN` with different bit widths returns false rather than crash now. ([#74](https://github.com/lsrcz/grisette/pull/74)) +- Changed the operations for `SomeIntN` and `SomeWordN` to accepting dynamic + runtime integers rather than compile-time integers. + ([#71](https://github.com/lsrcz/grisette/pull/71)) +- Comparing the equality of `SomeIntN`/`SomeWordN`/`SomeSymIntN`/`SomeSymWordN` + with different bit widths returns false rather than crash now. + ([#74](https://github.com/lsrcz/grisette/pull/74)) ### Fixed -- Fixed the compatibility issue with sbv 10+. ([#66](https://github.com/lsrcz/grisette/pull/66)) -- Fixed build error with newer GHC. ([#70](https://github.com/lsrcz/grisette/pull/70)) -- Fixed the merging for `SomeSymIntN` and `SomeSymWordN`. ([#72](https://github.com/lsrcz/grisette/pull/72)) +- Fixed the compatibility issue with sbv 10+. + ([#66](https://github.com/lsrcz/grisette/pull/66)) +- Fixed build error with newer GHC. + ([#70](https://github.com/lsrcz/grisette/pull/70)) +- Fixed the merging for `SomeSymIntN` and `SomeSymWordN`. + ([#72](https://github.com/lsrcz/grisette/pull/72)) ## [0.2.0.0] - 2023-04-13 ### Added -- Add term size count API. ([#48](https://github.com/lsrcz/grisette/pull/48), [#53](https://github.com/lsrcz/grisette/pull/53)) -- Add timeout to solver interface. ([#49](https://github.com/lsrcz/grisette/pull/49), [#50](https://github.com/lsrcz/grisette/pull/50)) -- Add parallel do-notation for parallel symbolic compilation. ([#51](https://github.com/lsrcz/grisette/pull/51)) -- Added some missing instances for symbolic values and bit vectors. ([#46](https://github.com/lsrcz/grisette/pull/46), [#61](https://github.com/lsrcz/grisette/pull/61)) -- Add missing instances for `MonadFresh` and `FreshT`. ([#59](https://github.com/lsrcz/grisette/pull/59)) +- Add term size count API. ([#48](https://github.com/lsrcz/grisette/pull/48), + [#53](https://github.com/lsrcz/grisette/pull/53)) +- Add timeout to solver interface. + ([#49](https://github.com/lsrcz/grisette/pull/49), + [#50](https://github.com/lsrcz/grisette/pull/50)) +- Add parallel do-notation for parallel symbolic compilation. + ([#51](https://github.com/lsrcz/grisette/pull/51)) +- Added some missing instances for symbolic values and bit vectors. + ([#46](https://github.com/lsrcz/grisette/pull/46), + [#61](https://github.com/lsrcz/grisette/pull/61)) +- Add missing instances for `MonadFresh` and `FreshT`. + ([#59](https://github.com/lsrcz/grisette/pull/59)) ### Changed -- New safe operator interfaces. ([#56](https://github.com/lsrcz/grisette/pull/56)) +- New safe operator interfaces. + ([#56](https://github.com/lsrcz/grisette/pull/56)) - Redesigned symbolic value interface. - - `Sym Bool`/`Sym Integer`, etc., are no longer available and are replaced with `SymBool` and `SymInteger`. ([#41](https://github.com/lsrcz/grisette/pull/41)) - - New symbolic bit vector interface. Added unsized bit vector. ([#41](https://github.com/lsrcz/grisette/pull/41)) + - `Sym Bool`/`Sym Integer`, etc., are no longer available and are replaced + with `SymBool` and `SymInteger`. + ([#41](https://github.com/lsrcz/grisette/pull/41)) + - New symbolic bit vector interface. Added unsized bit vector. + ([#41](https://github.com/lsrcz/grisette/pull/41)) ### Removed -- Dropped merging cache for `UnionM`. This fixed some segmentation fault errors. ([#43](https://github.com/lsrcz/grisette/pull/43)) +- Dropped merging cache for `UnionM`. This fixed some segmentation fault errors. + ([#43](https://github.com/lsrcz/grisette/pull/43)) ### Fixed -- Fix CEGIS when no symbolic input is present. ([#52](https://github.com/lsrcz/grisette/pull/52)) -- Fix overlapping `ToSym` and `ToCon` instances. ([#54](https://github.com/lsrcz/grisette/pull/54)) -- Fix uninterpreted function lowering. ([#57](https://github.com/lsrcz/grisette/pull/57), [#58](https://github.com/lsrcz/grisette/pull/58)) -- Fix CEGIS crash when subsequent solver calls introduces new symbolic constant. ([#60](https://github.com/lsrcz/grisette/pull/60)) +- Fix CEGIS when no symbolic input is present. + ([#52](https://github.com/lsrcz/grisette/pull/52)) +- Fix overlapping `ToSym` and `ToCon` instances. + ([#54](https://github.com/lsrcz/grisette/pull/54)) +- Fix uninterpreted function lowering. + ([#57](https://github.com/lsrcz/grisette/pull/57), + [#58](https://github.com/lsrcz/grisette/pull/58)) +- Fix CEGIS crash when subsequent solver calls introduces new symbolic constant. + ([#60](https://github.com/lsrcz/grisette/pull/60)) ## [0.1.0.0] - 2023-01-20 @@ -131,8 +275,10 @@ - Initial release for Grisette. -[0.4.1.0]: https://github.com/lsrcz/grisette/compare/v0.4.1.0...v0.4.0.0 -[0.4.0.0]: https://github.com/lsrcz/grisette/compare/v0.4.0.0...v0.3.1.0 +[Unreleased]: https://github.com/lsrcz/grisette/compare/v0.5.0.0...HEAD +[0.5.0.0]: https://github.com/lsrcz/grisette/compare/v0.4.1.0...v0.5.0.0 +[0.4.1.0]: https://github.com/lsrcz/grisette/compare/v0.4.0.0...v0.4.1.0 +[0.4.0.0]: https://github.com/lsrcz/grisette/compare/v0.3.1.1...v0.4.0.0 [0.3.1.1]: https://github.com/lsrcz/grisette/compare/v0.3.1.0...v0.3.1.1 [0.3.1.0]: https://github.com/lsrcz/grisette/compare/v0.3.0.0...v0.3.1.0 [0.3.0.0]: https://github.com/lsrcz/grisette/compare/v0.2.0.0...v0.3.0.0 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -47,7 +47,7 @@ ```cabal library ... - build-depends: grisette >= 0.4.1 < 0.5 + build-depends: grisette >= 0.5 < 0.6 ``` #### Quick start template with `stack new` @@ -151,6 +151,15 @@ returned by a solver to replace the symbolic holes inside to concrete values. ```haskell +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +import Grisette +import GHC.Generics + data SExpr -- `SConst` represents a constant in the syntax tree. -- @@ -180,8 +189,8 @@ -- >>> SConst 1 :: SExpr -- SConst 1 -- >>> mrgSConst 1 :: UnionM SExpr --- UMrg (Single (SConst 1)) -$(makeUnionWrapper "mrg" ''SExpr) +-- {SConst 1} +mkMergeConstructor "mrg" ''SExpr ``` Then we can define the program space. @@ -204,7 +213,8 @@ ```haskell interpret :: SExpr -> SymInteger -interpret (SInt x) = x +interpret (SConst x) = x +interpret (SInput x) = x interpret (SPlus x y) = interpretU x + interpretU y interpret (SMul x y) = interpretU x * interpretU y @@ -227,7 +237,7 @@ ```haskell example :: IO () example = do - Right model <- solve (UnboundedReasoning z3) $ executableSpace 2 ==~ 5 + Right model <- solve (precise z3) $ executableSpace 2 .== 5 print $ evaluateSym False model (space "x") -- result: SPlus {SInput x} {SConst 3} let synthesizedProgram :: Integer -> Integer = @@ -241,8 +251,8 @@ ## Documentation - Haddock documentation at [grisette](https://hackage.haskell.org/package/grisette). -- Grisette essentials (WIP). -- Grisette tutorials (WIP). +- A tutorial to Grisette is in the [tutorials](tutorials) directory. They are + provided as jupyter notebooks with the [IHaskell](https://github.com/IHaskell/IHaskell) kernel. ## License diff --git a/grisette.cabal b/grisette.cabal --- a/grisette.cabal +++ b/grisette.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: grisette -version: 0.4.1.0 +version: 0.5.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 @@ -29,7 +29,8 @@ , GHC == 9.0.2 , GHC == 9.2.8 , GHC == 9.4.8 - , GHC == 9.6.3 + , GHC == 9.6.4 + , GHC == 9.8.2 extra-source-files: CHANGELOG.md README.md @@ -46,94 +47,106 @@ library exposed-modules: Grisette - Grisette.Backend.SBV - Grisette.Backend.SBV.Data.SMT.Lowering - Grisette.Backend.SBV.Data.SMT.Solving - Grisette.Backend.SBV.Data.SMT.SymBiMap + Grisette.Backend Grisette.Core - Grisette.Core.BuiltinUnionWrappers - Grisette.Core.Control.Exception - Grisette.Core.Control.Monad.CBMCExcept - Grisette.Core.Control.Monad.Class.MonadParallelUnion - Grisette.Core.Control.Monad.Union - Grisette.Core.Control.Monad.UnionM - Grisette.Core.Data.BV - Grisette.Core.Data.Class.BitVector - Grisette.Core.Data.Class.CEGISSolver - Grisette.Core.Data.Class.Error - Grisette.Core.Data.Class.EvaluateSym - Grisette.Core.Data.Class.ExtractSymbolics - Grisette.Core.Data.Class.Function - Grisette.Core.Data.Class.GenSym - Grisette.Core.Data.Class.GPretty - Grisette.Core.Data.Class.ITEOp - Grisette.Core.Data.Class.LogicalOp - Grisette.Core.Data.Class.Mergeable - Grisette.Core.Data.Class.ModelOps - Grisette.Core.Data.Class.SafeDivision - Grisette.Core.Data.Class.SafeLinearArith - Grisette.Core.Data.Class.SafeSymRotate - Grisette.Core.Data.Class.SafeSymShift - Grisette.Core.Data.Class.SEq - Grisette.Core.Data.Class.SignConversion - Grisette.Core.Data.Class.SimpleMergeable - Grisette.Core.Data.Class.Solvable - Grisette.Core.Data.Class.Solver - Grisette.Core.Data.Class.SOrd - Grisette.Core.Data.Class.SubstituteSym - Grisette.Core.Data.Class.SymRotate - Grisette.Core.Data.Class.SymShift - Grisette.Core.Data.Class.ToCon - Grisette.Core.Data.Class.ToSym - Grisette.Core.Data.FileLocation - Grisette.Core.Data.MemoUtils - Grisette.Core.Data.Union - Grisette.Core.TH - Grisette.Core.THCompat Grisette.Experimental Grisette.Experimental.GenSymConstrained - Grisette.Internal.Backend.SBV - Grisette.Internal.Core - Grisette.Internal.IR.SymPrim - Grisette.IR.SymPrim - Grisette.IR.SymPrim.Data.IntBitwidth - Grisette.IR.SymPrim.Data.Prim.Helpers - Grisette.IR.SymPrim.Data.Prim.InternedTerm.Caches - Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors - Grisette.IR.SymPrim.Data.Prim.InternedTerm.SomeTerm - Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term - Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermSubstitution - Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermUtils - Grisette.IR.SymPrim.Data.Prim.Model - Grisette.IR.SymPrim.Data.Prim.ModelValue - Grisette.IR.SymPrim.Data.Prim.PartialEval.Bits - Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool - Grisette.IR.SymPrim.Data.Prim.PartialEval.BV - Grisette.IR.SymPrim.Data.Prim.PartialEval.GeneralFun - Grisette.IR.SymPrim.Data.Prim.PartialEval.Integral - Grisette.IR.SymPrim.Data.Prim.PartialEval.Num - Grisette.IR.SymPrim.Data.Prim.PartialEval.PartialEval - Grisette.IR.SymPrim.Data.Prim.PartialEval.TabularFun - Grisette.IR.SymPrim.Data.Prim.PartialEval.Unfold - Grisette.IR.SymPrim.Data.Prim.Utils - Grisette.IR.SymPrim.Data.SymPrim - Grisette.IR.SymPrim.Data.TabularFun + Grisette.Experimental.MonadParallelUnion + Grisette.Experimental.Qualified.ParallelUnionDo + Grisette.Internal.Backend.Solving + Grisette.Internal.Backend.SymBiMap + Grisette.Internal.Core.Control.Exception + Grisette.Internal.Core.Control.Monad.CBMCExcept + Grisette.Internal.Core.Control.Monad.Union + Grisette.Internal.Core.Control.Monad.UnionM + Grisette.Internal.Core.Data.Class.BitVector + Grisette.Internal.Core.Data.Class.CEGISSolver + Grisette.Internal.Core.Data.Class.Error + Grisette.Internal.Core.Data.Class.EvaluateSym + Grisette.Internal.Core.Data.Class.ExtractSymbolics + Grisette.Internal.Core.Data.Class.Function + Grisette.Internal.Core.Data.Class.GenSym + Grisette.Internal.Core.Data.Class.GPretty + Grisette.Internal.Core.Data.Class.ITEOp + Grisette.Internal.Core.Data.Class.LogicalOp + Grisette.Internal.Core.Data.Class.Mergeable + Grisette.Internal.Core.Data.Class.ModelOps + Grisette.Internal.Core.Data.Class.PlainUnion + Grisette.Internal.Core.Data.Class.SafeDivision + Grisette.Internal.Core.Data.Class.SafeLinearArith + Grisette.Internal.Core.Data.Class.SafeSymRotate + Grisette.Internal.Core.Data.Class.SafeSymShift + Grisette.Internal.Core.Data.Class.SEq + Grisette.Internal.Core.Data.Class.SignConversion + Grisette.Internal.Core.Data.Class.SimpleMergeable + Grisette.Internal.Core.Data.Class.Solvable + Grisette.Internal.Core.Data.Class.Solver + Grisette.Internal.Core.Data.Class.SOrd + Grisette.Internal.Core.Data.Class.SubstituteSym + Grisette.Internal.Core.Data.Class.SymRotate + Grisette.Internal.Core.Data.Class.SymShift + Grisette.Internal.Core.Data.Class.ToCon + Grisette.Internal.Core.Data.Class.ToSym + Grisette.Internal.Core.Data.Class.TryMerge + Grisette.Internal.Core.Data.MemoUtils + Grisette.Internal.Core.Data.Symbol + Grisette.Internal.Core.Data.Union + Grisette.Internal.Core.TH.MergeConstructor + Grisette.Internal.SymPrim.AllSyms + Grisette.Internal.SymPrim.BV + Grisette.Internal.SymPrim.GeneralFun + Grisette.Internal.SymPrim.IntBitwidth + Grisette.Internal.SymPrim.ModelRep + Grisette.Internal.SymPrim.Prim.Internal.Caches + Grisette.Internal.SymPrim.Prim.Internal.Instances.BVPEval + Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalBitwiseTerm + Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalDivModIntegralTerm + Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalNumTerm + Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalOrdTerm + Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalRotateTerm + Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalShiftTerm + Grisette.Internal.SymPrim.Prim.Internal.Instances.SupportedPrim + Grisette.Internal.SymPrim.Prim.Internal.IsZero + Grisette.Internal.SymPrim.Prim.Internal.PartialEval + 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 + Grisette.Internal.SymPrim.SomeBV + Grisette.Internal.SymPrim.SymBool + Grisette.Internal.SymPrim.SymBV + Grisette.Internal.SymPrim.SymGeneralFun + Grisette.Internal.SymPrim.SymInteger + Grisette.Internal.SymPrim.SymTabularFun + Grisette.Internal.SymPrim.TabularFun + Grisette.Internal.Utils.Parameterized Grisette.Lib.Base + Grisette.Lib.Control.Applicative Grisette.Lib.Control.Monad Grisette.Lib.Control.Monad.Except Grisette.Lib.Control.Monad.State.Class Grisette.Lib.Control.Monad.Trans Grisette.Lib.Control.Monad.Trans.Class Grisette.Lib.Control.Monad.Trans.Cont + Grisette.Lib.Control.Monad.Trans.Except Grisette.Lib.Control.Monad.Trans.State Grisette.Lib.Control.Monad.Trans.State.Lazy Grisette.Lib.Control.Monad.Trans.State.Strict + Grisette.Lib.Data.Bool + Grisette.Lib.Data.Either Grisette.Lib.Data.Foldable + Grisette.Lib.Data.Functor + Grisette.Lib.Data.Functor.Sum Grisette.Lib.Data.List + Grisette.Lib.Data.Maybe Grisette.Lib.Data.Traversable - Grisette.Qualified.ParallelUnionDo + Grisette.Lib.Data.Tuple + Grisette.SymPrim Grisette.Utils - Grisette.Utils.Parameterized other-modules: Paths_grisette hs-source-dirs: @@ -154,7 +167,7 @@ , mtl >=2.2.2 && <2.4 , parallel >=3.2.2.0 && <3.3 , prettyprinter >=1.5.0 && <1.8 - , sbv >=8.11 && <10.4 + , sbv >=8.11 && <11 , stm ==2.5.* , template-haskell >=2.16 && <2.22 , text >=1.2.4.1 && <2.2 @@ -193,7 +206,7 @@ , mtl >=2.2.2 && <2.4 , parallel >=3.2.2.0 && <3.3 , prettyprinter >=1.5.0 && <1.8 - , sbv >=8.11 && <10.4 + , sbv >=8.11 && <11 , stm ==2.5.* , template-haskell >=2.16 && <2.22 , text >=1.2.4.1 && <2.2 @@ -210,10 +223,10 @@ type: exitcode-stdio-1.0 main-is: Main.hs other-modules: - Grisette.Backend.SBV.Data.SMT.CEGISTests - Grisette.Backend.SBV.Data.SMT.LoweringTests - Grisette.Backend.SBV.Data.SMT.TermRewritingGen - Grisette.Backend.SBV.Data.SMT.TermRewritingTests + Grisette.Backend.CEGISTests + Grisette.Backend.LoweringTests + Grisette.Backend.TermRewritingGen + Grisette.Backend.TermRewritingTests Grisette.Core.Control.ExceptionTests Grisette.Core.Control.Monad.UnionMTests Grisette.Core.Control.Monad.UnionTests @@ -224,6 +237,9 @@ Grisette.Core.Data.Class.GenSymTests Grisette.Core.Data.Class.GPrettyTests Grisette.Core.Data.Class.MergeableTests + Grisette.Core.Data.Class.PlainUnionTests + Grisette.Core.Data.Class.SafeDivisionTests + Grisette.Core.Data.Class.SafeLinearArithTests Grisette.Core.Data.Class.SafeSymRotateTests Grisette.Core.Data.Class.SafeSymShiftTests Grisette.Core.Data.Class.SEqTests @@ -235,25 +251,32 @@ Grisette.Core.Data.Class.TestValues Grisette.Core.Data.Class.ToConTests Grisette.Core.Data.Class.ToSymTests - Grisette.Core.Data.Class.UnionLikeTests - Grisette.IR.SymPrim.Data.Prim.BitsTests - Grisette.IR.SymPrim.Data.Prim.BoolTests - Grisette.IR.SymPrim.Data.Prim.BVTests - Grisette.IR.SymPrim.Data.Prim.IntegralTests - Grisette.IR.SymPrim.Data.Prim.ModelTests - Grisette.IR.SymPrim.Data.Prim.NumTests - Grisette.IR.SymPrim.Data.Prim.TabularFunTests - Grisette.IR.SymPrim.Data.SymPrimTests - Grisette.IR.SymPrim.Data.TabularFunTests + Grisette.Core.Data.Class.TryMergeTests + Grisette.Core.Data.SomeBVTests + Grisette.Lib.Control.ApplicativeTest Grisette.Lib.Control.Monad.ExceptTests Grisette.Lib.Control.Monad.State.ClassTests Grisette.Lib.Control.Monad.Trans.ClassTests + Grisette.Lib.Control.Monad.Trans.ExceptTests Grisette.Lib.Control.Monad.Trans.State.Common Grisette.Lib.Control.Monad.Trans.State.LazyTests Grisette.Lib.Control.Monad.Trans.State.StrictTests Grisette.Lib.Control.MonadTests Grisette.Lib.Data.FoldableTests + Grisette.Lib.Data.FunctorTests + Grisette.Lib.Data.ListTests Grisette.Lib.Data.TraversableTests + Grisette.SymPrim.Prim.BitsTests + Grisette.SymPrim.Prim.BoolTests + Grisette.SymPrim.Prim.BVTests + Grisette.SymPrim.Prim.IntegralTests + Grisette.SymPrim.Prim.ModelTests + Grisette.SymPrim.Prim.NumTests + Grisette.SymPrim.Prim.TabularFunTests + Grisette.SymPrim.SymPrimTests + Grisette.SymPrim.TabularFunTests + Grisette.TestUtil.NoMerge + Grisette.TestUtil.PrettyPrint Grisette.TestUtil.SymbolicAssertion Paths_grisette hs-source-dirs: @@ -276,7 +299,7 @@ , mtl >=2.2.2 && <2.4 , parallel >=3.2.2.0 && <3.3 , prettyprinter >=1.5.0 && <1.8 - , sbv >=8.11 && <10.4 + , sbv >=8.11 && <11 , stm ==2.5.* , template-haskell >=2.16 && <2.22 , test-framework >=0.8.2 && <0.9 diff --git a/src/Grisette.hs b/src/Grisette.hs --- a/src/Grisette.hs +++ b/src/Grisette.hs @@ -17,18 +17,18 @@ module Grisette.Lib.Base, -- * Symbolic primitives - module Grisette.IR.SymPrim, + module Grisette.SymPrim, -- * Solver backend - module Grisette.Backend.SBV, + module Grisette.Backend, -- * Utils module Grisette.Utils, ) where -import Grisette.Backend.SBV +import Grisette.Backend import Grisette.Core -import Grisette.IR.SymPrim import Grisette.Lib.Base +import Grisette.SymPrim import Grisette.Utils diff --git a/src/Grisette/Backend.hs b/src/Grisette/Backend.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Backend.hs @@ -0,0 +1,48 @@ +-- Disable this warning because we are re-exporting things. +{-# OPTIONS_GHC -Wno-missing-import-lists #-} + +-- | +-- Module : Grisette.Backend +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Backend + ( -- * Grisette.Internal.SBV backend configuration + ApproximationConfig (..), + ExtraConfig (..), + precise, + approx, + withTimeout, + clearTimeout, + withApprox, + clearApprox, + GrisetteSMTConfig (..), + + -- * SBV backend solver configuration + SBV.SMTConfig (..), + SBV.boolector, + SBV.cvc4, + SBV.yices, + SBV.dReal, + SBV.z3, + SBV.mathSAT, + SBV.abc, + SBV.Timing (..), + ) +where + +import qualified Data.SBV as SBV +import Grisette.Internal.Backend.Solving + ( ApproximationConfig (..), + ExtraConfig (..), + GrisetteSMTConfig (..), + approx, + clearApprox, + clearTimeout, + precise, + withApprox, + withTimeout, + ) diff --git a/src/Grisette/Backend/SBV.hs b/src/Grisette/Backend/SBV.hs deleted file mode 100644 --- a/src/Grisette/Backend/SBV.hs +++ /dev/null @@ -1,48 +0,0 @@ --- Disable this warning because we are re-exporting things. -{-# OPTIONS_GHC -Wno-missing-import-lists #-} - --- | --- Module : Grisette.Backend.SBV --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Backend.SBV - ( -- * Grisette SBV backend configuration - ApproximationConfig (..), - ExtraConfig (..), - precise, - approx, - withTimeout, - clearTimeout, - withApprox, - clearApprox, - GrisetteSMTConfig (..), - - -- * SBV backend solver configuration - SBV.SMTConfig (..), - SBV.boolector, - SBV.cvc4, - SBV.yices, - SBV.dReal, - SBV.z3, - SBV.mathSAT, - SBV.abc, - SBV.Timing (..), - ) -where - -import qualified Data.SBV as SBV -import Grisette.Backend.SBV.Data.SMT.Solving - ( ApproximationConfig (..), - ExtraConfig (..), - GrisetteSMTConfig (..), - approx, - clearApprox, - clearTimeout, - precise, - withApprox, - withTimeout, - ) diff --git a/src/Grisette/Backend/SBV/Data/SMT/Lowering.hs b/src/Grisette/Backend/SBV/Data/SMT/Lowering.hs deleted file mode 100644 --- a/src/Grisette/Backend/SBV/Data/SMT/Lowering.hs +++ /dev/null @@ -1,1882 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RoleAnnotations #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} - --- | --- Module : Grisette.Backend.SBV.Data.SMT.Lowering --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Backend.SBV.Data.SMT.Lowering - ( lowerSinglePrim, - lowerSinglePrimCached, - parseModel, - SymBiMap, - ) -where - -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Reader (MonadTrans (lift), ReaderT) -import Control.Monad.State (StateT) -import Data.Bifunctor (Bifunctor (bimap, first, second)) -import Data.Bits - ( Bits (complement, xor, (.&.), (.|.)), - ) -import Data.Dynamic (Typeable, fromDyn, toDyn) -import Data.Foldable (Foldable (foldl'), asum) -import Data.Kind (Type) -import Data.Maybe (fromMaybe) -import Data.SBV (SIntegral, sRotateLeft, sRotateRight, sShiftLeft, sShiftRight) -import qualified Data.SBV as SBV -import qualified Data.SBV.Internals as SBVI -import qualified Data.SBV.Trans as SBVT -import qualified Data.SBV.Trans.Control as SBVTC -import Data.Type.Equality (type (~~)) -import Data.Typeable (Proxy (Proxy), type (:~:) (Refl)) -import GHC.Exts (sortWith) -import GHC.Stack (HasCallStack) -import GHC.TypeNats - ( KnownNat, - Nat, - natVal, - type (+), - type (-), - type (<=), - ) -import {-# SOURCE #-} Grisette.Backend.SBV.Data.SMT.Solving - ( ApproximationConfig (Approx, NoApprox), - ExtraConfig (integerApprox), - GrisetteSMTConfig (GrisetteSMTConfig), - TermTy, - ) -import Grisette.Backend.SBV.Data.SMT.SymBiMap - ( SymBiMap, - addBiMap, - addBiMapIntermediate, - emptySymBiMap, - findStringToSymbol, - lookupTerm, - sizeBiMap, - ) -import Grisette.Core.Data.BV (IntN (IntN, unIntN), WordN (WordN)) -import Grisette.Core.Data.Class.ModelOps - ( ModelOps (emptyModel, insertValue), - ) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors - ( conTerm, - symTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.SomeTerm - ( SomeTerm (SomeTerm), - ) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term - ( SomeTypedSymbol (SomeTypedSymbol), - SupportedPrim (withPrim), - Term - ( AbsNumTerm, - AddNumTerm, - AndBitsTerm, - AndTerm, - BVConcatTerm, - BVExtendTerm, - BVSelectTerm, - BinaryTerm, - ComplementBitsTerm, - ConTerm, - DivBoundedIntegralTerm, - DivIntegralTerm, - EqvTerm, - GeneralFunApplyTerm, - ITETerm, - LENumTerm, - LTNumTerm, - ModBoundedIntegralTerm, - ModIntegralTerm, - NotTerm, - OrBitsTerm, - OrTerm, - QuotBoundedIntegralTerm, - QuotIntegralTerm, - RemBoundedIntegralTerm, - RemIntegralTerm, - RotateLeftTerm, - RotateRightTerm, - ShiftLeftTerm, - ShiftRightTerm, - SignumNumTerm, - SymTerm, - TabularFunApplyTerm, - TernaryTerm, - TimesNumTerm, - ToSignedTerm, - ToUnsignedTerm, - UMinusNumTerm, - UnaryTerm, - XorBitsTerm - ), - TypedSymbol (IndexedSymbol), - buildGeneralFun, - someTypedSymbol, - withSymbolSupported, - type (-->), - ) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermUtils - ( introSupportedPrimConstraint, - ) -import Grisette.IR.SymPrim.Data.Prim.Model as PM (Model) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool - ( pevalEqvTerm, - pevalITETerm, - ) -import Grisette.IR.SymPrim.Data.TabularFun - ( type (=->) (TabularFun), - ) -import Grisette.Utils.Parameterized - ( KnownProof (KnownProof), - LeqProof (LeqProof), - unsafeAxiom, - unsafeKnownProof, - unsafeLeqProof, - withKnownProof, - ) -import qualified Type.Reflection as R - -translateTypeError :: (HasCallStack) => R.TypeRep a -> b -translateTypeError ta = - error $ - "Don't know how to translate the type " ++ show ta ++ " to SMT" - -translateUnaryError :: (HasCallStack) => String -> R.TypeRep a -> R.TypeRep b -> c -translateUnaryError op ta tb = - error $ - "Don't know how to translate the op " - ++ show op - ++ " :: " - ++ show ta - ++ " -> " - ++ show tb - ++ " to SMT" - -translateBinaryError :: (HasCallStack) => String -> R.TypeRep a -> R.TypeRep b -> R.TypeRep c -> d -translateBinaryError op ta tb tc = - error $ - "Don't know how to translate the op " - ++ show op - ++ " :: " - ++ show ta - ++ " -> " - ++ show tb - ++ " -> " - ++ show tc - ++ " to SMT" - -translateTernaryError :: (HasCallStack) => String -> R.TypeRep a -> R.TypeRep b -> R.TypeRep c -> R.TypeRep d -> e -translateTernaryError op ta tb tc td = - error $ - "Don't know how to translate the op " - ++ show op - ++ " :: " - ++ show ta - ++ " -> " - ++ show tb - ++ " -> " - ++ show tc - ++ " -> " - ++ show td - ++ " to SMT" - -lowerValue :: - forall integerBitWidth a. - (SupportedPrim a, Typeable a) => - GrisetteSMTConfig integerBitWidth -> - a -> - TermTy integerBitWidth a -lowerValue config@ResolvedConfig {} v = - case R.typeRep @a of - BoolType -> if v then SBV.sTrue else SBV.sFalse - IntegerType -> fromInteger v - SignedBVType _ -> case v of - IntN x -> fromInteger x - UnsignedBVType _ -> case v of - WordN x -> fromInteger x - TFunType (l :: a1) (r :: a2) -> - case ((config, l), (config, r)) of - (ResolvedSimpleType, ResolvedMergeableType) -> - lowerTFunCon config v - _ -> translateTypeError (R.typeRep @a) - _ -> translateTypeError (R.typeRep @a) -lowerValue _ _ = translateTypeError (R.typeRep @a) - -lowerTFunCon :: - forall integerBitWidth a b. - (SupportedPrim a, SupportedPrim b, SBV.EqSymbolic (TermTy integerBitWidth a), SBV.Mergeable (TermTy integerBitWidth b)) => - GrisetteSMTConfig integerBitWidth -> - (a =-> b) -> - (TermTy integerBitWidth a -> TermTy integerBitWidth b) -lowerTFunCon config@ResolvedConfig {} (TabularFun l d) = go l d - where - go [] d _ = lowerValue config d - go ((x, r) : xs) d v = SBV.ite (lowerValue config x SBV..== v) (lowerValue config r) (go xs d v) -lowerTFunCon _ TabularFun {} = translateTypeError (R.typeRep @a) - -buildUTFun11 :: - forall integerBitWidth s1 s2 a. - (SupportedPrim a, SupportedPrim s1, SupportedPrim s2) => - GrisetteSMTConfig integerBitWidth -> - R.TypeRep s1 -> - R.TypeRep s2 -> - Term a -> - SymBiMap -> - Maybe (SymBiMap, TermTy integerBitWidth (s1 =-> s2)) -buildUTFun11 config ta tb term@(SymTerm _ ts) m = case ((config, ta), (config, tb)) of - (ResolvedSimpleType, ResolvedSimpleType) -> - let name = "ufunc_" ++ show (sizeBiMap m) - f = SBV.uninterpret @(TermTy integerBitWidth s1 -> TermTy integerBitWidth s2) name - in Just (addBiMap (SomeTerm term) (toDyn f) name (someTypedSymbol ts) m, f) - _ -> Nothing -buildUTFun11 _ _ _ _ _ = error "Should only be called on SymTerm" - -buildUTFun111 :: - forall integerBitWidth s1 s2 s3 a. - (SupportedPrim a, SupportedPrim s1, SupportedPrim s2, SupportedPrim s3) => - GrisetteSMTConfig integerBitWidth -> - R.TypeRep s1 -> - R.TypeRep s2 -> - R.TypeRep s3 -> - Term a -> - SymBiMap -> - Maybe (SymBiMap, TermTy integerBitWidth (s1 =-> s2 =-> s3)) -buildUTFun111 config ta tb tc term@(SymTerm _ ts) m = - case ((config, ta), (config, tb), (config, tc)) of - (ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType) -> - let name = "ufunc_" ++ show (sizeBiMap m) - f = - SBV.uninterpret @(TermTy integerBitWidth s1 -> TermTy integerBitWidth s2 -> TermTy integerBitWidth s3) - name - in Just (addBiMap (SomeTerm term) (toDyn f) name (someTypedSymbol ts) m, f) - _ -> Nothing -buildUTFun111 _ _ _ _ _ _ = error "Should only be called on SymTerm" - -buildUTFun1111 :: - forall integerBitWidth s1 s2 s3 s4 a. - (SupportedPrim a, SupportedPrim s1, SupportedPrim s2, SupportedPrim s3, SupportedPrim s4) => - GrisetteSMTConfig integerBitWidth -> - R.TypeRep s1 -> - R.TypeRep s2 -> - R.TypeRep s3 -> - R.TypeRep s4 -> - Term a -> - SymBiMap -> - Maybe (SymBiMap, TermTy integerBitWidth (s1 =-> s2 =-> s3 =-> s4)) -buildUTFun1111 config ta tb tc td term@(SymTerm _ ts) m = - case ((config, ta), (config, tb), (config, tc), (config, td)) of - (ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType) -> - let name = "ufunc_" ++ show (sizeBiMap m) - f = - SBV.uninterpret @(TermTy integerBitWidth s1 -> TermTy integerBitWidth s2 -> TermTy integerBitWidth s3 -> TermTy integerBitWidth s4) - name - in Just (addBiMap (SomeTerm term) (toDyn f) name (someTypedSymbol ts) m, f) - _ -> Nothing -buildUTFun1111 _ _ _ _ _ _ _ = error "Should only be called on SymTerm" - -buildUTFun11111 :: - forall integerBitWidth s1 s2 s3 s4 s5 a. - (SupportedPrim a, SupportedPrim s1, SupportedPrim s2, SupportedPrim s3, SupportedPrim s4, SupportedPrim s5) => - GrisetteSMTConfig integerBitWidth -> - R.TypeRep s1 -> - R.TypeRep s2 -> - R.TypeRep s3 -> - R.TypeRep s4 -> - R.TypeRep s5 -> - Term a -> - SymBiMap -> - Maybe (SymBiMap, TermTy integerBitWidth (s1 =-> s2 =-> s3 =-> s4 =-> s5)) -buildUTFun11111 config ta tb tc td te term@(SymTerm _ ts) m = - case ((config, ta), (config, tb), (config, tc), (config, td), (config, te)) of - (ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType) -> - let name = "ufunc_" ++ show (sizeBiMap m) - f = - SBV.uninterpret @(TermTy integerBitWidth (s1 =-> s2 =-> s3 =-> s4 =-> s5)) - name - in Just (addBiMap (SomeTerm term) (toDyn f) name (someTypedSymbol ts) m, f) - _ -> Nothing -buildUTFun11111 _ _ _ _ _ _ _ _ = error "Should only be called on SymTerm" - -buildUTFun111111 :: - forall integerBitWidth s1 s2 s3 s4 s5 s6 a. - ( SupportedPrim a, - SupportedPrim s1, - SupportedPrim s2, - SupportedPrim s3, - SupportedPrim s4, - SupportedPrim s5, - SupportedPrim s6 - ) => - GrisetteSMTConfig integerBitWidth -> - R.TypeRep s1 -> - R.TypeRep s2 -> - R.TypeRep s3 -> - R.TypeRep s4 -> - R.TypeRep s5 -> - R.TypeRep s6 -> - Term a -> - SymBiMap -> - Maybe (SymBiMap, TermTy integerBitWidth (s1 =-> s2 =-> s3 =-> s4 =-> s5 =-> s6)) -buildUTFun111111 config ta tb tc td te tf term@(SymTerm _ ts) m = - case ((config, ta), (config, tb), (config, tc), (config, td), (config, te), (config, tf)) of - (ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType) -> - let name = "ufunc_" ++ show (sizeBiMap m) - f = - SBV.uninterpret @(TermTy integerBitWidth (s1 =-> s2 =-> s3 =-> s4 =-> s5 =-> s6)) - name - in Just (addBiMap (SomeTerm term) (toDyn f) name (someTypedSymbol ts) m, f) - _ -> Nothing -buildUTFun111111 _ _ _ _ _ _ _ _ _ = error "Should only be called on SymTerm" - -buildUTFun1111111 :: - forall integerBitWidth s1 s2 s3 s4 s5 s6 s7 a. - ( SupportedPrim a, - SupportedPrim s1, - SupportedPrim s2, - SupportedPrim s3, - SupportedPrim s4, - SupportedPrim s5, - SupportedPrim s6, - SupportedPrim s7 - ) => - GrisetteSMTConfig integerBitWidth -> - R.TypeRep s1 -> - R.TypeRep s2 -> - R.TypeRep s3 -> - R.TypeRep s4 -> - R.TypeRep s5 -> - R.TypeRep s6 -> - R.TypeRep s7 -> - Term a -> - SymBiMap -> - Maybe (SymBiMap, TermTy integerBitWidth (s1 =-> s2 =-> s3 =-> s4 =-> s5 =-> s6 =-> s7)) -buildUTFun1111111 config ta tb tc td te tf tg term@(SymTerm _ ts) m = - case ((config, ta), (config, tb), (config, tc), (config, td), (config, te), (config, tf), (config, tg)) of - (ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType) -> - let name = "ufunc_" ++ show (sizeBiMap m) - f = - SBV.uninterpret @(TermTy integerBitWidth (s1 =-> s2 =-> s3 =-> s4 =-> s5 =-> s6 =-> s7)) - name - in Just (addBiMap (SomeTerm term) (toDyn f) name (someTypedSymbol ts) m, f) - _ -> Nothing -buildUTFun1111111 _ _ _ _ _ _ _ _ _ _ = error "Should only be called on SymTerm" - -buildUTFun11111111 :: - forall integerBitWidth s1 s2 s3 s4 s5 s6 s7 s8 a. - ( SupportedPrim a, - SupportedPrim s1, - SupportedPrim s2, - SupportedPrim s3, - SupportedPrim s4, - SupportedPrim s5, - SupportedPrim s6, - SupportedPrim s7, - SupportedPrim s8 - ) => - GrisetteSMTConfig integerBitWidth -> - R.TypeRep s1 -> - R.TypeRep s2 -> - R.TypeRep s3 -> - R.TypeRep s4 -> - R.TypeRep s5 -> - R.TypeRep s6 -> - R.TypeRep s7 -> - R.TypeRep s8 -> - Term a -> - SymBiMap -> - Maybe (SymBiMap, TermTy integerBitWidth (s1 =-> s2 =-> s3 =-> s4 =-> s5 =-> s6 =-> s7 =-> s8)) -buildUTFun11111111 config ta tb tc td te tf tg th term@(SymTerm _ ts) m = - case ((config, ta), (config, tb), (config, tc), (config, td), (config, te), (config, tf), (config, tg), (config, th)) of - (ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType) -> - let name = "ufunc_" ++ show (sizeBiMap m) - f = - SBV.uninterpret @(TermTy integerBitWidth (s1 =-> s2 =-> s3 =-> s4 =-> s5 =-> s6 =-> s7 =-> s8)) - name - in Just (addBiMap (SomeTerm term) (toDyn f) name (someTypedSymbol ts) m, f) - _ -> Nothing -buildUTFun11111111 _ _ _ _ _ _ _ _ _ _ _ = error "Should only be called on SymTerm" - -buildUGFun11 :: - forall integerBitWidth s1 s2 a. - (SupportedPrim a, SupportedPrim s1, SupportedPrim s2) => - GrisetteSMTConfig integerBitWidth -> - R.TypeRep s1 -> - R.TypeRep s2 -> - Term a -> - SymBiMap -> - Maybe (SymBiMap, TermTy integerBitWidth (s1 --> s2)) -buildUGFun11 config ta tb term@(SymTerm _ ts) m = case ((config, ta), (config, tb)) of - (ResolvedSimpleType, ResolvedSimpleType) -> - let name = "ufunc_" ++ show (sizeBiMap m) - f = SBV.uninterpret @(TermTy integerBitWidth s1 -> TermTy integerBitWidth s2) name - in Just (addBiMap (SomeTerm term) (toDyn f) name (someTypedSymbol ts) m, f) - _ -> Nothing -buildUGFun11 _ _ _ _ _ = error "Should only be called on SymTerm" - -buildUGFun111 :: - forall integerBitWidth s1 s2 s3 a. - (SupportedPrim a, SupportedPrim s1, SupportedPrim s2, SupportedPrim s3) => - GrisetteSMTConfig integerBitWidth -> - R.TypeRep s1 -> - R.TypeRep s2 -> - R.TypeRep s3 -> - Term a -> - SymBiMap -> - Maybe (SymBiMap, TermTy integerBitWidth (s1 --> s2 --> s3)) -buildUGFun111 config ta tb tc term@(SymTerm _ ts) m = case ((config, ta), (config, tb), (config, tc)) of - (ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType) -> - let name = "ufunc_" ++ show (sizeBiMap m) - f = - SBV.uninterpret @(TermTy integerBitWidth s1 -> TermTy integerBitWidth s2 -> TermTy integerBitWidth s3) - name - in Just (addBiMap (SomeTerm term) (toDyn f) name (someTypedSymbol ts) m, f) - _ -> Nothing -buildUGFun111 _ _ _ _ _ _ = error "Should only be called on SymTerm" - -buildUGFun1111 :: - forall integerBitWidth s1 s2 s3 s4 a. - (SupportedPrim a, SupportedPrim s1, SupportedPrim s2, SupportedPrim s3, SupportedPrim s4) => - GrisetteSMTConfig integerBitWidth -> - R.TypeRep s1 -> - R.TypeRep s2 -> - R.TypeRep s3 -> - R.TypeRep s4 -> - Term a -> - SymBiMap -> - Maybe (SymBiMap, TermTy integerBitWidth (s1 --> s2 --> s3 --> s4)) -buildUGFun1111 config ta tb tc td term@(SymTerm _ ts) m = - case ((config, ta), (config, tb), (config, tc), (config, td)) of - (ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType) -> - let name = "ufunc_" ++ show (sizeBiMap m) - f = - SBV.uninterpret @(TermTy integerBitWidth s1 -> TermTy integerBitWidth s2 -> TermTy integerBitWidth s3 -> TermTy integerBitWidth s4) - name - in Just (addBiMap (SomeTerm term) (toDyn f) name (someTypedSymbol ts) m, f) - _ -> Nothing -buildUGFun1111 _ _ _ _ _ _ _ = error "Should only be called on SymTerm" - -buildUGFun11111 :: - forall integerBitWidth s1 s2 s3 s4 s5 a. - (SupportedPrim a, SupportedPrim s1, SupportedPrim s2, SupportedPrim s3, SupportedPrim s4, SupportedPrim s5) => - GrisetteSMTConfig integerBitWidth -> - R.TypeRep s1 -> - R.TypeRep s2 -> - R.TypeRep s3 -> - R.TypeRep s4 -> - R.TypeRep s5 -> - Term a -> - SymBiMap -> - Maybe (SymBiMap, TermTy integerBitWidth (s1 --> s2 --> s3 --> s4 --> s5)) -buildUGFun11111 config ta tb tc td te term@(SymTerm _ ts) m = - case ((config, ta), (config, tb), (config, tc), (config, td), (config, te)) of - (ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType) -> - let name = "ufunc_" ++ show (sizeBiMap m) - f = - SBV.uninterpret @(TermTy integerBitWidth (s1 --> s2 --> s3 --> s4 --> s5)) - name - in Just (addBiMap (SomeTerm term) (toDyn f) name (someTypedSymbol ts) m, f) - _ -> Nothing -buildUGFun11111 _ _ _ _ _ _ _ _ = error "Should only be called on SymTerm" - -buildUGFun111111 :: - forall integerBitWidth s1 s2 s3 s4 s5 s6 a. - ( SupportedPrim a, - SupportedPrim s1, - SupportedPrim s2, - SupportedPrim s3, - SupportedPrim s4, - SupportedPrim s5, - SupportedPrim s6 - ) => - GrisetteSMTConfig integerBitWidth -> - R.TypeRep s1 -> - R.TypeRep s2 -> - R.TypeRep s3 -> - R.TypeRep s4 -> - R.TypeRep s5 -> - R.TypeRep s6 -> - Term a -> - SymBiMap -> - Maybe (SymBiMap, TermTy integerBitWidth (s1 --> s2 --> s3 --> s4 --> s5 --> s6)) -buildUGFun111111 config ta tb tc td te tf term@(SymTerm _ ts) m = - case ((config, ta), (config, tb), (config, tc), (config, td), (config, te), (config, tf)) of - (ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType) -> - let name = "ufunc_" ++ show (sizeBiMap m) - f = - SBV.uninterpret @(TermTy integerBitWidth (s1 --> s2 --> s3 --> s4 --> s5 --> s6)) - name - in Just (addBiMap (SomeTerm term) (toDyn f) name (someTypedSymbol ts) m, f) - _ -> Nothing -buildUGFun111111 _ _ _ _ _ _ _ _ _ = error "Should only be called on SymTerm" - -buildUGFun1111111 :: - forall integerBitWidth s1 s2 s3 s4 s5 s6 s7 a. - ( SupportedPrim a, - SupportedPrim s1, - SupportedPrim s2, - SupportedPrim s3, - SupportedPrim s4, - SupportedPrim s5, - SupportedPrim s6, - SupportedPrim s7 - ) => - GrisetteSMTConfig integerBitWidth -> - R.TypeRep s1 -> - R.TypeRep s2 -> - R.TypeRep s3 -> - R.TypeRep s4 -> - R.TypeRep s5 -> - R.TypeRep s6 -> - R.TypeRep s7 -> - Term a -> - SymBiMap -> - Maybe (SymBiMap, TermTy integerBitWidth (s1 --> s2 --> s3 --> s4 --> s5 --> s6 --> s7)) -buildUGFun1111111 config ta tb tc td te tf tg term@(SymTerm _ ts) m = - case ((config, ta), (config, tb), (config, tc), (config, td), (config, te), (config, tf), (config, tg)) of - (ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType) -> - let name = "ufunc_" ++ show (sizeBiMap m) - f = - SBV.uninterpret @(TermTy integerBitWidth (s1 --> s2 --> s3 --> s4 --> s5 --> s6 --> s7)) - name - in Just (addBiMap (SomeTerm term) (toDyn f) name (someTypedSymbol ts) m, f) - _ -> Nothing -buildUGFun1111111 _ _ _ _ _ _ _ _ _ _ = error "Should only be called on SymTerm" - -buildUGFun11111111 :: - forall integerBitWidth s1 s2 s3 s4 s5 s6 s7 s8 a. - ( SupportedPrim a, - SupportedPrim s1, - SupportedPrim s2, - SupportedPrim s3, - SupportedPrim s4, - SupportedPrim s5, - SupportedPrim s6, - SupportedPrim s7, - SupportedPrim s8 - ) => - GrisetteSMTConfig integerBitWidth -> - R.TypeRep s1 -> - R.TypeRep s2 -> - R.TypeRep s3 -> - R.TypeRep s4 -> - R.TypeRep s5 -> - R.TypeRep s6 -> - R.TypeRep s7 -> - R.TypeRep s8 -> - Term a -> - SymBiMap -> - Maybe (SymBiMap, TermTy integerBitWidth (s1 --> s2 --> s3 --> s4 --> s5 --> s6 --> s7 --> s8)) -buildUGFun11111111 config ta tb tc td te tf tg th term@(SymTerm _ ts) m = - case ((config, ta), (config, tb), (config, tc), (config, td), (config, te), (config, tf), (config, tg), (config, th)) of - (ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType, ResolvedSimpleType) -> - let name = "ufunc_" ++ show (sizeBiMap m) - f = - SBV.uninterpret @(TermTy integerBitWidth (s1 --> s2 --> s3 --> s4 --> s5 --> s6 --> s7 --> s8)) - name - in Just (addBiMap (SomeTerm term) (toDyn f) name (someTypedSymbol ts) m, f) - _ -> Nothing -buildUGFun11111111 _ _ _ _ _ _ _ _ _ _ _ = error "Should only be called on SymTerm" - -lowerSinglePrimUFun :: - forall integerBitWidth a. - GrisetteSMTConfig integerBitWidth -> - Term a -> - SymBiMap -> - Maybe (SymBiMap, TermTy integerBitWidth a) -lowerSinglePrimUFun config t@(SymTerm _ _) m = - case R.typeRep @a of - TFun8Type t1 t2 t3 t4 t5 t6 t7 t8 -> buildUTFun11111111 config t1 t2 t3 t4 t5 t6 t7 t8 t m - TFun7Type t1 t2 t3 t4 t5 t6 t7 -> buildUTFun1111111 config t1 t2 t3 t4 t5 t6 t7 t m - TFun6Type t1 t2 t3 t4 t5 t6 -> buildUTFun111111 config t1 t2 t3 t4 t5 t6 t m - TFun5Type t1 t2 t3 t4 t5 -> buildUTFun11111 config t1 t2 t3 t4 t5 t m - TFun4Type t1 t2 t3 t4 -> buildUTFun1111 config t1 t2 t3 t4 t m - TFun3Type t1 t2 t3 -> buildUTFun111 config t1 t2 t3 t m - TFunType t1 t2 -> buildUTFun11 config t1 t2 t m - GFun8Type t1 t2 t3 t4 t5 t6 t7 t8 -> buildUGFun11111111 config t1 t2 t3 t4 t5 t6 t7 t8 t m - GFun7Type t1 t2 t3 t4 t5 t6 t7 -> buildUGFun1111111 config t1 t2 t3 t4 t5 t6 t7 t m - GFun6Type t1 t2 t3 t4 t5 t6 -> buildUGFun111111 config t1 t2 t3 t4 t5 t6 t m - GFun5Type t1 t2 t3 t4 t5 -> buildUGFun11111 config t1 t2 t3 t4 t5 t m - GFun4Type t1 t2 t3 t4 -> buildUGFun1111 config t1 t2 t3 t4 t m - GFun3Type t1 t2 t3 -> buildUGFun111 config t1 t2 t3 t m - GFunType t1 t2 -> buildUGFun11 config t1 t2 t m - _ -> Nothing -lowerSinglePrimUFun _ _ _ = error "Should not call this function" - -class (Monad m) => SBVFreshMonad m where - sbvFresh :: (SBV.SymVal a) => String -> m (SBV.SBV a) - -instance (MonadIO m) => SBVFreshMonad (SBVT.SymbolicT m) where - sbvFresh = SBVT.free - -instance (MonadIO m) => SBVFreshMonad (SBVTC.QueryT m) where - sbvFresh = SBVTC.freshVar - -instance (SBVFreshMonad m) => SBVFreshMonad (ReaderT r m) where - sbvFresh = lift . sbvFresh - -instance (SBVFreshMonad m) => SBVFreshMonad (StateT s m) where - sbvFresh = lift . sbvFresh - -lowerUnaryTerm :: - forall integerBitWidth a a1 x x1 m. - (Typeable x1, a1 ~ TermTy integerBitWidth a, SupportedPrim x, HasCallStack, SBVFreshMonad m) => - GrisetteSMTConfig integerBitWidth -> - Term x -> - Term a -> - (a1 -> x1) -> - SymBiMap -> - m (SymBiMap, x1) -lowerUnaryTerm config orig t1 f m = do - (m1, l1) <- lowerSinglePrimCached config t1 m - let g = f l1 - return (addBiMapIntermediate (SomeTerm orig) (toDyn g) m1, g) - -lowerBinaryTerm :: - forall integerBitWidth a b a1 b1 x x1 m. - (Typeable x1, a1 ~ TermTy integerBitWidth a, b1 ~ TermTy integerBitWidth b, SupportedPrim x, HasCallStack, SBVFreshMonad m) => - GrisetteSMTConfig integerBitWidth -> - Term x -> - Term a -> - Term b -> - (a1 -> b1 -> x1) -> - SymBiMap -> - m (SymBiMap, x1) -lowerBinaryTerm config orig t1 t2 f m = do - (m1, l1) <- lowerSinglePrimCached config t1 m - (m2, l2) <- lowerSinglePrimCached config t2 m1 - let g = f l1 l2 - return (addBiMapIntermediate (SomeTerm orig) (toDyn g) m2, g) - -lowerSinglePrimCached :: - forall integerBitWidth a m. - (HasCallStack, SBVFreshMonad m) => - GrisetteSMTConfig integerBitWidth -> - Term a -> - SymBiMap -> - m (SymBiMap, TermTy integerBitWidth a) -lowerSinglePrimCached config t m = - introSupportedPrimConstraint t $ - case (config, R.typeRep @a) of - ResolvedDeepType -> - case lookupTerm (SomeTerm t) m of - Just x -> return (m, fromDyn x undefined) - Nothing -> lowerSinglePrimImpl config t m - _ -> translateTypeError (R.typeRep @a) - -lowerSinglePrim :: - forall integerBitWidth a m. - (HasCallStack, SBVFreshMonad m) => - GrisetteSMTConfig integerBitWidth -> - Term a -> - m (SymBiMap, TermTy integerBitWidth a) -lowerSinglePrim config t = lowerSinglePrimCached config t emptySymBiMap - -lowerSinglePrimImpl :: - forall integerBitWidth a m. - (HasCallStack, SBVFreshMonad m) => - GrisetteSMTConfig integerBitWidth -> - Term a -> - SymBiMap -> - m (SymBiMap, TermTy integerBitWidth a) -lowerSinglePrimImpl config@ResolvedConfig {} (ConTerm _ v) m = return (m, lowerValue config v) -lowerSinglePrimImpl config t@(SymTerm _ ts) m = - fromMaybe errorMsg $ asum [simple, ufunc] - where - errorMsg :: forall x. x - errorMsg = translateTypeError (R.typeRep @a) - simple :: Maybe (m (SymBiMap, TermTy integerBitWidth a)) - simple = case (config, R.typeRep @a) of - ResolvedSimpleType -> Just $ do - let name = show ts - (g :: TermTy integerBitWidth a) <- sbvFresh name - return (addBiMap (SomeTerm t) (toDyn g) name (someTypedSymbol ts) m, g) - _ -> Nothing - ufunc :: (Maybe (m (SymBiMap, TermTy integerBitWidth a))) - ufunc = return <$> lowerSinglePrimUFun config t m -lowerSinglePrimImpl _ (UnaryTerm _ op (_ :: Term x)) _ = errorMsg - where - errorMsg :: forall t1. t1 - errorMsg = translateUnaryError (show op) (R.typeRep @x) (R.typeRep @a) -lowerSinglePrimImpl _ (BinaryTerm _ op (_ :: Term x) (_ :: Term y)) _ = errorMsg - where - errorMsg :: forall t1. t1 - errorMsg = translateBinaryError (show op) (R.typeRep @x) (R.typeRep @y) (R.typeRep @a) -lowerSinglePrimImpl ResolvedConfig {} (TernaryTerm _ op (_ :: Term x) (_ :: Term y) (_ :: Term z)) _ = errorMsg - where - errorMsg :: forall t1. t1 - errorMsg = translateTernaryError (show op) (R.typeRep @x) (R.typeRep @y) (R.typeRep @z) (R.typeRep @a) -lowerSinglePrimImpl config t@(NotTerm _ arg) m = lowerUnaryTerm config t arg SBV.sNot m -lowerSinglePrimImpl config t@(OrTerm _ arg1 arg2) m = lowerBinaryTerm config t arg1 arg2 (SBV..||) m -lowerSinglePrimImpl config t@(AndTerm _ arg1 arg2) m = lowerBinaryTerm config t arg1 arg2 (SBV..&&) m -lowerSinglePrimImpl config t@(EqvTerm _ (arg1 :: Term x) arg2) m = - case (config, R.typeRep @x) of - ResolvedSimpleType -> lowerBinaryTerm config t arg1 arg2 (SBV..==) m - _ -> translateBinaryError "(==)" (R.typeRep @x) (R.typeRep @x) (R.typeRep @a) -lowerSinglePrimImpl config t@(ITETerm _ cond arg1 arg2) m = - case (config, R.typeRep @a) of - ResolvedMergeableType -> do - (m1, l1) <- lowerSinglePrimCached config cond m - (m2, l2) <- lowerSinglePrimCached config arg1 m1 - (m3, l3) <- lowerSinglePrimCached config arg2 m2 - let g = SBV.ite l1 l2 l3 - return (addBiMapIntermediate (SomeTerm t) (toDyn g) m3, g) - _ -> translateBinaryError "ite" (R.typeRep @Bool) (R.typeRep @a) (R.typeRep @a) (R.typeRep @a) -lowerSinglePrimImpl config t@(AddNumTerm _ arg1 arg2) m = - case (config, R.typeRep @a) of - ResolvedNumType -> lowerBinaryTerm config t arg1 arg2 (+) m - _ -> translateBinaryError "(+)" (R.typeRep @a) (R.typeRep @a) (R.typeRep @a) -lowerSinglePrimImpl config t@(UMinusNumTerm _ arg) m = - case (config, R.typeRep @a) of - ResolvedNumType -> lowerUnaryTerm config t arg negate m - _ -> translateUnaryError "negate" (R.typeRep @a) (R.typeRep @a) -lowerSinglePrimImpl config t@(TimesNumTerm _ arg1 arg2) m = - case (config, R.typeRep @a) of - ResolvedNumType -> lowerBinaryTerm config t arg1 arg2 (*) m - _ -> translateBinaryError "(*)" (R.typeRep @a) (R.typeRep @a) (R.typeRep @a) -lowerSinglePrimImpl config t@(AbsNumTerm _ arg) m = - case (config, R.typeRep @a) of - ResolvedNumType -> lowerUnaryTerm config t arg abs m - _ -> translateUnaryError "abs" (R.typeRep @a) (R.typeRep @a) -lowerSinglePrimImpl config t@(SignumNumTerm _ arg) m = - case (config, R.typeRep @a) of - ResolvedNumType -> lowerUnaryTerm config t arg signum m - _ -> translateUnaryError "signum" (R.typeRep @a) (R.typeRep @a) -lowerSinglePrimImpl config t@(LTNumTerm _ (arg1 :: Term arg) arg2) m = - case (config, R.typeRep @arg) of - ResolvedNumOrdType -> lowerBinaryTerm config t arg1 arg2 (SBV..<) m - _ -> translateBinaryError "(<)" (R.typeRep @a) (R.typeRep @a) (R.typeRep @Bool) -lowerSinglePrimImpl config t@(LENumTerm _ (arg1 :: Term arg) arg2) m = - case (config, R.typeRep @arg) of - ResolvedNumOrdType -> lowerBinaryTerm config t arg1 arg2 (SBV..<=) m - _ -> translateBinaryError "(<=)" (R.typeRep @a) (R.typeRep @a) (R.typeRep @Bool) -lowerSinglePrimImpl config t@(AndBitsTerm _ arg1 arg2) m = - case (config, R.typeRep @a) of - ResolvedBitsType -> lowerBinaryTerm config t arg1 arg2 (.&.) m - _ -> translateBinaryError "(.&.)" (R.typeRep @a) (R.typeRep @a) (R.typeRep @a) -lowerSinglePrimImpl config t@(OrBitsTerm _ arg1 arg2) m = - case (config, R.typeRep @a) of - ResolvedBitsType -> lowerBinaryTerm config t arg1 arg2 (.|.) m - _ -> translateBinaryError "(.|.)" (R.typeRep @a) (R.typeRep @a) (R.typeRep @a) -lowerSinglePrimImpl config t@(XorBitsTerm _ arg1 arg2) m = - case (config, R.typeRep @a) of - ResolvedBitsType -> lowerBinaryTerm config t arg1 arg2 xor m - _ -> translateBinaryError "xor" (R.typeRep @a) (R.typeRep @a) (R.typeRep @a) -lowerSinglePrimImpl config t@(ComplementBitsTerm _ arg) m = - case (config, R.typeRep @a) of - ResolvedBitsType -> lowerUnaryTerm config t arg complement m - _ -> translateUnaryError "complement" (R.typeRep @a) (R.typeRep @a) -lowerSinglePrimImpl config t@(ShiftLeftTerm _ arg n) m = - case (config, R.typeRep @a) of - ResolvedBitsType -> lowerBinaryTerm config t arg n sShiftLeft m - _ -> translateBinaryError "shiftLeft" (R.typeRep @a) (R.typeRep @Int) (R.typeRep @a) -lowerSinglePrimImpl config t@(ShiftRightTerm _ arg n) m = - case (config, R.typeRep @a) of - ResolvedBitsType -> lowerBinaryTerm config t arg n sShiftRight m - _ -> translateBinaryError "shiftRight" (R.typeRep @a) (R.typeRep @Int) (R.typeRep @a) --- SBV's rotateLeft and rotateRight are broken for signed values, so we have to --- do this --- https://github.com/LeventErkok/sbv/issues/673 -lowerSinglePrimImpl config t@(RotateLeftTerm _ arg n) m = - case (config, R.typeRep @a) of - (_, SignedBVType (Proxy :: Proxy n)) -> - lowerBinaryTerm - config - t - arg - n - ( \x y -> - SBV.sFromIntegral $ - sRotateLeft - (SBV.sFromIntegral x :: SBV.SWord n) - (SBV.sFromIntegral y :: SBV.SWord n) - ) - m - ResolvedBitsType -> lowerBinaryTerm config t arg n sRotateLeft m - _ -> translateBinaryError "rotateLeft" (R.typeRep @a) (R.typeRep @Int) (R.typeRep @a) -lowerSinglePrimImpl config t@(RotateRightTerm _ arg n) m = - case (config, R.typeRep @a) of - (_, SignedBVType (Proxy :: Proxy n)) -> - lowerBinaryTerm - config - t - arg - n - ( \x y -> - SBV.sFromIntegral $ - sRotateRight - (SBV.sFromIntegral x :: SBV.SWord n) - (SBV.sFromIntegral y :: SBV.SWord n) - ) - m - ResolvedBitsType -> lowerBinaryTerm config t arg n sRotateRight m - _ -> translateBinaryError "rotateRight" (R.typeRep @a) (R.typeRep @Int) (R.typeRep @a) -lowerSinglePrimImpl config t@(ToSignedTerm _ (bv :: Term x)) m = - case (R.typeRep @a, R.typeRep @x) of - (SignedBVType (_ :: Proxy na), UnsignedBVType (_ :: Proxy nx)) -> - case R.eqTypeRep (R.typeRep @na) (R.typeRep @nx) of - Just R.HRefl -> - lowerUnaryTerm config t bv SBV.sFromIntegral m - _ -> translateUnaryError "u2s" (R.typeRep @x) (R.typeRep @a) - _ -> translateUnaryError "u2s" (R.typeRep @x) (R.typeRep @a) -lowerSinglePrimImpl config t@(ToUnsignedTerm _ (bv :: Term x)) m = - case (R.typeRep @a, R.typeRep @x) of - (UnsignedBVType (_ :: Proxy na), SignedBVType (_ :: Proxy nx)) -> - case R.eqTypeRep (R.typeRep @na) (R.typeRep @nx) of - Just R.HRefl -> - lowerUnaryTerm config t bv SBV.sFromIntegral m - _ -> translateUnaryError "s2u" (R.typeRep @x) (R.typeRep @a) - _ -> translateUnaryError "s2u" (R.typeRep @x) (R.typeRep @a) -lowerSinglePrimImpl config t@(BVConcatTerm _ (bv1 :: Term x) (bv2 :: Term y)) m = - case (R.typeRep @a, R.typeRep @x, R.typeRep @y) of - (UnsignedBVType (_ :: Proxy na), UnsignedBVType (_ :: Proxy nx), UnsignedBVType (_ :: Proxy ny)) -> - case (unsafeAxiom @(nx + ny) @na) of - Refl -> lowerBinaryTerm config t bv1 bv2 (SBV.#) m - (SignedBVType (_ :: Proxy na), SignedBVType (_ :: Proxy nx), SignedBVType (_ :: Proxy ny)) -> - case (unsafeAxiom @(nx + ny) @na) of - Refl -> - lowerBinaryTerm - config - t - bv1 - bv2 - ( \(x :: SBV.SInt xn) (y :: SBV.SInt yn) -> - SBV.sFromIntegral $ - (SBV.sFromIntegral x :: SBV.SWord xn) SBV.# (SBV.sFromIntegral y :: SBV.SWord yn) - ) - m - _ -> translateBinaryError "bvconcat" (R.typeRep @x) (R.typeRep @y) (R.typeRep @a) -lowerSinglePrimImpl config t@(BVSelectTerm _ (ix :: R.TypeRep ix) w (bv :: Term x)) m = - case (R.typeRep @a, R.typeRep @x) of - (UnsignedBVType (_ :: Proxy na), UnsignedBVType (_ :: Proxy xn)) -> - withKnownProof (unsafeKnownProof @(na + ix - 1) (natVal (Proxy @na) + natVal (Proxy @ix) - 1)) $ - case ( unsafeAxiom @(na + ix - 1 - ix + 1) @na, - unsafeLeqProof @(na + ix - 1 + 1) @xn, - unsafeLeqProof @ix @(na + ix - 1) - ) of - (Refl, LeqProof, LeqProof) -> - lowerUnaryTerm config t bv (SBV.bvExtract (Proxy @(na + ix - 1)) (Proxy @ix)) m - (SignedBVType (_ :: Proxy na), SignedBVType (_ :: Proxy xn)) -> - withKnownProof (unsafeKnownProof @(na + ix - 1) (natVal (Proxy @na) + natVal (Proxy @ix) - 1)) $ - case ( unsafeAxiom @(na + ix - 1 - ix + 1) @na, - unsafeLeqProof @(na + ix - 1 + 1) @xn, - unsafeLeqProof @ix @(na + ix - 1) - ) of - (Refl, LeqProof, LeqProof) -> - lowerUnaryTerm config t bv (SBV.bvExtract (Proxy @(na + ix - 1)) (Proxy @ix)) m - _ -> translateTernaryError "bvselect" ix w (R.typeRep @x) (R.typeRep @a) -lowerSinglePrimImpl config t@(BVExtendTerm _ signed (n :: R.TypeRep n) (bv :: Term x)) m = - case (R.typeRep @a, R.typeRep @x) of - (UnsignedBVType (_ :: Proxy na), UnsignedBVType (_ :: Proxy nx)) -> - withKnownProof (unsafeKnownProof @(na - nx) (natVal (Proxy @na) - natVal (Proxy @nx))) $ - case (unsafeLeqProof @(nx + 1) @na, unsafeLeqProof @1 @(na - nx)) of - (LeqProof, LeqProof) -> - bvIsNonZeroFromGEq1 @(na - nx) $ - lowerUnaryTerm config t bv (if signed then SBV.signExtend else SBV.zeroExtend) m - (SignedBVType (_ :: Proxy na), SignedBVType (_ :: Proxy nx)) -> - withKnownProof (unsafeKnownProof @(na - nx) (natVal (Proxy @na) - natVal (Proxy @nx))) $ - case (unsafeLeqProof @(nx + 1) @na, unsafeLeqProof @1 @(na - nx)) of - (LeqProof, LeqProof) -> - bvIsNonZeroFromGEq1 @(na - nx) $ - lowerUnaryTerm - config - t - bv - ( if signed - then SBV.signExtend - else \x -> - SBV.sFromIntegral - (SBV.zeroExtend (SBV.sFromIntegral x :: SBV.SBV (SBV.WordN nx)) :: SBV.SBV (SBV.WordN na)) - ) - m - _ -> translateTernaryError "bvextend" (R.typeRep @Bool) n (R.typeRep @x) (R.typeRep @a) -lowerSinglePrimImpl config t@(TabularFunApplyTerm _ (f :: Term (b =-> a)) (arg :: Term b)) m = - case (config, R.typeRep @a) of - ResolvedDeepType -> do - (m1, l1) <- lowerSinglePrimCached config f m - (m2, l2) <- lowerSinglePrimCached config arg m1 - let g = l1 l2 - return (addBiMapIntermediate (SomeTerm t) (toDyn g) m2, g) - _ -> translateBinaryError "tabularApply" (R.typeRep @(b =-> a)) (R.typeRep @b) (R.typeRep @a) -lowerSinglePrimImpl config t@(GeneralFunApplyTerm _ (f :: Term (b --> a)) (arg :: Term b)) m = - case (config, R.typeRep @a) of - ResolvedDeepType -> do - (m1, l1) <- lowerSinglePrimCached config f m - (m2, l2) <- lowerSinglePrimCached config arg m1 - let g = l1 l2 - return (addBiMapIntermediate (SomeTerm t) (toDyn g) m2, g) - _ -> translateBinaryError "generalApply" (R.typeRep @(b --> a)) (R.typeRep @b) (R.typeRep @a) -lowerSinglePrimImpl config t@(DivIntegralTerm _ arg1 arg2) m = - case (config, R.typeRep @a) of - ResolvedSDivisibleType -> lowerBinaryTerm config t arg1 arg2 SBV.sDiv m - _ -> translateBinaryError "div" (R.typeRep @a) (R.typeRep @a) (R.typeRep @a) -lowerSinglePrimImpl config t@(ModIntegralTerm _ arg1 arg2) m = - case (config, R.typeRep @a) of - ResolvedSDivisibleType -> lowerBinaryTerm config t arg1 arg2 SBV.sMod m - _ -> translateBinaryError "mod" (R.typeRep @a) (R.typeRep @a) (R.typeRep @a) -lowerSinglePrimImpl config t@(QuotIntegralTerm _ arg1 arg2) m = - case (config, R.typeRep @a) of - ResolvedSDivisibleType -> lowerBinaryTerm config t arg1 arg2 SBV.sQuot m - _ -> translateBinaryError "quot" (R.typeRep @a) (R.typeRep @a) (R.typeRep @a) -lowerSinglePrimImpl config t@(RemIntegralTerm _ arg1 arg2) m = - case (config, R.typeRep @a) of - ResolvedSDivisibleType -> lowerBinaryTerm config t arg1 arg2 SBV.sRem m - _ -> translateBinaryError "rem" (R.typeRep @a) (R.typeRep @a) (R.typeRep @a) -lowerSinglePrimImpl config t@(DivBoundedIntegralTerm _ arg1 arg2) m = - case (config, R.typeRep @a) of - ResolvedSDivisibleType -> lowerBinaryTerm config t arg1 arg2 SBV.sDiv m - _ -> translateBinaryError "div" (R.typeRep @a) (R.typeRep @a) (R.typeRep @a) -lowerSinglePrimImpl config t@(ModBoundedIntegralTerm _ arg1 arg2) m = - case (config, R.typeRep @a) of - ResolvedSDivisibleType -> lowerBinaryTerm config t arg1 arg2 SBV.sMod m - _ -> translateBinaryError "mod" (R.typeRep @a) (R.typeRep @a) (R.typeRep @a) -lowerSinglePrimImpl config t@(QuotBoundedIntegralTerm _ arg1 arg2) m = - case (config, R.typeRep @a) of - ResolvedSDivisibleType -> lowerBinaryTerm config t arg1 arg2 SBV.sQuot m - _ -> translateBinaryError "quot" (R.typeRep @a) (R.typeRep @a) (R.typeRep @a) -lowerSinglePrimImpl config t@(RemBoundedIntegralTerm _ arg1 arg2) m = - case (config, R.typeRep @a) of - ResolvedSDivisibleType -> lowerBinaryTerm config t arg1 arg2 SBV.sRem m - _ -> translateBinaryError "rem" (R.typeRep @a) (R.typeRep @a) (R.typeRep @a) -lowerSinglePrimImpl _ _ _ = error "Should never happen" - -bvIsNonZeroFromGEq1 :: forall w r. (1 <= w) => ((SBV.BVIsNonZero w) => r) -> r -bvIsNonZeroFromGEq1 r1 = case unsafeAxiom :: w :~: 1 of - Refl -> r1 - -#if MIN_VERSION_sbv(10,3,0) -preprocessUIFuncs :: - [(String, (Bool, SBVI.SBVType, Either String ([([SBVI.CV], SBVI.CV)], SBVI.CV)))] -> - Maybe [(String, (SBVI.SBVType, ([([SBVI.CV], SBVI.CV)], SBVI.CV)))] -preprocessUIFuncs = - traverse - (\case - (a, (_, b, Right c)) -> Just (a, (b, c)) - _ -> Nothing) -#elif MIN_VERSION_sbv(10,0,0) -preprocessUIFuncs :: - [(String, (SBVI.SBVType, Either String ([([SBVI.CV], SBVI.CV)], SBVI.CV)))] -> - Maybe [(String, (SBVI.SBVType, ([([SBVI.CV], SBVI.CV)], SBVI.CV)))] -preprocessUIFuncs = - traverse - (\case - (a, (b, Right c)) -> Just (a, (b, c)) - _ -> Nothing) -#else -preprocessUIFuncs :: - [(String, (SBVI.SBVType, ([([SBVI.CV], SBVI.CV)], SBVI.CV)))] -> - Maybe [(String, (SBVI.SBVType, ([([SBVI.CV], SBVI.CV)], SBVI.CV)))] -preprocessUIFuncs = Just -#endif - -parseModel :: forall integerBitWidth. GrisetteSMTConfig integerBitWidth -> SBVI.SMTModel -> SymBiMap -> PM.Model -parseModel _ (SBVI.SMTModel _ _ assoc orguifuncs) mp = - case preprocessUIFuncs orguifuncs of - Just uifuncs -> foldr gouifuncs (foldr goassoc emptyModel assoc) uifuncs - _ -> error "SBV Failed to parse model" - where - goassoc :: (String, SBVI.CV) -> PM.Model -> PM.Model - goassoc (name, cv) m = case findStringToSymbol name mp of - Just (SomeTypedSymbol tr s) -> - insertValue s (resolveSingle tr cv) m - Nothing -> error "Bad" - resolveSingle :: R.TypeRep a -> SBVI.CV -> a - resolveSingle t (SBVI.CV SBVI.KBool (SBVI.CInteger n)) = - case R.eqTypeRep t (R.typeRep @Bool) of - Just R.HRefl -> n /= 0 - Nothing -> error "Bad type" - resolveSingle t (SBVI.CV SBVI.KUnbounded (SBVI.CInteger i)) = - case R.eqTypeRep t (R.typeRep @Integer) of - Just R.HRefl -> i - Nothing -> error "Bad type" - resolveSingle t (SBVI.CV (SBVI.KBounded _ bitWidth) (SBVI.CInteger i)) = - case R.eqTypeRep t (R.typeRep @Integer) of - Just R.HRefl -> i - _ -> case t of - R.App a (n :: R.TypeRep w) -> - case R.eqTypeRep (R.typeRepKind n) (R.typeRep @Nat) of - Just R.HRefl -> - case (unsafeKnownProof @w (fromIntegral bitWidth), unsafeLeqProof @1 @w) of - (KnownProof, LeqProof) -> - case (R.eqTypeRep a (R.typeRep @IntN), R.eqTypeRep a (R.typeRep @WordN)) of - (Just R.HRefl, _) -> - fromInteger i - (_, Just R.HRefl) -> fromInteger i - _ -> error "Bad type" - _ -> error "Bad type" - _ -> error "Bad type" - resolveSingle _ _ = error "Unknown cv" - - buildConstFun :: (SupportedPrim a, SupportedPrim r) => R.TypeRep a -> R.TypeRep r -> SBVI.CV -> a =-> r - buildConstFun _ tr v = case tr of - TFunType (ta2' :: R.TypeRep a2) (tr2' :: R.TypeRep r2) -> TabularFun [] $ buildConstFun ta2' tr2' v - _ -> TabularFun [] $ resolveSingle tr v - - goutfuncResolve :: - forall a r. - (SupportedPrim a, SupportedPrim r) => - R.TypeRep a -> - R.TypeRep r -> - ([([SBVI.CV], SBVI.CV)], SBVI.CV) -> - (a =-> r) - goutfuncResolve ta1 ta2 (l, s) = - case ta2 of - TFunType (ta2' :: R.TypeRep a2) (tr2' :: R.TypeRep r2) -> - TabularFun - (second (\r -> goutfuncResolve ta2' tr2' (r, s)) <$> partition ta1 l) - (buildConstFun ta2' tr2' s) - _ -> - TabularFun - (bimap (resolveSingle ta1 . head) (resolveSingle ta2) <$> l) - (resolveSingle ta2 s) - - gougfuncResolve :: - forall a r. - (SupportedPrim a, SupportedPrim r) => - Int -> - R.TypeRep a -> - R.TypeRep r -> - ([([SBVI.CV], SBVI.CV)], SBVI.CV) -> - (a --> r) - gougfuncResolve idx ta1 ta2 (l, s) = - case ta2 of - GFunType (ta2' :: R.TypeRep a2) (tr2' :: R.TypeRep r2) -> - let sym = IndexedSymbol "arg" idx - funs = second (\r -> gougfuncResolve (idx + 1) ta2' tr2' (r, s)) <$> partition ta1 l - def = gougfuncResolve (idx + 1) ta2' tr2' ([], s) - body = - foldl' - ( \acc (v, f) -> - pevalITETerm - (pevalEqvTerm (symTerm sym) (conTerm v)) - (conTerm f) - acc - ) - (conTerm def) - funs - in buildGeneralFun sym body - _ -> - let sym = IndexedSymbol "arg" idx - vs = bimap (resolveSingle ta1 . head) (resolveSingle ta2) <$> l - def = resolveSingle ta2 s - body = - foldl' - ( \acc (v, a) -> - pevalITETerm - (pevalEqvTerm (symTerm sym) (conTerm v)) - (conTerm a) - acc - ) - (conTerm def) - vs - in buildGeneralFun sym body - partition :: R.TypeRep a -> [([SBVI.CV], SBVI.CV)] -> [(a, [([SBVI.CV], SBVI.CV)])] - partition t = case (R.eqTypeRep t (R.typeRep @Bool), R.eqTypeRep t (R.typeRep @Integer)) of - (Just R.HRefl, _) -> partitionWithOrd . resolveFirst t - (_, Just R.HRefl) -> partitionWithOrd . resolveFirst t - _ -> case t of - R.App bv _ -> case (R.eqTypeRep bv (R.typeRep @IntN), R.eqTypeRep bv (R.typeRep @WordN)) of - (Just R.HRefl, _) -> fmap (first IntN) . partitionWithOrd . fmap (first unIntN) . resolveFirst t - (_, Just R.HRefl) -> partitionWithOrd . resolveFirst t - _ -> error "Unknown type" - _ -> error "Unknown type" - - resolveFirst :: R.TypeRep a -> [([SBVI.CV], SBVI.CV)] -> [(a, [([SBVI.CV], SBVI.CV)])] - resolveFirst tf = fmap (\case (x : xs, v) -> (resolveSingle tf x, [(xs, v)]); _ -> error "impossible") - - partitionWithOrd :: forall a. (Ord a) => [(a, [([SBVI.CV], SBVI.CV)])] -> [(a, [([SBVI.CV], SBVI.CV)])] - partitionWithOrd v = go sorted - where - sorted = sortWith fst v - go (x : x1 : xs) = - if fst x == fst x1 - then go $ (fst x, snd x ++ snd x1) : xs - else x : go (x1 : xs) - go x = x - - gouifuncs :: (String, (SBVI.SBVType, ([([SBVI.CV], SBVI.CV)], SBVI.CV))) -> PM.Model -> PM.Model - gouifuncs (name, (SBVI.SBVType _, l)) m = case findStringToSymbol name mp of - Just (SomeTypedSymbol tr s) -> withSymbolSupported s $ case tr of - t@(TFunType a r) -> R.withTypeable t $ insertValue s (goutfuncResolve a r l) m - t@(GFunType a r) -> R.withTypeable t $ insertValue s (gougfuncResolve 0 a r l) m - _ -> error "Bad" - Nothing -> error "Bad" - --- helpers - -data BVTypeContainer bv k where - BVTypeContainer :: (SBV.BVIsNonZero n, KnownNat n, 1 <= n, k ~ bv n) => Proxy n -> BVTypeContainer bv k - -signedBVTypeView :: forall t. (SupportedPrim t) => R.TypeRep t -> Maybe (BVTypeContainer IntN t) -signedBVTypeView t = case t of - R.App s (n :: R.TypeRep w) -> - case (R.eqTypeRep s (R.typeRep @IntN), R.eqTypeRep (R.typeRepKind n) (R.typeRep @Nat)) of - (Just R.HRefl, Just R.HRefl) -> - Just $ unsafeBVIsNonZero @w $ withPrim (Proxy @t) (BVTypeContainer Proxy) - _ -> Nothing - _ -> Nothing - where - unsafeBVIsNonZero :: forall w r. ((SBV.BVIsNonZero w) => r) -> r - unsafeBVIsNonZero r1 = case unsafeAxiom :: w :~: 1 of - Refl -> r1 - -pattern SignedBVType :: - forall t. - (SupportedPrim t) => - forall (n :: Nat). - (t ~~ IntN n, KnownNat n, 1 <= n, SBV.BVIsNonZero n) => - Proxy n -> - R.TypeRep t -pattern SignedBVType p <- (signedBVTypeView @t -> Just (BVTypeContainer p)) - -unsignedBVTypeView :: forall t. (SupportedPrim t) => R.TypeRep t -> Maybe (BVTypeContainer WordN t) -unsignedBVTypeView t = case t of - R.App s (n :: R.TypeRep w) -> - case (R.eqTypeRep s (R.typeRep @WordN), R.eqTypeRep (R.typeRepKind n) (R.typeRep @Nat)) of - (Just R.HRefl, Just R.HRefl) -> - Just $ unsafeBVIsNonZero @w $ withPrim (Proxy @t) (BVTypeContainer Proxy) - _ -> Nothing - _ -> Nothing - where - unsafeBVIsNonZero :: forall w r. ((SBV.BVIsNonZero w) => r) -> r - unsafeBVIsNonZero r1 = case unsafeAxiom :: w :~: 1 of - Refl -> r1 - -pattern UnsignedBVType :: - forall t. - (SupportedPrim t) => - forall (n :: Nat). - (t ~~ WordN n, KnownNat n, 1 <= n, SBV.BVIsNonZero n) => - Proxy n -> - R.TypeRep t -pattern UnsignedBVType p <- (unsignedBVTypeView @t -> Just (BVTypeContainer p)) - -data TFunTypeContainer :: forall k. k -> Type where - TFunTypeContainer :: (SupportedPrim a, SupportedPrim b) => R.TypeRep a -> R.TypeRep b -> TFunTypeContainer (a =-> b) - -tFunTypeView :: forall t. (SupportedPrim t) => R.TypeRep t -> Maybe (TFunTypeContainer t) -tFunTypeView t = case t of - R.App (R.App arr (ta2' :: R.TypeRep a2)) (tr2' :: R.TypeRep r2) -> - case R.eqTypeRep arr (R.typeRep @(=->)) of - Just R.HRefl -> Just $ withPrim (Proxy @t) $ TFunTypeContainer ta2' tr2' - Nothing -> Nothing - _ -> Nothing - -pattern TFunType :: - forall t. - (SupportedPrim t) => - forall (a :: Type) (b :: Type). - (t ~~ (a =-> b), SupportedPrim a, SupportedPrim b) => - R.TypeRep a -> - R.TypeRep b -> - R.TypeRep t -pattern TFunType a b <- - (tFunTypeView -> Just (TFunTypeContainer a b)) - where - TFunType a b = R.App (R.App (R.typeRep @(=->)) a) b - -pattern TFun3Type :: - forall t. - (SupportedPrim t) => - forall (a :: Type) (b :: Type) (c :: Type). - (t ~~ (a =-> b =-> c), SupportedPrim a, SupportedPrim b, SupportedPrim c) => - R.TypeRep a -> - R.TypeRep b -> - R.TypeRep c -> - R.TypeRep t -pattern TFun3Type a b c = TFunType a (TFunType b c) - -pattern TFun4Type :: - forall t. - (SupportedPrim t) => - forall (a :: Type) (b :: Type) (c :: Type) (d :: Type). - ( t ~~ (a =-> b =-> c =-> d), - SupportedPrim a, - SupportedPrim b, - SupportedPrim c, - SupportedPrim d - ) => - R.TypeRep a -> - R.TypeRep b -> - R.TypeRep c -> - R.TypeRep d -> - R.TypeRep t -pattern TFun4Type a b c d = TFunType a (TFunType b (TFunType c d)) - -pattern TFun5Type :: - forall t. - (SupportedPrim t) => - forall (a :: Type) (b :: Type) (c :: Type) (d :: Type) (e :: Type). - ( t ~~ (a =-> b =-> c =-> d =-> e), - SupportedPrim a, - SupportedPrim b, - SupportedPrim c, - SupportedPrim d, - SupportedPrim e - ) => - R.TypeRep a -> - R.TypeRep b -> - R.TypeRep c -> - R.TypeRep d -> - R.TypeRep e -> - R.TypeRep t -pattern TFun5Type a b c d e = - TFunType - a - ( TFunType - b - ( TFunType - c - (TFunType d e) - ) - ) - -pattern TFun6Type :: - forall t. - (SupportedPrim t) => - forall - (a :: Type) - (b :: Type) - (c :: Type) - (d :: Type) - (e :: Type) - (f :: Type). - ( t ~~ (a =-> b =-> c =-> d =-> e =-> f), - SupportedPrim a, - SupportedPrim b, - SupportedPrim c, - SupportedPrim d, - SupportedPrim e, - SupportedPrim f - ) => - R.TypeRep a -> - R.TypeRep b -> - R.TypeRep c -> - R.TypeRep d -> - R.TypeRep e -> - R.TypeRep f -> - R.TypeRep t -pattern TFun6Type a b c d e f = - TFunType - a - ( TFunType - b - ( TFunType - c - ( TFunType - d - (TFunType e f) - ) - ) - ) - -pattern TFun7Type :: - forall t. - (SupportedPrim t) => - forall - (a :: Type) - (b :: Type) - (c :: Type) - (d :: Type) - (e :: Type) - (f :: Type) - (g :: Type). - ( t ~~ (a =-> b =-> c =-> d =-> e =-> f =-> g), - SupportedPrim a, - SupportedPrim b, - SupportedPrim c, - SupportedPrim d, - SupportedPrim e, - SupportedPrim f, - SupportedPrim g - ) => - R.TypeRep a -> - R.TypeRep b -> - R.TypeRep c -> - R.TypeRep d -> - R.TypeRep e -> - R.TypeRep f -> - R.TypeRep g -> - R.TypeRep t -pattern TFun7Type a b c d e f g = - TFunType - a - ( TFunType - b - ( TFunType - c - ( TFunType - d - ( TFunType - e - (TFunType f g) - ) - ) - ) - ) - -pattern TFun8Type :: - forall t. - (SupportedPrim t) => - forall - (a :: Type) - (b :: Type) - (c :: Type) - (d :: Type) - (e :: Type) - (f :: Type) - (g :: Type) - (h :: Type). - ( t ~~ (a =-> b =-> c =-> d =-> e =-> f =-> g =-> h), - SupportedPrim a, - SupportedPrim b, - SupportedPrim c, - SupportedPrim d, - SupportedPrim e, - SupportedPrim f, - SupportedPrim g, - SupportedPrim h - ) => - R.TypeRep a -> - R.TypeRep b -> - R.TypeRep c -> - R.TypeRep d -> - R.TypeRep e -> - R.TypeRep f -> - R.TypeRep g -> - R.TypeRep h -> - R.TypeRep t -pattern TFun8Type a b c d e f g h = - TFunType - a - ( TFunType - b - ( TFunType - c - ( TFunType - d - ( TFunType - e - ( TFunType - f - (TFunType g h) - ) - ) - ) - ) - ) - -data GFunTypeContainer :: forall k. k -> Type where - GFunTypeContainer :: (SupportedPrim a, SupportedPrim b) => R.TypeRep a -> R.TypeRep b -> GFunTypeContainer (a --> b) - -gFunTypeView :: forall t. (SupportedPrim t) => R.TypeRep t -> Maybe (GFunTypeContainer t) -gFunTypeView t = case t of - R.App (R.App arr (ta2' :: R.TypeRep a2)) (tr2' :: R.TypeRep r2) -> - case R.eqTypeRep arr (R.typeRep @(-->)) of - Just R.HRefl -> Just $ withPrim (Proxy @t) $ GFunTypeContainer ta2' tr2' - Nothing -> Nothing - _ -> Nothing - -pattern GFunType :: - forall t. - (SupportedPrim t) => - forall (a :: Type) (b :: Type). - (t ~~ (a --> b), SupportedPrim a, SupportedPrim b) => - R.TypeRep a -> - R.TypeRep b -> - R.TypeRep t -pattern GFunType a b <- - (gFunTypeView -> Just (GFunTypeContainer a b)) - where - GFunType a b = R.App (R.App (R.typeRep @(-->)) a) b - -pattern GFun3Type :: - forall t. - (SupportedPrim t) => - forall (a :: Type) (b :: Type) (c :: Type). - (t ~~ (a --> b --> c), SupportedPrim a, SupportedPrim b, SupportedPrim c) => - R.TypeRep a -> - R.TypeRep b -> - R.TypeRep c -> - R.TypeRep t -pattern GFun3Type a b c = GFunType a (GFunType b c) - -pattern GFun4Type :: - forall t. - (SupportedPrim t) => - forall (a :: Type) (b :: Type) (c :: Type) (d :: Type). - ( t ~~ (a --> b --> c --> d), - SupportedPrim a, - SupportedPrim b, - SupportedPrim c, - SupportedPrim d - ) => - R.TypeRep a -> - R.TypeRep b -> - R.TypeRep c -> - R.TypeRep d -> - R.TypeRep t -pattern GFun4Type a b c d = GFunType a (GFunType b (GFunType c d)) - -pattern GFun5Type :: - forall t. - (SupportedPrim t) => - forall (a :: Type) (b :: Type) (c :: Type) (d :: Type) (e :: Type). - ( t ~~ (a --> b --> c --> d --> e), - SupportedPrim a, - SupportedPrim b, - SupportedPrim c, - SupportedPrim d, - SupportedPrim e - ) => - R.TypeRep a -> - R.TypeRep b -> - R.TypeRep c -> - R.TypeRep d -> - R.TypeRep e -> - R.TypeRep t -pattern GFun5Type a b c d e = - GFunType - a - ( GFunType - b - ( GFunType - c - (GFunType d e) - ) - ) - -pattern GFun6Type :: - forall t. - (SupportedPrim t) => - forall - (a :: Type) - (b :: Type) - (c :: Type) - (d :: Type) - (e :: Type) - (f :: Type). - ( t ~~ (a --> b --> c --> d --> e --> f), - SupportedPrim a, - SupportedPrim b, - SupportedPrim c, - SupportedPrim d, - SupportedPrim e, - SupportedPrim f - ) => - R.TypeRep a -> - R.TypeRep b -> - R.TypeRep c -> - R.TypeRep d -> - R.TypeRep e -> - R.TypeRep f -> - R.TypeRep t -pattern GFun6Type a b c d e f = - GFunType - a - ( GFunType - b - ( GFunType - c - ( GFunType - d - (GFunType e f) - ) - ) - ) - -pattern GFun7Type :: - forall t. - (SupportedPrim t) => - forall - (a :: Type) - (b :: Type) - (c :: Type) - (d :: Type) - (e :: Type) - (f :: Type) - (g :: Type). - ( t ~~ (a --> b --> c --> d --> e --> f --> g), - SupportedPrim a, - SupportedPrim b, - SupportedPrim c, - SupportedPrim d, - SupportedPrim e, - SupportedPrim f, - SupportedPrim g - ) => - R.TypeRep a -> - R.TypeRep b -> - R.TypeRep c -> - R.TypeRep d -> - R.TypeRep e -> - R.TypeRep f -> - R.TypeRep g -> - R.TypeRep t -pattern GFun7Type a b c d e f g = - GFunType - a - ( GFunType - b - ( GFunType - c - ( GFunType - d - ( GFunType - e - (GFunType f g) - ) - ) - ) - ) - -pattern GFun8Type :: - forall t. - (SupportedPrim t) => - forall - (a :: Type) - (b :: Type) - (c :: Type) - (d :: Type) - (e :: Type) - (f :: Type) - (g :: Type) - (h :: Type). - ( t ~~ (a --> b --> c --> d --> e --> f --> g --> h), - SupportedPrim a, - SupportedPrim b, - SupportedPrim c, - SupportedPrim d, - SupportedPrim e, - SupportedPrim f, - SupportedPrim g, - SupportedPrim h - ) => - R.TypeRep a -> - R.TypeRep b -> - R.TypeRep c -> - R.TypeRep d -> - R.TypeRep e -> - R.TypeRep f -> - R.TypeRep g -> - R.TypeRep h -> - R.TypeRep t -pattern GFun8Type a b c d e f g h = - GFunType - a - ( GFunType - b - ( GFunType - c - ( GFunType - d - ( GFunType - e - ( GFunType - f - (GFunType g h) - ) - ) - ) - ) - ) - -pattern BoolType :: - forall t. - () => - (t ~~ Bool) => - R.TypeRep t -pattern BoolType <- (R.eqTypeRep (R.typeRep @Bool) -> Just R.HRefl) - -pattern IntegerType :: - forall t. - () => - (t ~~ Integer) => - R.TypeRep t -pattern IntegerType <- (R.eqTypeRep (R.typeRep @Integer) -> Just R.HRefl) - -type ConfigConstraint integerBitWidth s = - ( SBV.SBV s ~ TermTy integerBitWidth Integer, - SBV.SymVal s, - SBV.HasKind s, - Typeable s, - Num (SBV.SBV s), - Num s, - SBV.OrdSymbolic (SBV.SBV s), - Ord s, - SBV.SDivisible (SBV.SBV s), - SBV.OrdSymbolic (SBV.SBV s), - SBV.Mergeable (SBV.SBV s) - ) - -data DictConfig integerBitWidth where - DictConfig :: - forall s integerBitWidth. - (ConfigConstraint integerBitWidth s) => - SBV.SMTConfig -> - DictConfig integerBitWidth - -resolveConfigView :: - forall integerBitWidth. - GrisetteSMTConfig integerBitWidth -> - DictConfig integerBitWidth -resolveConfigView config = case config of - GrisetteSMTConfig c extra -> - case integerApprox extra of - NoApprox -> DictConfig c - Approx _ -> DictConfig c - -pattern ResolvedConfig :: - forall integerBitWidth. - () => - forall s. - (ConfigConstraint integerBitWidth s) => - SBV.SMTConfig -> - GrisetteSMTConfig integerBitWidth -pattern ResolvedConfig c <- (resolveConfigView -> DictConfig c) - -type MergeableTypeConstraint integerBitWidth s = - ( Typeable (TermTy integerBitWidth s), - SBV.Mergeable (TermTy integerBitWidth s) - ) - --- has to declare this because GHC does not support impredicative polymorphism -data DictMergeableType integerBitWidth s where - DictMergeableType :: - forall integerBitWidth s. - (MergeableTypeConstraint integerBitWidth s) => - DictMergeableType integerBitWidth s - -resolveMergeableTypeView :: TypeResolver DictMergeableType -resolveMergeableTypeView (config@ResolvedConfig {}, s) = case s of - BoolType -> Just DictMergeableType - IntegerType -> Just DictMergeableType - SignedBVType _ -> Just DictMergeableType - UnsignedBVType _ -> Just DictMergeableType - TFunType l r -> - case (resolveSimpleTypeView (config, l), resolveMergeableTypeView (config, r)) of - (Just DictSimpleType, Just DictMergeableType) -> Just DictMergeableType - _ -> Nothing - GFunType l r -> - case (resolveSimpleTypeView (config, l), resolveMergeableTypeView (config, r)) of - (Just DictSimpleType, Just DictMergeableType) -> Just DictMergeableType - _ -> Nothing - _ -> Nothing -resolveMergeableTypeView _ = error "Should never happen, make compiler happy" - -pattern ResolvedMergeableType :: - forall integerBitWidth s. - (SupportedPrim s) => - (MergeableTypeConstraint integerBitWidth s) => - (GrisetteSMTConfig integerBitWidth, R.TypeRep s) -pattern ResolvedMergeableType <- (resolveMergeableTypeView -> Just DictMergeableType) - -type SimpleTypeConstraint integerBitWidth s s' = - ( SBV.SBV s' ~ TermTy integerBitWidth s, - SBV.SymVal s', - SBV.HasKind s', - Typeable s', - SBV.OrdSymbolic (SBV.SBV s'), - SBV.Mergeable (SBV.SBV s') - ) - -type TypeResolver dictType = - forall integerBitWidth s. - (SupportedPrim s) => - (GrisetteSMTConfig integerBitWidth, R.TypeRep s) -> - Maybe (dictType integerBitWidth s) - --- has to declare this because GHC does not support impredicative polymorphism -data DictSimpleType integerBitWidth s where - DictSimpleType :: - forall integerBitWidth s s'. - (SimpleTypeConstraint integerBitWidth s s') => - DictSimpleType integerBitWidth s - -resolveSimpleTypeView :: TypeResolver DictSimpleType -resolveSimpleTypeView (ResolvedConfig {}, s) = case s of - BoolType -> Just DictSimpleType - IntegerType -> Just DictSimpleType - SignedBVType _ -> Just DictSimpleType - UnsignedBVType _ -> Just DictSimpleType - _ -> Nothing -resolveSimpleTypeView _ = error "Should never happen, make compiler happy" - -pattern ResolvedSimpleType :: - forall integerBitWidth s. - (SupportedPrim s) => - forall s'. - (SimpleTypeConstraint integerBitWidth s s') => - (GrisetteSMTConfig integerBitWidth, R.TypeRep s) -pattern ResolvedSimpleType <- (resolveSimpleTypeView -> Just DictSimpleType) - -type DeepTypeConstraint integerBitWidth s s' = - ( s' ~ TermTy integerBitWidth s, - Typeable s', - SBV.Mergeable s' - ) - -data DictDeepType integerBitWidth s where - DictDeepType :: - forall integerBitWidth s s'. - (DeepTypeConstraint integerBitWidth s s') => - DictDeepType integerBitWidth s - -resolveDeepTypeView :: TypeResolver DictDeepType -resolveDeepTypeView r = case r of - ResolvedSimpleType -> Just DictDeepType - (config, TFunType (ta :: R.TypeRep a) (tb :: R.TypeRep b)) -> - case (resolveDeepTypeView (config, ta), resolveDeepTypeView (config, tb)) of - (Just DictDeepType, Just DictDeepType) -> Just DictDeepType - _ -> Nothing - (config, GFunType (ta :: R.TypeRep a) (tb :: R.TypeRep b)) -> - case (resolveDeepTypeView (config, ta), resolveDeepTypeView (config, tb)) of - (Just DictDeepType, Just DictDeepType) -> Just DictDeepType - _ -> Nothing - _ -> Nothing - -pattern ResolvedDeepType :: - forall integerBitWidth s. - (SupportedPrim s) => - forall s'. - (DeepTypeConstraint integerBitWidth s s') => - (GrisetteSMTConfig integerBitWidth, R.TypeRep s) -pattern ResolvedDeepType <- (resolveDeepTypeView -> Just DictDeepType) - -type NumTypeConstraint integerBitWidth s s' = - ( SimpleTypeConstraint integerBitWidth s s', - Num (SBV.SBV s'), - Num s', - Num s - ) - -data DictNumType integerBitWidth s where - DictNumType :: - forall integerBitWidth s s'. - (NumTypeConstraint integerBitWidth s s') => - DictNumType integerBitWidth s - -resolveNumTypeView :: TypeResolver DictNumType -resolveNumTypeView (ResolvedConfig {}, s) = case s of - IntegerType -> Just DictNumType - SignedBVType _ -> Just DictNumType - UnsignedBVType _ -> Just DictNumType - _ -> Nothing -resolveNumTypeView _ = error "Should never happen, make compiler happy" - -pattern ResolvedNumType :: - forall integerBitWidth s. - (SupportedPrim s) => - forall s'. - (NumTypeConstraint integerBitWidth s s') => - (GrisetteSMTConfig integerBitWidth, R.TypeRep s) -pattern ResolvedNumType <- (resolveNumTypeView -> Just DictNumType) - -type SDivisibleTypeConstraint integerBitWidth s s' = - ( SimpleTypeConstraint integerBitWidth s s', - SBV.SDivisible (SBV.SBV s'), - Integral s - ) - -data DictSDivisibleType integerBitWidth s where - DictSDivisibleType :: - forall integerBitWidth s s'. - (SDivisibleTypeConstraint integerBitWidth s s') => - DictSDivisibleType integerBitWidth s - -resolveSDivisibleTypeView :: TypeResolver DictSDivisibleType -resolveSDivisibleTypeView (ResolvedConfig {}, s) = case s of - IntegerType -> Just DictSDivisibleType - SignedBVType _ -> Just DictSDivisibleType - UnsignedBVType _ -> Just DictSDivisibleType - _ -> Nothing -resolveSDivisibleTypeView _ = error "Should never happen, make compiler happy" - -pattern ResolvedSDivisibleType :: - forall integerBitWidth s. - (SupportedPrim s) => - forall s'. - (SDivisibleTypeConstraint integerBitWidth s s') => - (GrisetteSMTConfig integerBitWidth, R.TypeRep s) -pattern ResolvedSDivisibleType <- (resolveSDivisibleTypeView -> Just DictSDivisibleType) - -type NumOrdTypeConstraint integerBitWidth s s' = - ( NumTypeConstraint integerBitWidth s s', - SBV.OrdSymbolic (SBV.SBV s'), - Ord s', - Ord s - ) - -data DictNumOrdType integerBitWidth s where - DictNumOrdType :: - forall integerBitWidth s s'. - (NumOrdTypeConstraint integerBitWidth s s') => - DictNumOrdType integerBitWidth s - -resolveNumOrdTypeView :: TypeResolver DictNumOrdType -resolveNumOrdTypeView (ResolvedConfig {}, s) = case s of - IntegerType -> Just DictNumOrdType - SignedBVType _ -> Just DictNumOrdType - UnsignedBVType _ -> Just DictNumOrdType - _ -> Nothing -resolveNumOrdTypeView _ = error "Should never happen, make compiler happy" - -pattern ResolvedNumOrdType :: - forall integerBitWidth s. - (SupportedPrim s) => - forall s'. - (NumOrdTypeConstraint integerBitWidth s s') => - (GrisetteSMTConfig integerBitWidth, R.TypeRep s) -pattern ResolvedNumOrdType <- (resolveNumOrdTypeView -> Just DictNumOrdType) - -type BitsTypeConstraint integerBitWidth s s' = - ( SimpleTypeConstraint integerBitWidth s s', - Bits (SBV.SBV s'), - Bits s', - Bits s, - SIntegral s', - Integral s - ) - -data DictBitsType integerBitWidth s where - DictBitsType :: - forall integerBitWidth s s'. - (BitsTypeConstraint integerBitWidth s s') => - DictBitsType integerBitWidth s - -resolveBitsTypeView :: TypeResolver DictBitsType -resolveBitsTypeView (ResolvedConfig {}, s) = case s of - SignedBVType _ -> Just DictBitsType - UnsignedBVType _ -> Just DictBitsType - _ -> Nothing -resolveBitsTypeView _ = error "Should never happen, make compiler happy" - -pattern ResolvedBitsType :: - forall integerBitWidth s. - (SupportedPrim s) => - forall s'. - (BitsTypeConstraint integerBitWidth s s') => - (GrisetteSMTConfig integerBitWidth, R.TypeRep s) -pattern ResolvedBitsType <- (resolveBitsTypeView -> Just DictBitsType) diff --git a/src/Grisette/Backend/SBV/Data/SMT/Solving.hs b/src/Grisette/Backend/SBV/Data/SMT/Solving.hs deleted file mode 100644 --- a/src/Grisette/Backend/SBV/Data/SMT/Solving.hs +++ /dev/null @@ -1,418 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- Module : Grisette.Backend.SBV.Data.SMT.Solving --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Backend.SBV.Data.SMT.Solving - ( -- * Term type computation - TermTy, - - -- * SBV backend configuration - ApproximationConfig (..), - ExtraConfig (..), - precise, - approx, - withTimeout, - clearTimeout, - withApprox, - clearApprox, - GrisetteSMTConfig (..), - - -- * SBV monadic solver interface - SBVIncrementalT, - SBVIncremental, - runSBVIncrementalT, - runSBVIncremental, - - -- * SBV solver handle - SBVSolverHandle, - ) -where - -import Control.Concurrent.Async (Async (asyncThreadId), async, wait) -import Control.Concurrent.STM - ( TMVar, - atomically, - newTMVarIO, - putTMVar, - takeTMVar, - tryReadTMVar, - tryTakeTMVar, - ) -import Control.Concurrent.STM.TChan (TChan, newTChan, readTChan, writeTChan) -import Control.Exception (handle, throwTo) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Reader - ( MonadReader (ask), - MonadTrans (lift), - ReaderT (runReaderT), - ) -import Control.Monad.STM (STM) -import Control.Monad.State (MonadState (get, put), StateT, evalStateT) -import Data.Kind (Type) -import qualified Data.SBV as SBV -import qualified Data.SBV.Control as SBVC -import qualified Data.SBV.Trans as SBVT -import qualified Data.SBV.Trans.Control as SBVTC -import GHC.IO.Exception (ExitCode (ExitSuccess)) -import GHC.TypeNats (KnownNat, Nat) -import Grisette.Backend.SBV.Data.SMT.Lowering - ( SymBiMap, - lowerSinglePrimCached, - parseModel, - ) -import Grisette.Backend.SBV.Data.SMT.SymBiMap (emptySymBiMap) -import Grisette.Core.Data.BV (IntN, WordN) -import Grisette.Core.Data.Class.Solver - ( ConfigurableSolver (newSolver), - MonadicSolver - ( monadicSolverPop, - monadicSolverPush, - monadicSolverSolve - ), - Solver - ( solverForceTerminate, - solverRunCommand, - solverSolve, - solverTerminate - ), - SolverCommand (SolverPop, SolverPush, SolverSolve, SolverTerminate), - SolvingFailure (SolvingError, Terminated, Unk, Unsat), - ) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term - ( type (-->), - ) -import Grisette.IR.SymPrim.Data.Prim.Model as PM - ( Model, - ) -import Grisette.IR.SymPrim.Data.SymPrim (SymBool (SymBool)) -import Grisette.IR.SymPrim.Data.TabularFun (type (=->)) - --- $setup --- >>> import Grisette.Core --- >>> import Grisette.IR.SymPrim --- >>> import Grisette.Backend.SBV --- >>> import Data.Proxy - -type Aux :: Bool -> Nat -> Type -type family Aux o n where - Aux 'True _ = SBV.SInteger - Aux 'False n = SBV.SInt n - -type IsZero :: Nat -> Bool -type family IsZero n where - IsZero 0 = 'True - IsZero _ = 'False - -type TermTy :: Nat -> Type -> Type -type family TermTy bitWidth b where - TermTy _ Bool = SBV.SBool - TermTy n Integer = Aux (IsZero n) n - TermTy _ (IntN x) = SBV.SBV (SBV.IntN x) - TermTy _ (WordN x) = SBV.SBV (SBV.WordN x) - TermTy n (a =-> b) = TermTy n a -> TermTy n b - TermTy n (a --> b) = TermTy n a -> TermTy n b - TermTy _ v = v - --- | Configures how to approximate unbounded values. --- --- For example, if we use @'Approx' ('Data.Proxy' :: 'Data.Proxy' 4)@ to --- approximate the following unbounded integer: --- --- > (+ a 9) --- --- We will get --- --- > (bvadd a #x9) --- --- Here the value 9 will be approximated to a 4-bit bit vector, and the --- operation `bvadd` will be used instead of `+`. --- --- Note that this approximation may not be sound. See 'GrisetteSMTConfig' for --- more details. -data ApproximationConfig (n :: Nat) where - NoApprox :: ApproximationConfig 0 - Approx :: - (KnownNat n, IsZero n ~ 'False, SBV.BVIsNonZero n) => - p n -> - ApproximationConfig n - --- | Grisette specific extra configurations for the SBV backend. -data ExtraConfig (i :: Nat) = ExtraConfig - { -- | Timeout in milliseconds for each solver call. CEGIS may call the - -- solver multiple times and each call has its own timeout. - timeout :: Maybe Int, - -- | Configures how to approximate unbounded integer values. - integerApprox :: ApproximationConfig i - } - -preciseExtraConfig :: ExtraConfig 0 -preciseExtraConfig = - ExtraConfig - { timeout = Nothing, - integerApprox = NoApprox - } - -approximateExtraConfig :: - (KnownNat n, IsZero n ~ 'False, SBV.BVIsNonZero n) => - p n -> - ExtraConfig n -approximateExtraConfig p = - ExtraConfig - { timeout = Nothing, - integerApprox = Approx p - } - --- | Solver configuration for the Grisette SBV backend. --- A Grisette solver configuration consists of a SBV solver configuration and --- the reasoning precision. --- --- Integers can be unbounded (mathematical integer) or bounded (machine --- integer/bit vector). The two types of integers have their own use cases, --- and should be used to model different systems. --- However, the solvers are known to have bad performance on some unbounded --- integer operations, for example, when reason about non-linear integer --- algebraic (e.g., multiplication or division), --- the solver may not be able to get a result in a reasonable time. --- In contrast, reasoning about bounded integers is usually more efficient. --- --- To bridge the performance gap between the two types of integers, Grisette --- allows to model the system with unbounded integers, and evaluate them with --- infinite precision during the symbolic evaluation, but when solving the --- queries, they are translated to bit vectors for better performance. --- --- For example, the Grisette term @5 * "a" :: 'SymInteger'@ should be translated --- to the following SMT with the unbounded reasoning configuration (the term --- is @t1@): --- --- > (declare-fun a () Int) ; declare symbolic constant a --- > (define-fun c1 () Int 5) ; define the concrete value 5 --- > (define-fun t1 () Int (* c1 a)) ; define the term --- --- While with reasoning precision 4, it would be translated to the following --- SMT (the term is @t1@): --- --- > ; declare symbolic constant a, the type is a bit vector with bit width 4 --- > (declare-fun a () (_ BitVec 4)) --- > ; define the concrete value 1, translated to the bit vector #x1 --- > (define-fun c1 () (_ BitVec 4) #x5) --- > ; define the term, using bit vector addition rather than integer addition --- > (define-fun t1 () (_ BitVec 4) (bvmul c1 a)) --- --- This bounded translation can usually be solved faster than the unbounded --- one, and should work well when no overflow is possible, in which case the --- performance can be improved with almost no cost. --- --- We must note that the bounded translation is an approximation and is --- __/not sound/__. As the approximation happens only during the final --- translation, the symbolic evaluation may aggressively optimize the term based --- on the properties of mathematical integer arithmetic. This may cause the --- solver yield results that is incorrect under both unbounded or bounded --- semantics. --- --- The following is an example that is correct under bounded semantics, while is --- incorrect under the unbounded semantics: --- --- >>> :set -XTypeApplications -XOverloadedStrings -XDataKinds --- >>> let a = "a" :: SymInteger --- >>> solve (precise z3) $ a .> 7 .&& a .< 9 --- Right (Model {a -> 8 :: Integer}) --- >>> solve (approx (Proxy @4) z3) $ a .> 7 .&& a .< 9 --- Left Unsat --- --- This may be avoided by setting an large enough reasoning precision to prevent --- overflows. -data GrisetteSMTConfig (i :: Nat) = GrisetteSMTConfig - { sbvConfig :: SBV.SMTConfig, - extraConfig :: ExtraConfig i - } - --- | A precise reasoning configuration with the given SBV solver configuration. -precise :: SBV.SMTConfig -> GrisetteSMTConfig 0 -precise config = GrisetteSMTConfig config preciseExtraConfig - --- | An approximate reasoning configuration with the given SBV solver --- configuration. -approx :: - forall p n. - (KnownNat n, IsZero n ~ 'False, SBV.BVIsNonZero n) => - p n -> - SBV.SMTConfig -> - GrisetteSMTConfig n -approx p config = GrisetteSMTConfig config (approximateExtraConfig p) - --- | Set the timeout for the solver configuration. -withTimeout :: Int -> GrisetteSMTConfig i -> GrisetteSMTConfig i -withTimeout t config = - config {extraConfig = (extraConfig config) {timeout = Just t}} - --- | Clear the timeout for the solver configuration. -clearTimeout :: GrisetteSMTConfig i -> GrisetteSMTConfig i -clearTimeout config = - config {extraConfig = (extraConfig config) {timeout = Nothing}} - --- | Set the reasoning precision for the solver configuration. -withApprox :: - (KnownNat n, IsZero n ~ 'False, SBV.BVIsNonZero n) => - p n -> - GrisetteSMTConfig i -> - GrisetteSMTConfig n -withApprox p config = - config {extraConfig = (extraConfig config) {integerApprox = Approx p}} - --- | Clear the reasoning precision and perform precise reasoning with the --- solver configuration. -clearApprox :: GrisetteSMTConfig i -> GrisetteSMTConfig 0 -clearApprox config = - config {extraConfig = (extraConfig config) {integerApprox = NoApprox}} - -sbvCheckSatResult :: SBVC.CheckSatResult -> SolvingFailure -sbvCheckSatResult SBVC.Sat = error "Should not happen" -sbvCheckSatResult (SBVC.DSat _) = error "DSat is currently not supported" -sbvCheckSatResult SBVC.Unsat = Unsat -sbvCheckSatResult SBVC.Unk = Unk - --- | Apply the timeout to the configuration. -applyTimeout :: - (MonadIO m, SBVTC.MonadQuery m) => GrisetteSMTConfig i -> m a -> m a -applyTimeout config q = case timeout (extraConfig config) of - Nothing -> q - Just t -> SBVTC.timeout t q - --- | Incremental solver monad transformer with the SBV backend. -type SBVIncrementalT n m = - ReaderT (GrisetteSMTConfig n) (StateT SymBiMap (SBVTC.QueryT m)) - --- | Incremental solver monad with the SBV backend. -type SBVIncremental n = SBVIncrementalT n IO - --- | Run the incremental solver monad with a given configuration. -runSBVIncremental :: GrisetteSMTConfig n -> SBVIncremental n a -> IO a -runSBVIncremental = runSBVIncrementalT - --- | Run the incremental solver monad transformer with a given configuration. -runSBVIncrementalT :: - (SBVTC.ExtractIO m) => - GrisetteSMTConfig n -> - SBVIncrementalT n m a -> - m a -runSBVIncrementalT config sbvIncrementalT = - SBVT.runSMTWith (sbvConfig config) $ - SBVTC.query $ - applyTimeout config $ - flip evalStateT emptySymBiMap $ - runReaderT sbvIncrementalT config - -instance (MonadIO m) => MonadicSolver (SBVIncrementalT n m) where - monadicSolverSolve (SymBool formula) = do - symBiMap <- get - config <- ask - (newSymBiMap, lowered) <- lowerSinglePrimCached config formula symBiMap - lift $ lift $ SBV.constrain lowered - put newSymBiMap - checkSatResult <- SBVTC.checkSat - case checkSatResult of - SBVC.Sat -> do - sbvModel <- SBVTC.getModel - let model = parseModel config sbvModel newSymBiMap - return $ Right model - r -> return $ Left $ sbvCheckSatResult r - monadicSolverPush = SBVTC.push - monadicSolverPop = SBVTC.pop - -data SBVSolverStatus = SBVSolverNormal | SBVSolverTerminated - --- | The handle type for the SBV solver. --- --- See 'ConfigurableSolver' and 'Solver' for the interfaces. -data SBVSolverHandle = SBVSolverHandle - { sbvSolverHandleMonad :: Async (), - sbvSolverHandleStatus :: TMVar SBVSolverStatus, - sbvSolverHandleInChan :: TChan SolverCommand, - sbvSolverHandleOutChan :: TChan (Either SolvingFailure Model) - } - -setTerminated :: TMVar SBVSolverStatus -> STM () -setTerminated status = do - _ <- tryTakeTMVar status - putTMVar status SBVSolverTerminated - -instance ConfigurableSolver (GrisetteSMTConfig n) SBVSolverHandle where - newSolver config = do - sbvSolverHandleInChan <- atomically newTChan - sbvSolverHandleOutChan <- atomically newTChan - sbvSolverHandleStatus <- newTMVarIO SBVSolverNormal - sbvSolverHandleMonad <- async $ do - let handler e = - liftIO $ - atomically $ do - setTerminated sbvSolverHandleStatus - writeTChan sbvSolverHandleOutChan (Left (SolvingError e)) - handle handler $ runSBVIncremental config $ do - let loop = do - nextFormula <- liftIO $ atomically $ readTChan sbvSolverHandleInChan - case nextFormula of - SolverPush n -> monadicSolverPush n >> loop - SolverPop n -> monadicSolverPop n >> loop - SolverTerminate -> return () - SolverSolve formula -> do - r <- monadicSolverSolve formula - liftIO $ atomically $ writeTChan sbvSolverHandleOutChan r - loop - loop - liftIO $ atomically $ do - setTerminated sbvSolverHandleStatus - writeTChan sbvSolverHandleOutChan $ Left Terminated - return $ SBVSolverHandle {..} - -instance Solver SBVSolverHandle where - solverRunCommand f handle@(SBVSolverHandle _ status inChan _) command = do - st <- liftIO $ atomically $ takeTMVar status - case st of - SBVSolverNormal -> do - liftIO $ atomically $ writeTChan inChan command - r <- f handle - liftIO $ atomically $ do - currStatus <- tryReadTMVar status - case currStatus of - Nothing -> putTMVar status SBVSolverNormal - Just _ -> return () - return r - SBVSolverTerminated -> do - liftIO $ atomically $ setTerminated status - return $ Left Terminated - solverSolve handle nextFormula = - solverRunCommand - ( \(SBVSolverHandle _ _ _ outChan) -> - liftIO $ atomically $ readTChan outChan - ) - handle - $ SolverSolve nextFormula - solverTerminate (SBVSolverHandle thread status inChan _) = do - liftIO $ atomically $ do - setTerminated status - writeTChan inChan SolverTerminate - wait thread - solverForceTerminate (SBVSolverHandle thread status _ outChan) = do - liftIO $ atomically $ do - setTerminated status - writeTChan outChan (Left Terminated) - throwTo (asyncThreadId thread) ExitSuccess - wait thread diff --git a/src/Grisette/Backend/SBV/Data/SMT/Solving.hs-boot b/src/Grisette/Backend/SBV/Data/SMT/Solving.hs-boot deleted file mode 100644 --- a/src/Grisette/Backend/SBV/Data/SMT/Solving.hs-boot +++ /dev/null @@ -1,54 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -module Grisette.Backend.SBV.Data.SMT.Solving - ( ApproximationConfig (..), - ExtraConfig (..), - GrisetteSMTConfig (..), - TermTy, - ) -where - -import Data.Kind (Type) -import qualified Data.SBV as SBV -import GHC.TypeNats (KnownNat, Nat) -import Grisette.Core.Data.BV (IntN, WordN) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term - ( type (-->), - ) -import Grisette.IR.SymPrim.Data.TabularFun (type (=->)) - -type Aux :: Bool -> Nat -> Type -type family Aux o n where - Aux 'True _ = SBV.SInteger - Aux 'False n = SBV.SInt n - -type IsZero :: Nat -> Bool -type family IsZero n where - IsZero 0 = 'True - IsZero _ = 'False - -type TermTy :: Nat -> Type -> Type -type family TermTy bitWidth b where - TermTy _ Bool = SBV.SBool - TermTy n Integer = Aux (IsZero n) n - TermTy _ (IntN x) = SBV.SBV (SBV.IntN x) - TermTy _ (WordN x) = SBV.SBV (SBV.WordN x) - TermTy n (a =-> b) = TermTy n a -> TermTy n b - TermTy n (a --> b) = TermTy n a -> TermTy n b - TermTy _ v = v - -data ApproximationConfig (n :: Nat) where - NoApprox :: ApproximationConfig 0 - Approx :: (KnownNat n, IsZero n ~ 'False, SBV.BVIsNonZero n) => p n -> ApproximationConfig n - -data ExtraConfig (i :: Nat) = ExtraConfig - { timeout :: Maybe Int, - integerApprox :: ApproximationConfig i - } - -data GrisetteSMTConfig (i :: Nat) = GrisetteSMTConfig {sbvConfig :: SBV.SMTConfig, extraConfig :: ExtraConfig i} diff --git a/src/Grisette/Backend/SBV/Data/SMT/SymBiMap.hs b/src/Grisette/Backend/SBV/Data/SMT/SymBiMap.hs deleted file mode 100644 --- a/src/Grisette/Backend/SBV/Data/SMT/SymBiMap.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - --- | --- Module : Grisette.Backend.SBV.Data.SMT.SymBiMap --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Backend.SBV.Data.SMT.SymBiMap - ( SymBiMap (..), - emptySymBiMap, - sizeBiMap, - addBiMap, - addBiMapIntermediate, - findStringToSymbol, - lookupTerm, - ) -where - -import Data.Dynamic (Dynamic) -import qualified Data.HashMap.Strict as M -import GHC.Stack (HasCallStack) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.SomeTerm - ( SomeTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term - ( SomeTypedSymbol, - ) - -data SymBiMap = SymBiMap - { biMapToSBV :: M.HashMap SomeTerm Dynamic, - biMapFromSBV :: M.HashMap String SomeTypedSymbol - } - deriving (Show) - -emptySymBiMap :: SymBiMap -emptySymBiMap = SymBiMap M.empty M.empty - -sizeBiMap :: SymBiMap -> Int -sizeBiMap = M.size . biMapToSBV - -addBiMap :: (HasCallStack) => SomeTerm -> Dynamic -> String -> SomeTypedSymbol -> SymBiMap -> SymBiMap -addBiMap s d n sb (SymBiMap t f) = SymBiMap (M.insert s d t) (M.insert n sb f) - -addBiMapIntermediate :: (HasCallStack) => SomeTerm -> Dynamic -> SymBiMap -> SymBiMap -addBiMapIntermediate s d (SymBiMap t f) = SymBiMap (M.insert s d t) f - -findStringToSymbol :: String -> SymBiMap -> Maybe SomeTypedSymbol -findStringToSymbol s (SymBiMap _ f) = M.lookup s f - -lookupTerm :: (HasCallStack) => SomeTerm -> SymBiMap -> Maybe Dynamic -lookupTerm t m = M.lookup t (biMapToSBV m) diff --git a/src/Grisette/Core.hs b/src/Grisette/Core.hs --- a/src/Grisette/Core.hs +++ b/src/Grisette/Core.hs @@ -5,7 +5,7 @@ -- | -- Module : Grisette.Core --- Copyright : (c) Sirui Lu 2021-2023 +-- Copyright : (c) Sirui Lu 2021-2024 -- License : BSD-3-Clause (see the LICENSE file) -- -- Maintainer : siruilu@cs.washington.edu @@ -77,7 +77,7 @@ -- union, which is essentially an if-then-else tree. -- -- For example, assume that the lists have the type - -- @['Grisette.IR.SymPrim.SymBool']@. + -- @['Grisette.SymPrim.SymBool']@. -- In the following example, the result shows that @[b]@ and @[c]@ can be -- merged together in the same symbolic union because they have the same -- length: @@ -128,14 +128,14 @@ -- Grisette -- currently provides an implementation for the following solvable types: -- - -- * 'Grisette.IR.SymPrim.SymBool' (symbolic Booleans) - -- * 'Grisette.IR.SymPrim.SymInteger' (symbolic unbounded integers) - -- * @'Grisette.IR.SymPrim.SymIntN' n@ (symbolic signed bit vectors of length @n@) - -- * @'Grisette.IR.SymPrim.SymWordN' n@ (symbolic unsigned bit vectors of length @n@) + -- * 'Grisette.SymPrim.SymBool' (symbolic Booleans) + -- * 'Grisette.SymPrim.SymInteger' (symbolic unbounded integers) + -- * @'Grisette.SymPrim.SymIntN' n@ (symbolic signed bit vectors of length @n@) + -- * @'Grisette.SymPrim.SymWordN' n@ (symbolic unsigned bit vectors of length @n@) -- -- The two bit vector types has their lengths checked at compile time. -- Grisette also provides runtime-checked versions of these types: - -- 'Grisette.IR.SymPrim.SomeSymIntN' and 'Grisette.IR.SymPrim.SomeSymWordN'. + -- 'Grisette.SymPrim.SomeSymIntN' and 'Grisette.SymPrim.SomeSymWordN'. -- -- Values of a solvable type can consist of concrete values, symbolic -- constants (placeholders for concrete values that can be assigned by a @@ -172,8 +172,15 @@ -- *** Creation of solvable type values Solvable (..), pattern Con, + Identifier (..), + Symbol (..), + identifier, + withInfo, + withLoc, slocsym, ilocsym, + simple, + indexed, -- *** Symbolic operators @@ -182,6 +189,10 @@ ITEOp (..), SEq (..), SOrd (..), + symMax, + symMin, + mrgMax, + mrgMin, BV (..), bvExtract, SizedBV (..), @@ -191,6 +202,10 @@ SafeLinearArith (..), Function (..), Apply (..), + SymShift (..), + SafeSymShift (..), + SymRotate (..), + SafeSymRotate (..), -- ** Unsolvable types @@ -229,8 +244,8 @@ -- -- >>> :{ -- ret :: UnionM [SymInteger] - -- ret = do x <- mrgIf "a" (single ["b"]) (single ["b","c"]) - -- y <- mrgIf "d" (single ["e"]) (single ["e","f"]) + -- ret = do x <- mrgIf "a" (return ["b"]) (return ["b","c"]) + -- y <- mrgIf "d" (return ["e"]) (return ["e","f"]) -- mrgReturn $ x ++ y -- we will explain mrgReturn later -- :} -- @@ -558,8 +573,9 @@ -- *** UnionM Monad UnionM, IsConcrete, - makeUnionWrapper, - makeUnionWrapper', + unionMUnaryOp, + unionMBinOp, + liftUnionM, liftToMonadUnion, unionSize, @@ -593,23 +609,29 @@ mrgIte1, SimpleMergeable2 (..), mrgIte2, - - -- **** UnionLike operations - UnionLike (..), + UnionMergeable1 (..), mrgIf, + mergeWithStrategy, merge, + + -- **** TryMerge operations + MonadTryMerge, + TryMerge (..), mrgSingle, - UnionPrjOp (..), + mrgSingleWithStrategy, + tryMerge, + + -- **** PlainUnion operations + PlainUnion (..), pattern Single, pattern If, - MonadUnion, - MonadParallelUnion (..), simpleMerge, + (.#), onUnion, onUnion2, onUnion3, onUnion4, - (.#), + MonadUnion, -- * Conversion between Concrete and Symbolic values ToCon (..), @@ -703,11 +725,6 @@ -- ** Symbolic Generation Context FreshIndex (..), - FreshIdent (..), - name, - nameWithInfo, - FileLocation (..), - nameWithLoc, -- ** Symbolic Generation Monad MonadFresh (..), @@ -718,6 +735,7 @@ runFresh, runFreshT, mrgRunFreshT, + freshString, -- ** Symbolic Generation Class GenSym (..), @@ -761,7 +779,7 @@ -- -- >>> :set -XDerivingVia -XDeriveGeneric -XDerivingStrategies -XLambdaCase -- >>> import GHC.Generics - -- >>> import Grisette.Backend.SBV + -- >>> import Grisette.Backend -- >>> :{ -- data Error = Error1 | Error2 | Error3 -- deriving (Show, Generic) @@ -838,8 +856,8 @@ -- \right. -- \] -- - -- >>> import Grisette.IR.SymPrim - -- >>> import Grisette.Backend.SBV + -- >>> import Grisette.SymPrim + -- >>> import Grisette.Backend -- >>> let x = "x" :: SymInteger -- >>> let y = "y" :: SymInteger -- >>> solve (precise z3) (x + y .== 6 .&& x - y .== 20) @@ -897,6 +915,7 @@ -- -- >>> :set -XLambdaCase -XDeriveGeneric -XDerivingStrategies -XDerivingVia -- >>> import Control.Monad.Except + -- >>> import Grisette.Lib.Control.Monad.Trans.Except -- >>> import Control.Exception -- >>> import GHC.Generics -- >>> :{ @@ -913,7 +932,7 @@ -- >>> let x = "x" :: SymInteger -- >>> let y = "y" :: SymInteger -- >>> assert = symAssertWith Assert - -- >>> sdiv = safeDiv' (const Arith) + -- >>> sdiv l r = mrgWithExceptT (\(_::ArithException) -> Arith) $ safeDiv l r -- >>> :{ -- -- equivalent concrete program: -- -- let x = x `div` y @@ -1017,68 +1036,41 @@ htmup, htmemoFix, - -- ** Bundled Constructor Wrappers - mrgTrue, - mrgFalse, - mrgUnit, - mrgTuple2, - mrgTuple3, - mrgJust, - mrgNothing, - mrgLeft, - mrgRight, - mrgInL, - mrgInR, - mrgAssertionViolation, - mrgAssumptionViolation, + -- ** Template Haskell + mkMergeConstructor, + mkMergeConstructor', ) where import Generics.Deriving (Default (..), Default1 (..)) -import Grisette.Core.BuiltinUnionWrappers - ( mrgAssertionViolation, - mrgAssumptionViolation, - mrgFalse, - mrgInL, - mrgInR, - mrgJust, - mrgLeft, - mrgNothing, - mrgRight, - mrgTrue, - mrgTuple2, - mrgTuple3, - mrgUnit, - ) -import Grisette.Core.Control.Exception +import Grisette.Internal.Core.Control.Exception ( AssertionError (..), VerificationConditions (..), ) -import Grisette.Core.Control.Monad.CBMCExcept +import Grisette.Internal.Core.Control.Monad.CBMCExcept ( CBMCEither (..), CBMCExceptT (..), cbmcExcept, mapCBMCExceptT, withCBMCExceptT, ) -import Grisette.Core.Control.Monad.Class.MonadParallelUnion - ( MonadParallelUnion (..), - ) -import Grisette.Core.Control.Monad.Union (MonadUnion) -import Grisette.Core.Control.Monad.UnionM +import Grisette.Internal.Core.Control.Monad.Union (MonadUnion) +import Grisette.Internal.Core.Control.Monad.UnionM ( IsConcrete, UnionM, liftToMonadUnion, + liftUnionM, + unionMBinOp, + unionMUnaryOp, unionSize, - (.#), ) -import Grisette.Core.Data.Class.BitVector +import Grisette.Internal.Core.Data.Class.BitVector ( BV (..), SizedBV (..), bvExtract, sizedBVExtract, ) -import Grisette.Core.Data.Class.CEGISSolver +import Grisette.Internal.Core.Data.Class.CEGISSolver ( CEGISCondition (..), CEGISResult (..), StatefulVerifierFun, @@ -1100,7 +1092,7 @@ cegisPrePost, genericCEGIS, ) -import Grisette.Core.Data.Class.Error +import Grisette.Internal.Core.Data.Class.Error ( TransformError (..), symAssert, symAssertTransformableError, @@ -1108,20 +1100,19 @@ symAssume, symThrowTransformableError, ) -import Grisette.Core.Data.Class.EvaluateSym +import Grisette.Internal.Core.Data.Class.EvaluateSym ( EvaluateSym (..), evaluateSymToCon, ) -import Grisette.Core.Data.Class.ExtractSymbolics +import Grisette.Internal.Core.Data.Class.ExtractSymbolics ( ExtractSymbolics (..), ) -import Grisette.Core.Data.Class.Function (Apply (..), Function (..)) -import Grisette.Core.Data.Class.GPretty (GPretty (..)) -import Grisette.Core.Data.Class.GenSym +import Grisette.Internal.Core.Data.Class.Function (Apply (..), Function (..)) +import Grisette.Internal.Core.Data.Class.GPretty (GPretty (..)) +import Grisette.Internal.Core.Data.Class.GenSym ( EnumGenBound (..), EnumGenUpperBound (..), Fresh, - FreshIdent (..), FreshIndex (..), FreshT (..), GenSym (..), @@ -1138,19 +1129,18 @@ derivedNoSpecFresh, derivedNoSpecSimpleFresh, derivedSameShapeSimpleFresh, + freshString, genSym, genSymSimple, liftFresh, mrgRunFreshT, - name, - nameWithInfo, nextFreshIndex, runFresh, runFreshT, ) -import Grisette.Core.Data.Class.ITEOp (ITEOp (..)) -import Grisette.Core.Data.Class.LogicalOp (LogicalOp (..)) -import Grisette.Core.Data.Class.Mergeable +import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp (..)) +import Grisette.Internal.Core.Data.Class.LogicalOp (LogicalOp (..)) +import Grisette.Internal.Core.Data.Class.Mergeable ( DynamicSortedIdx (..), Mergeable (..), Mergeable1 (..), @@ -1168,38 +1158,54 @@ rootStrategy3, wrapStrategy, ) -import Grisette.Core.Data.Class.ModelOps +import Grisette.Internal.Core.Data.Class.ModelOps ( ModelOps (..), ModelRep (..), SymbolSetOps (..), SymbolSetRep (..), ) -import Grisette.Core.Data.Class.SEq (SEq (..)) -import Grisette.Core.Data.Class.SOrd (SOrd (..)) -import Grisette.Core.Data.Class.SafeDivision (SafeDivision (..)) -import Grisette.Core.Data.Class.SafeLinearArith (SafeLinearArith (..)) -import Grisette.Core.Data.Class.SignConversion (SignConversion (..)) -import Grisette.Core.Data.Class.SimpleMergeable - ( SimpleMergeable (..), - SimpleMergeable1 (..), - SimpleMergeable2 (..), - UnionLike (..), - UnionPrjOp (..), - merge, - mrgIf, - mrgIte1, - mrgIte2, - mrgSingle, +import Grisette.Internal.Core.Data.Class.PlainUnion + ( PlainUnion (..), onUnion, onUnion2, onUnion3, onUnion4, simpleMerge, + (.#), pattern If, pattern Single, ) -import Grisette.Core.Data.Class.Solvable (Solvable (..), pattern Con) -import Grisette.Core.Data.Class.Solver +import Grisette.Internal.Core.Data.Class.SEq (SEq (..)) +import Grisette.Internal.Core.Data.Class.SOrd + ( SOrd (..), + mrgMax, + mrgMin, + symMax, + symMin, + ) +import Grisette.Internal.Core.Data.Class.SafeDivision (SafeDivision (..)) +import Grisette.Internal.Core.Data.Class.SafeLinearArith (SafeLinearArith (..)) +import Grisette.Internal.Core.Data.Class.SafeSymRotate (SafeSymRotate (..)) +import Grisette.Internal.Core.Data.Class.SafeSymShift (SafeSymShift (..)) +import Grisette.Internal.Core.Data.Class.SignConversion (SignConversion (..)) +import Grisette.Internal.Core.Data.Class.SimpleMergeable + ( SimpleMergeable (..), + SimpleMergeable1 (..), + SimpleMergeable2 (..), + UnionMergeable1 (..), + merge, + mergeWithStrategy, + mrgIf, + mrgIte1, + mrgIte2, + ) +import Grisette.Internal.Core.Data.Class.Solvable + ( Solvable (..), + ilocsym, + slocsym, + pattern Con, + ) +import Grisette.Internal.Core.Data.Class.Solver ( ConfigurableSolver (..), MonadicSolver (..), Solver (..), @@ -1212,33 +1218,49 @@ solveMultiExcept, withSolver, ) -import Grisette.Core.Data.Class.SubstituteSym +import Grisette.Internal.Core.Data.Class.SubstituteSym ( SubstituteSym (..), SubstituteSym' (..), ) -import Grisette.Core.Data.Class.ToCon (ToCon (..)) -import Grisette.Core.Data.Class.ToSym (ToSym (..)) -import Grisette.Core.Data.FileLocation - ( FileLocation (..), - ilocsym, - nameWithLoc, - slocsym, +import Grisette.Internal.Core.Data.Class.SymRotate (SymRotate (..)) +import Grisette.Internal.Core.Data.Class.SymShift (SymShift (..)) +import Grisette.Internal.Core.Data.Class.ToCon (ToCon (..)) +import Grisette.Internal.Core.Data.Class.ToSym (ToSym (..)) +import Grisette.Internal.Core.Data.Class.TryMerge + ( MonadTryMerge, + TryMerge (..), + mrgSingle, + mrgSingleWithStrategy, + tryMerge, ) -import Grisette.Core.Data.MemoUtils +import Grisette.Internal.Core.Data.MemoUtils ( htmemo, htmemo2, htmemo3, htmemoFix, htmup, ) -import Grisette.Core.TH (makeUnionWrapper, makeUnionWrapper') +import Grisette.Internal.Core.Data.Symbol + ( Identifier (..), + Symbol (..), + identifier, + indexed, + simple, + withInfo, + withLoc, + ) +import Grisette.Internal.Core.TH.MergeConstructor + ( mkMergeConstructor, + mkMergeConstructor', + ) -- $setup -- >>> import Grisette.Core -- >>> import Grisette.Lib.Base --- >>> import Grisette.IR.SymPrim +-- >>> import Grisette.SymPrim -- >>> :set -XDataKinds -- >>> :set -XBinaryLiterals -- >>> :set -XFlexibleContexts -- >>> :set -XFlexibleInstances -- >>> :set -XFunctionalDependencies +-- >>> :set -XOverloadedStrings diff --git a/src/Grisette/Core/BuiltinUnionWrappers.hs b/src/Grisette/Core/BuiltinUnionWrappers.hs deleted file mode 100644 --- a/src/Grisette/Core/BuiltinUnionWrappers.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE Trustworthy #-} - --- | --- Module : Grisette.Core.BuiltinUnionWrapper --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Core.BuiltinUnionWrappers - ( -- * Builtin constructor wrappers for some common data types - mrgTrue, - mrgFalse, - mrgUnit, - mrgTuple2, - mrgTuple3, - mrgJust, - mrgNothing, - mrgLeft, - mrgRight, - mrgInL, - mrgInR, - mrgAssertionViolation, - mrgAssumptionViolation, - ) -where - -import Data.Functor.Sum (Sum) -import Grisette.Core.Control.Exception (VerificationConditions) -import Grisette.Core.Data.Class.SimpleMergeable (mrgSingle) -import Grisette.Core.TH (makeUnionWrapper, makeUnionWrapper') - -$(makeUnionWrapper "mrg" ''Bool) -$(makeUnionWrapper' ["mrgUnit"] ''()) -$(makeUnionWrapper' ["mrgTuple2"] ''(,)) -$(makeUnionWrapper' ["mrgTuple3"] ''(,,)) -$(makeUnionWrapper "mrg" ''Maybe) -$(makeUnionWrapper "mrg" ''Either) -$(makeUnionWrapper "mrg" ''Sum) -$(makeUnionWrapper "mrg" ''VerificationConditions) diff --git a/src/Grisette/Core/Control/Exception.hs b/src/Grisette/Core/Control/Exception.hs deleted file mode 100644 --- a/src/Grisette/Core/Control/Exception.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE Trustworthy #-} - --- | --- Module : Grisette.Core.Control.Exception --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Core.Control.Exception - ( -- * Predefined exceptions - AssertionError (..), - VerificationConditions (..), - ) -where - -import Control.DeepSeq (NFData) -import GHC.Generics (Generic) - --- import Grisette.Core.Data.Class.Mergeable (Mergeable) --- import Grisette.Core.Data.Class.SimpleMergeable --- ( SimpleMergeable, --- ) - --- $setup --- >>> import Grisette.Core --- >>> import Grisette.Lib.Base --- >>> import Grisette.IR.SymPrim --- >>> import Control.Monad.Trans.Except - --- | Assertion error. -data AssertionError = AssertionError - deriving (Show, Eq, Ord, Generic, NFData) - --- | Verification conditions. --- A crashed program path can terminate with either assertion violation errors or assumption violation errors. -data VerificationConditions - = AssertionViolation - | AssumptionViolation - deriving (Show, Eq, Ord, Generic, NFData) diff --git a/src/Grisette/Core/Control/Monad/CBMCExcept.hs b/src/Grisette/Core/Control/Monad/CBMCExcept.hs deleted file mode 100644 --- a/src/Grisette/Core/Control/Monad/CBMCExcept.hs +++ /dev/null @@ -1,475 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- Module : Grisette.Core.Control.Monad.CBMCExcept --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Core.Control.Monad.CBMCExcept - ( -- * CBMC-like error handling - CBMCEither (..), - CBMCExceptT (..), - cbmcExcept, - mapCBMCExceptT, - withCBMCExceptT, - OrigExcept.MonadError (..), - ) -where - -#if MIN_VERSION_base(4,18,0) -import Control.Applicative - ( Alternative (empty, (<|>)), - ) -#else -import Control.Applicative - ( Alternative (empty, (<|>)), - Applicative (liftA2), - ) -#endif -import Control.DeepSeq (NFData) -import Control.Monad (MonadPlus (mplus, mzero)) -import qualified Control.Monad.Except as OrigExcept -import qualified Control.Monad.Fail as Fail -import Control.Monad.Fix (MonadFix (mfix)) -import Control.Monad.Trans (MonadIO (liftIO), MonadTrans (lift)) -import Control.Monad.Zip (MonadZip (mzipWith)) -import Data.Functor.Classes - ( Eq1 (liftEq), - Ord1 (liftCompare), - Read1 (liftReadList, liftReadsPrec), - Show1 (liftShowList, liftShowsPrec), - compare1, - eq1, - readsData, - readsPrec1, - readsUnaryWith, - showsPrec1, - showsUnaryWith, - ) -import Data.Functor.Contravariant (Contravariant (contramap)) -import Data.Hashable (Hashable) -import GHC.Generics (Generic, Generic1) -import Grisette.Core.Control.Monad.UnionM (UnionM) -import Grisette.Core.Data.Class.EvaluateSym (EvaluateSym (evaluateSym)) -import Grisette.Core.Data.Class.ExtractSymbolics - ( ExtractSymbolics (extractSymbolics), - ) -import Grisette.Core.Data.Class.GenSym - ( GenSym (fresh), - GenSymSimple (simpleFresh), - derivedNoSpecFresh, - derivedSameShapeSimpleFresh, - ) -import Grisette.Core.Data.Class.Mergeable - ( Mergeable (rootStrategy), - Mergeable1 (liftRootStrategy), - MergingStrategy (NoStrategy, SimpleStrategy, SortedStrategy), - rootStrategy1, - wrapStrategy, - ) -import Grisette.Core.Data.Class.SEq (SEq ((.==))) -import Grisette.Core.Data.Class.SOrd (SOrd (symCompare, (.<), (.<=), (.>), (.>=))) -import Grisette.Core.Data.Class.SimpleMergeable - ( SimpleMergeable (mrgIte), - SimpleMergeable1 (liftMrgIte), - UnionLike (mergeWithStrategy, mrgIfWithStrategy, single, unionIf), - merge, - mrgIf, - ) -import Grisette.Core.Data.Class.Solver (UnionWithExcept (extractUnionExcept)) -import Grisette.Core.Data.Class.ToCon (ToCon (toCon)) -import Grisette.Core.Data.Class.ToSym (ToSym (toSym)) -import Language.Haskell.TH.Syntax (Lift) -import Unsafe.Coerce (unsafeCoerce) - --- | A wrapper type for 'Either'. Uses different merging strategies. -newtype CBMCEither a b = CBMCEither {runCBMCEither :: Either a b} - deriving newtype (Eq, Eq1, Ord, Ord1, Read, Read1, Show, Show1, Functor, Applicative, Monad, Hashable, NFData) - deriving stock (Generic, Lift) - -deriving newtype instance (SEq e, SEq a) => SEq (CBMCEither e a) - -deriving newtype instance (EvaluateSym a, EvaluateSym b) => EvaluateSym (CBMCEither a b) - -deriving newtype instance - (ExtractSymbolics a, ExtractSymbolics b) => - ExtractSymbolics (CBMCEither a b) - -instance - ( GenSymSimple a a, - Mergeable a, - GenSymSimple b b, - Mergeable b - ) => - GenSym (CBMCEither a b) (CBMCEither a b) - -instance - ( GenSymSimple a a, - GenSymSimple b b - ) => - GenSymSimple (CBMCEither a b) (CBMCEither a b) - where - simpleFresh = derivedSameShapeSimpleFresh - -instance - (GenSym () a, Mergeable a, GenSym () b, Mergeable b) => - GenSym () (CBMCEither a b) - where - fresh = derivedNoSpecFresh - -deriving newtype instance (SOrd a, SOrd b) => SOrd (CBMCEither a b) - -deriving newtype instance (ToCon e1 e2, ToCon a1 a2) => ToCon (Either e1 a1) (CBMCEither e2 a2) - -instance (ToCon e1 e2, ToCon a1 a2) => ToCon (CBMCEither e1 a1) (CBMCEither e2 a2) where - toCon (CBMCEither a) = CBMCEither <$> toCon a - -instance (ToCon e1 e2, ToCon a1 a2) => ToCon (CBMCEither e1 a1) (Either e2 a2) where - toCon (CBMCEither a) = toCon a - -deriving newtype instance (ToSym e1 e2, ToSym a1 a2) => ToSym (Either e1 a1) (CBMCEither e2 a2) - -instance (ToSym e1 e2, ToSym a1 a2) => ToSym (CBMCEither e1 a1) (CBMCEither e2 a2) where - toSym (CBMCEither a) = CBMCEither $ toSym a - -instance (ToSym e1 e2, ToSym a1 a2) => ToSym (CBMCEither e1 a1) (Either e2 a2) where - toSym (CBMCEither a) = toSym a - -data EitherIdx idx = L idx | R deriving (Eq, Ord, Show) - -instance (Mergeable e, Mergeable a) => Mergeable (CBMCEither e a) where - rootStrategy = rootStrategy1 - -instance (Mergeable e) => Mergeable1 (CBMCEither e) where - liftRootStrategy ms = case rootStrategy of - SimpleStrategy m -> - SortedStrategy - ( \(CBMCEither e) -> case e of - Left _ -> False - Right _ -> True - ) - ( \case - False -> SimpleStrategy $ - \cond (CBMCEither le) (CBMCEither re) -> case (le, re) of - (Left l, Left r) -> CBMCEither $ Left $ m cond l r - _ -> error "impossible" - True -> wrapStrategy ms (CBMCEither . Right) (\case (CBMCEither (Right x)) -> x; _ -> error "impossible") - ) - NoStrategy -> - SortedStrategy - ( \(CBMCEither e) -> case e of - Left _ -> False - Right _ -> True - ) - ( \case - False -> NoStrategy - True -> wrapStrategy ms (CBMCEither . Right) (\case (CBMCEither (Right x)) -> x; _ -> error "impossible") - ) - SortedStrategy idx sub -> - SortedStrategy - ( \(CBMCEither e) -> case e of - Left v -> L $ idx v - Right _ -> R - ) - ( \case - L i -> wrapStrategy (sub i) (CBMCEither . Left) (\case (CBMCEither (Left x)) -> x; _ -> error "impossible") - R -> wrapStrategy ms (CBMCEither . Right) (\case (CBMCEither (Right x)) -> x; _ -> error "impossible") - ) - -cbmcEither :: forall a c b. (a -> c) -> (b -> c) -> CBMCEither a b -> c -cbmcEither l r v = either l r (unsafeCoerce v) - --- | Wrap an 'Either' value in 'CBMCExceptT' -cbmcExcept :: (Monad m) => Either e a -> CBMCExceptT e m a -cbmcExcept m = CBMCExceptT (return $ CBMCEither m) - --- | Map the error and values in a 'CBMCExceptT' -mapCBMCExceptT :: (m (Either e a) -> n (Either e' b)) -> CBMCExceptT e m a -> CBMCExceptT e' n b -mapCBMCExceptT f m = CBMCExceptT $ (unsafeCoerce . f . unsafeCoerce) (runCBMCExceptT m) - --- | Map the error in a 'CBMCExceptT' -withCBMCExceptT :: (Functor m) => (e -> e') -> CBMCExceptT e m a -> CBMCExceptT e' m a -withCBMCExceptT f = mapCBMCExceptT $ fmap $ either (Left . f) Right - --- | Similar to 'ExceptT', but with different error handling mechanism. -newtype CBMCExceptT e m a = CBMCExceptT {runCBMCExceptT :: m (CBMCEither e a)} deriving stock (Generic, Generic1) - -instance (Eq e, Eq1 m) => Eq1 (CBMCExceptT e m) where - liftEq eq (CBMCExceptT x) (CBMCExceptT y) = liftEq (liftEq eq) x y - {-# INLINE liftEq #-} - -instance (Ord e, Ord1 m) => Ord1 (CBMCExceptT e m) where - liftCompare comp (CBMCExceptT x) (CBMCExceptT y) = - liftCompare (liftCompare comp) x y - {-# INLINE liftCompare #-} - -instance (Read e, Read1 m) => Read1 (CBMCExceptT e m) where - liftReadsPrec rp rl = - readsData $ - readsUnaryWith (liftReadsPrec rp' rl') "CBMCExceptT" CBMCExceptT - where - rp' = liftReadsPrec rp rl - rl' = liftReadList rp rl - -instance (Show e, Show1 m) => Show1 (CBMCExceptT e m) where - liftShowsPrec sp sl d (CBMCExceptT m) = - showsUnaryWith (liftShowsPrec sp' sl') "CBMCExceptT" d m - where - sp' = liftShowsPrec sp sl - sl' = liftShowList sp sl - -instance (Eq e, Eq1 m, Eq a) => Eq (CBMCExceptT e m a) where - (==) = eq1 - -instance (Ord e, Ord1 m, Ord a) => Ord (CBMCExceptT e m a) where - compare = compare1 - -instance (Read e, Read1 m, Read a) => Read (CBMCExceptT e m a) where - readsPrec = readsPrec1 - -instance (Show e, Show1 m, Show a) => Show (CBMCExceptT e m a) where - showsPrec = showsPrec1 - -instance (Functor m) => Functor (CBMCExceptT e m) where - fmap f = CBMCExceptT . fmap (fmap f) . runCBMCExceptT - {-# INLINE fmap #-} - -instance (Foldable f) => Foldable (CBMCExceptT e f) where - foldMap f (CBMCExceptT a) = foldMap (cbmcEither (const mempty) f) a - {-# INLINE foldMap #-} - -instance (Traversable f) => Traversable (CBMCExceptT e f) where - traverse f (CBMCExceptT a) = - CBMCExceptT <$> traverse (cbmcEither (pure . CBMCEither . Left) (fmap (CBMCEither . Right) . f)) a - {-# INLINE traverse #-} - -instance (Functor m, Monad m) => Applicative (CBMCExceptT e m) where - pure a = CBMCExceptT $ return (CBMCEither . Right $ a) - {-# INLINE pure #-} - CBMCExceptT f <*> CBMCExceptT v = CBMCExceptT $ do - mf <- f - case mf of - CBMCEither (Left e) -> return (CBMCEither . Left $ e) - CBMCEither (Right k) -> do - mv <- v - case mv of - CBMCEither (Left e) -> return (CBMCEither . Left $ e) - CBMCEither (Right x) -> return (CBMCEither . Right $ k x) - {-# INLINEABLE (<*>) #-} - m *> k = m >> k - {-# INLINE (*>) #-} - -instance (Functor m, Monad m, Monoid e) => Alternative (CBMCExceptT e m) where - empty = CBMCExceptT $ return (CBMCEither . Left $ mempty) - {-# INLINE empty #-} - CBMCExceptT mx <|> CBMCExceptT my = CBMCExceptT $ do - ex <- mx - case ex of - CBMCEither (Left e) -> fmap (cbmcEither (CBMCEither . Left . mappend e) (CBMCEither . Right)) my - CBMCEither (Right x) -> return (CBMCEither . Right $ x) - {-# INLINEABLE (<|>) #-} - -instance (Monad m) => Monad (CBMCExceptT e m) where - m >>= k = CBMCExceptT $ do - a <- runCBMCExceptT m - case a of - CBMCEither (Left e) -> return (CBMCEither $ Left e) - CBMCEither (Right x) -> runCBMCExceptT (k x) - {-# INLINE (>>=) #-} - -instance (Fail.MonadFail m) => Fail.MonadFail (CBMCExceptT e m) where - fail = CBMCExceptT . Fail.fail - {-# INLINE fail #-} - -instance (Monad m, Monoid e) => MonadPlus (CBMCExceptT e m) where - mzero = CBMCExceptT $ return (CBMCEither $ Left mempty) - {-# INLINE mzero #-} - CBMCExceptT mx `mplus` CBMCExceptT my = CBMCExceptT $ do - ex <- mx - case ex of - CBMCEither (Left e) -> fmap (cbmcEither (CBMCEither . Left . mappend e) (CBMCEither . Right)) my - CBMCEither (Right x) -> return (CBMCEither $ Right x) - {-# INLINEABLE mplus #-} - -instance (MonadFix m) => MonadFix (CBMCExceptT e m) where - mfix f = CBMCExceptT (mfix (runCBMCExceptT . f . cbmcEither (const bomb) id)) - where - bomb = error "mfix (CBMCExceptT): inner computation returned Left value" - {-# INLINE mfix #-} - -instance MonadTrans (CBMCExceptT e) where - lift = CBMCExceptT . fmap (CBMCEither . Right) - {-# INLINE lift #-} - -instance (MonadIO m) => MonadIO (CBMCExceptT e m) where - liftIO = lift . liftIO - {-# INLINE liftIO #-} - -instance (MonadZip m) => MonadZip (CBMCExceptT e m) where - mzipWith f (CBMCExceptT a) (CBMCExceptT b) = CBMCExceptT $ mzipWith (liftA2 f) a b - {-# INLINE mzipWith #-} - -instance (Contravariant m) => Contravariant (CBMCExceptT e m) where - contramap f = CBMCExceptT . contramap (fmap f) . runCBMCExceptT - {-# INLINE contramap #-} - -throwE :: (Monad m) => e -> CBMCExceptT e m a -throwE = CBMCExceptT . return . CBMCEither . Left -{-# INLINE throwE #-} - -catchE :: - (Monad m) => - CBMCExceptT e m a -> - (e -> CBMCExceptT e' m a) -> - CBMCExceptT e' m a -m `catchE` h = CBMCExceptT $ do - a <- runCBMCExceptT m - case a of - CBMCEither (Left l) -> runCBMCExceptT (h l) - CBMCEither (Right r) -> return (CBMCEither . Right $ r) -{-# INLINE catchE #-} - -instance (Monad m) => OrigExcept.MonadError e (CBMCExceptT e m) where - throwError = throwE - {-# INLINE throwError #-} - catchError = catchE - {-# INLINE catchError #-} - -instance (SEq (m (CBMCEither e a))) => SEq (CBMCExceptT e m a) where - (CBMCExceptT a) .== (CBMCExceptT b) = a .== b - {-# INLINE (.==) #-} - -instance (EvaluateSym (m (CBMCEither e a))) => EvaluateSym (CBMCExceptT e m a) where - evaluateSym fillDefault model (CBMCExceptT v) = CBMCExceptT $ evaluateSym fillDefault model v - {-# INLINE evaluateSym #-} - -instance - (ExtractSymbolics (m (CBMCEither e a))) => - ExtractSymbolics (CBMCExceptT e m a) - where - extractSymbolics (CBMCExceptT v) = extractSymbolics v - -instance - (Mergeable1 m, Mergeable e, Mergeable a) => - Mergeable (CBMCExceptT e m a) - where - rootStrategy = wrapStrategy rootStrategy1 CBMCExceptT runCBMCExceptT - {-# INLINE rootStrategy #-} - -instance (Mergeable1 m, Mergeable e) => Mergeable1 (CBMCExceptT e m) where - liftRootStrategy m = wrapStrategy (liftRootStrategy (liftRootStrategy m)) CBMCExceptT runCBMCExceptT - {-# INLINE liftRootStrategy #-} - -instance - {-# OVERLAPPABLE #-} - ( GenSym spec (m (CBMCEither a b)), - Mergeable1 m, - Mergeable a, - Mergeable b - ) => - GenSym spec (CBMCExceptT a m b) - where - fresh v = do - x <- fresh v - return $ merge . fmap CBMCExceptT $ x - -instance - {-# OVERLAPPABLE #-} - ( GenSymSimple spec (m (CBMCEither a b)) - ) => - GenSymSimple spec (CBMCExceptT a m b) - where - simpleFresh v = CBMCExceptT <$> simpleFresh v - -instance - {-# OVERLAPPING #-} - ( GenSymSimple (m (CBMCEither e a)) (m (CBMCEither e a)) - ) => - GenSymSimple (CBMCExceptT e m a) (CBMCExceptT e m a) - where - simpleFresh (CBMCExceptT v) = CBMCExceptT <$> simpleFresh v - -instance - {-# OVERLAPPING #-} - ( GenSymSimple (m (CBMCEither e a)) (m (CBMCEither e a)), - Mergeable1 m, - Mergeable e, - Mergeable a - ) => - GenSym (CBMCExceptT e m a) (CBMCExceptT e m a) - -instance - (UnionLike m, Mergeable e, Mergeable a) => - SimpleMergeable (CBMCExceptT e m a) - where - mrgIte = mrgIf - {-# INLINE mrgIte #-} - -instance - (UnionLike m, Mergeable e) => - SimpleMergeable1 (CBMCExceptT e m) - where - liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) - {-# INLINE liftMrgIte #-} - -instance - (UnionLike m, Mergeable e) => - UnionLike (CBMCExceptT e m) - where - mergeWithStrategy s (CBMCExceptT v) = CBMCExceptT $ mergeWithStrategy (liftRootStrategy s) v - {-# INLINE mergeWithStrategy #-} - mrgIfWithStrategy s cond (CBMCExceptT t) (CBMCExceptT f) = CBMCExceptT $ mrgIfWithStrategy (liftRootStrategy s) cond t f - {-# INLINE mrgIfWithStrategy #-} - single = CBMCExceptT . single . return - {-# INLINE single #-} - unionIf cond (CBMCExceptT l) (CBMCExceptT r) = CBMCExceptT $ unionIf cond l r - {-# INLINE unionIf #-} - -instance (SOrd (m (CBMCEither e a))) => SOrd (CBMCExceptT e m a) where - (CBMCExceptT l) .<= (CBMCExceptT r) = l .<= r - (CBMCExceptT l) .< (CBMCExceptT r) = l .< r - (CBMCExceptT l) .>= (CBMCExceptT r) = l .>= r - (CBMCExceptT l) .> (CBMCExceptT r) = l .> r - symCompare (CBMCExceptT l) (CBMCExceptT r) = symCompare l r - -instance - (ToCon (m1 (CBMCEither e1 a)) (m2 (CBMCEither e2 b))) => - ToCon (CBMCExceptT e1 m1 a) (CBMCExceptT e2 m2 b) - where - toCon (CBMCExceptT v) = CBMCExceptT <$> toCon v - -instance - (ToCon (m1 (CBMCEither e1 a)) (Either e2 b)) => - ToCon (CBMCExceptT e1 m1 a) (Either e2 b) - where - toCon (CBMCExceptT v) = toCon v - -instance - (ToSym (m1 (CBMCEither e1 a)) (m2 (CBMCEither e2 b))) => - ToSym (CBMCExceptT e1 m1 a) (CBMCExceptT e2 m2 b) - where - toSym (CBMCExceptT v) = CBMCExceptT $ toSym v - -instance - (Monad u, UnionLike u, Mergeable e, Mergeable v) => - UnionWithExcept (CBMCExceptT e u v) u e v - where - extractUnionExcept = merge . fmap runCBMCEither . runCBMCExceptT - -instance UnionWithExcept (UnionM (CBMCEither e v)) UnionM e v where - extractUnionExcept = fmap runCBMCEither diff --git a/src/Grisette/Core/Control/Monad/Class/MonadParallelUnion.hs b/src/Grisette/Core/Control/Monad/Class/MonadParallelUnion.hs deleted file mode 100644 --- a/src/Grisette/Core/Control/Monad/Class/MonadParallelUnion.hs +++ /dev/null @@ -1,124 +0,0 @@ -{-# LANGUAGE LambdaCase #-} - --- | --- Module : Grisette.Core.Control.Monad.Class.MonadParallelUnion --- Copyright : (c) Sirui Lu 2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Core.Control.Monad.Class.MonadParallelUnion - ( MonadParallelUnion (..), - ) -where - -import Control.DeepSeq (NFData) -import Control.Monad.Except (ExceptT (ExceptT), runExceptT) -import Control.Monad.Identity (IdentityT (IdentityT, runIdentityT)) -import qualified Control.Monad.RWS.Lazy as RWSLazy -import qualified Control.Monad.RWS.Strict as RWSStrict -import Control.Monad.Reader (ReaderT (ReaderT, runReaderT)) -import qualified Control.Monad.State.Lazy as StateLazy -import qualified Control.Monad.State.Strict as StateStrict -import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) -import qualified Control.Monad.Writer.Lazy as WriterLazy -import qualified Control.Monad.Writer.Strict as WriterStrict -import Grisette.Core.Data.Class.Mergeable (Mergeable) -import Grisette.Core.Data.Class.SimpleMergeable - ( UnionLike, - merge, - ) - --- | Parallel union monad. --- --- With the @QualifiedDo@ extension and the "Grisette.Qualified.ParallelUnionDo" --- module, one can execute the paths in parallel and merge the results with: --- --- > :set -XQualifiedDo -XOverloadedStrings --- > import Grisette --- > import qualified Grisette.Qualified.ParallelUnionDo as P --- > P.do --- > x <- mrgIf "a" (return 1) (return 2) :: UnionM Int --- > return $ x + 1 --- > --- > -- {If a 2 3} -class (UnionLike m, Monad m) => MonadParallelUnion m where - parBindUnion :: (Mergeable b, NFData b) => m a -> (a -> m b) -> m b - -instance (MonadParallelUnion m) => MonadParallelUnion (MaybeT m) where - parBindUnion (MaybeT x) f = - MaybeT $ - x `parBindUnion` \case - Nothing -> return Nothing - Just x'' -> runMaybeT $ f x'' - {-# INLINE parBindUnion #-} - -instance (MonadParallelUnion m, Mergeable e, NFData e) => MonadParallelUnion (ExceptT e m) where - parBindUnion (ExceptT x) f = - ExceptT $ - x `parBindUnion` \case - Left e -> return $ Left e - Right x'' -> runExceptT $ f x'' - {-# INLINE parBindUnion #-} - -instance (MonadParallelUnion m, Mergeable s, NFData s) => MonadParallelUnion (StateLazy.StateT s m) where - parBindUnion (StateLazy.StateT x) f = StateLazy.StateT $ \s -> - x s `parBindUnion` \case - ~(a, s') -> StateLazy.runStateT (f a) s' - {-# INLINE parBindUnion #-} - -instance (MonadParallelUnion m, Mergeable s, NFData s) => MonadParallelUnion (StateStrict.StateT s m) where - parBindUnion (StateStrict.StateT x) f = StateStrict.StateT $ \s -> - x s `parBindUnion` \case - (a, s') -> StateStrict.runStateT (f a) s' - {-# INLINE parBindUnion #-} - -instance (MonadParallelUnion m, Mergeable s, Monoid s, NFData s) => MonadParallelUnion (WriterLazy.WriterT s m) where - parBindUnion (WriterLazy.WriterT x) f = - WriterLazy.WriterT $ - x `parBindUnion` \case - ~(a, w) -> - WriterLazy.runWriterT (f a) `parBindUnion` \case - ~(b, w') -> return (b, w <> w') - {-# INLINE parBindUnion #-} - -instance (MonadParallelUnion m, Mergeable s, Monoid s, NFData s) => MonadParallelUnion (WriterStrict.WriterT s m) where - parBindUnion (WriterStrict.WriterT x) f = - WriterStrict.WriterT $ - x `parBindUnion` \case - (a, w) -> - WriterStrict.runWriterT (f a) `parBindUnion` \case - (b, w') -> return (b, w <> w') - {-# INLINE parBindUnion #-} - -instance (MonadParallelUnion m, Mergeable a, NFData a) => MonadParallelUnion (ReaderT a m) where - parBindUnion (ReaderT x) f = ReaderT $ \a -> - x a `parBindUnion` \a' -> runReaderT (f a') a - {-# INLINE parBindUnion #-} - -instance (MonadParallelUnion m) => MonadParallelUnion (IdentityT m) where - parBindUnion (IdentityT x) f = IdentityT $ x `parBindUnion` (merge . runIdentityT . f) - {-# INLINE parBindUnion #-} - -instance - (MonadParallelUnion m, Mergeable s, Mergeable r, Mergeable w, Monoid w, NFData r, NFData w, NFData s) => - MonadParallelUnion (RWSStrict.RWST r w s m) - where - parBindUnion m k = RWSStrict.RWST $ \r s -> - RWSStrict.runRWST m r s `parBindUnion` \case - (a, s', w) -> - RWSStrict.runRWST (k a) r s' `parBindUnion` \case - (b, s'', w') -> return (b, s'', w <> w') - {-# INLINE parBindUnion #-} - -instance - (MonadParallelUnion m, Mergeable s, Mergeable r, Mergeable w, Monoid w, NFData r, NFData w, NFData s) => - MonadParallelUnion (RWSLazy.RWST r w s m) - where - parBindUnion m k = RWSLazy.RWST $ \r s -> - RWSLazy.runRWST m r s `parBindUnion` \case - ~(a, s', w) -> - RWSLazy.runRWST (k a) r s' `parBindUnion` \case - ~(b, s'', w') -> return (b, s'', w <> w') - {-# INLINE parBindUnion #-} diff --git a/src/Grisette/Core/Control/Monad/Union.hs b/src/Grisette/Core/Control/Monad/Union.hs deleted file mode 100644 --- a/src/Grisette/Core/Control/Monad/Union.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- Module : Grisette.Core.Control.Monad.Union --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Core.Control.Monad.Union - ( -- * MonadUnion - MonadUnion, - ) -where - -import Grisette.Core.Data.Class.SimpleMergeable (UnionLike) - --- $setup --- >>> import Grisette.Core --- >>> import Grisette.IR.SymPrim - --- | Class for monads that support union-like operations and 'Grisette.Core.Data.Class.Mergeable' knowledge propagation. -type MonadUnion u = (UnionLike u, Monad u) diff --git a/src/Grisette/Core/Control/Monad/UnionM.hs b/src/Grisette/Core/Control/Monad/UnionM.hs deleted file mode 100644 --- a/src/Grisette/Core/Control/Monad/UnionM.hs +++ /dev/null @@ -1,608 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# HLINT ignore "Use <&>" #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskellQuotes #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - --- {-# OPTIONS_GHC -fno-full-laziness #-} - --- | --- Module : Grisette.Core.Control.Monad.UnionM --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Core.Control.Monad.UnionM - ( -- * UnionM and helpers - UnionM (..), - liftToMonadUnion, - underlyingUnion, - isMerged, - (.#), - IsConcrete, - unionSize, - ) -where - -import Control.DeepSeq (NFData (rnf), NFData1 (liftRnf), force, rnf1) -import Control.Parallel.Strategies (rpar, rseq, runEval) -import Data.Functor.Classes - ( Eq1 (liftEq), - Show1 (liftShowsPrec), - showsPrec1, - ) -import qualified Data.HashMap.Lazy as HML -import Data.Hashable (Hashable (hashWithSalt)) -import Data.String (IsString (fromString)) -import GHC.TypeNats (KnownNat, type (<=)) -import Grisette.Core.Control.Monad.Class.MonadParallelUnion - ( MonadParallelUnion (parBindUnion), - ) -import Grisette.Core.Control.Monad.Union (MonadUnion) -import Grisette.Core.Data.BV (IntN, WordN) -import Grisette.Core.Data.Class.EvaluateSym (EvaluateSym (evaluateSym)) -import Grisette.Core.Data.Class.ExtractSymbolics - ( ExtractSymbolics (extractSymbolics), - ) -import Grisette.Core.Data.Class.Function (Function (Arg, Ret, (#))) -import Grisette.Core.Data.Class.GPretty - ( GPretty (gpretty), - groupedEnclose, - ) -import Grisette.Core.Data.Class.ITEOp (ITEOp (symIte)) -import Grisette.Core.Data.Class.LogicalOp - ( LogicalOp (symImplies, symNot, symXor, (.&&), (.||)), - ) -import Grisette.Core.Data.Class.Mergeable - ( Mergeable (rootStrategy), - Mergeable1 (liftRootStrategy), - MergingStrategy (SimpleStrategy), - ) -import Grisette.Core.Data.Class.SEq (SEq ((.==))) -import Grisette.Core.Data.Class.SimpleMergeable - ( SimpleMergeable (mrgIte), - SimpleMergeable1 (liftMrgIte), - UnionLike (mergeWithStrategy, mrgIfWithStrategy, single, unionIf), - UnionPrjOp (ifView, leftMost, singleView), - merge, - mrgIf, - mrgSingle, - simpleMerge, - (.#), - ) -import Grisette.Core.Data.Class.Solvable - ( Solvable (con, conView, iinfosym, isym, sinfosym, ssym), - pattern Con, - ) -import Grisette.Core.Data.Class.Solver (UnionWithExcept (extractUnionExcept)) -import Grisette.Core.Data.Class.SubstituteSym (SubstituteSym (substituteSym)) -import Grisette.Core.Data.Class.ToCon (ToCon (toCon)) -import Grisette.Core.Data.Class.ToSym (ToSym (toSym)) -import Grisette.Core.Data.Union - ( Union (UnionIf, UnionSingle), - fullReconstruct, - ifWithStrategy, - ) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term - ( LinkedRep, - SupportedPrim, - type (-->), - ) -import Grisette.IR.SymPrim.Data.SymPrim - ( AllSyms (allSymsS), - SymBool, - SymIntN, - SymInteger, - SymWordN, - type (-~>), - type (=~>), - ) -import Grisette.IR.SymPrim.Data.TabularFun (type (=->)) -import Language.Haskell.TH.Syntax (Lift (lift, liftTyped)) -import Language.Haskell.TH.Syntax.Compat (unTypeSplice) - --- $setup --- >>> import Grisette.Core --- >>> import Grisette.IR.SymPrim --- >>> :set -XScopedTypeVariables - --- | 'UnionM' is the 'Union' container (hidden) enhanced with --- 'MergingStrategy' --- [knowledge propagation](https://okmij.org/ftp/Haskell/set-monad.html#PE). --- --- The 'Union' models the underlying semantics evaluation semantics for --- unsolvable types with the nested if-then-else tree semantics, and can be --- viewed as the following structure: --- --- > data Union a --- > = Single a --- > | If bool (Union a) (Union a) --- --- The 'Single' constructor is for a single value with the path condition --- @true@, and the 'If' constructor is the if operator in an if-then-else --- tree. --- For clarity, when printing a 'UnionM' value, we will omit the 'Single' --- constructor. The following two representations has the same semantics. --- --- > If c1 (If c11 v11 (If c12 v12 v13)) --- > (If c2 v2 --- > v3) --- --- \[ --- \left\{\begin{aligned}&t_1&&\mathrm{if}&&c_1\\&v_2&&\mathrm{else if}&&c_2\\&v_3&&\mathrm{otherwise}&&\end{aligned}\right.\hspace{2em}\mathrm{where}\hspace{2em}t_1 = \left\{\begin{aligned}&v_{11}&&\mathrm{if}&&c_{11}\\&v_{12}&&\mathrm{else if}&&c_{12}\\&v_{13}&&\mathrm{otherwise}&&\end{aligned}\right. --- \] --- --- To reduce the size of the if-then-else tree to reduce the number of paths to --- execute, Grisette would merge the branches in a 'Union' container and --- maintain a representation invariant for them. To perform this merging --- procedure, Grisette relies on a type class called 'Mergeable' and the --- merging strategy defined by it. --- --- 'Union' is a monad, so we can easily write code with the do-notation and --- monadic combinators. However, the standard monadic operators cannot --- resolve any extra constraints, including the 'Mergeable' constraint (see --- [The constrained-monad --- problem](https://dl.acm.org/doi/10.1145/2500365.2500602) --- by Sculthorpe et al.). --- This prevents the standard do-notations to merge the results automatically, --- and would result in bad performance or very verbose code. --- --- To reduce this boilerplate, Grisette provide another monad, 'UnionM' that --- would try to cache the merging strategy. --- The 'UnionM' has two data constructors (hidden intentionally), 'UAny' and 'UMrg'. --- The 'UAny' data constructor (printed as @<@@...@@>@) wraps an arbitrary (probably --- unmerged) 'Union'. It is constructed when no 'Mergeable' knowledge is --- available (for example, when constructed with Haskell\'s 'return'). --- The 'UMrg' data constructor (printed as @{...}@) wraps a merged 'UnionM' along with the --- 'Mergeable' constraint. This constraint can be propagated to the contexts --- without 'Mergeable' knowledge, and helps the system to merge the resulting --- 'Union'. --- --- __/Examples:/__ --- --- 'return' cannot resolve the 'Mergeable' constraint. --- --- >>> return 1 :: UnionM Integer --- <1> --- --- 'Grisette.Lib.Control.Monad.mrgReturn' can resolve the 'Mergeable' constraint. --- --- >>> import Grisette.Lib.Base --- >>> mrgReturn 1 :: UnionM Integer --- {1} --- --- 'unionIf' cannot resolve the 'Mergeable' constraint. --- --- >>> unionIf "a" (return 1) (unionIf "b" (return 1) (return 2)) :: UnionM Integer --- --- --- But 'unionIf' is able to merge the result if some of the branches are merged: --- --- >>> unionIf "a" (return 1) (unionIf "b" (mrgReturn 1) (return 2)) :: UnionM Integer --- {If (|| a b) 1 2} --- --- The '>>=' operator uses 'unionIf' internally. When the final statement in a do-block --- merges the values, the system can then merge the final result. --- --- >>> :{ --- do --- x <- unionIf (ssym "a") (return 1) (unionIf (ssym "b") (return 1) (return 2)) --- mrgSingle $ x + 1 :: UnionM Integer --- :} --- {If (|| a b) 2 3} --- --- Calling a function that merges a result at the last line of a do-notation --- will also merge the whole block. If you stick to these @mrg*@ combinators and --- all the functions will merge the results, the whole program can be --- symbolically evaluated efficiently. --- --- >>> f x y = mrgIf "c" x y --- >>> :{ --- do --- x <- unionIf (ssym "a") (return 1) (unionIf (ssym "b") (return 1) (return 2)) --- f x (x + 1) :: UnionM Integer --- :} --- {If (&& c (|| a b)) 1 (If (|| a (|| b c)) 2 3)} --- --- In "Grisette.Lib.Base", "Grisette.Lib.Mtl", we also provided more @mrg*@ --- variants of other combinators. You should stick to these combinators to --- ensure efficient merging by Grisette. -data UnionM a where - -- | 'UnionM' with no 'Mergeable' knowledge. - UAny :: - -- | Original 'Union'. - Union a -> - UnionM a - -- | 'UnionM' with 'Mergeable' knowledge. - UMrg :: - -- | Cached merging strategy. - MergingStrategy a -> - -- | Merged Union - Union a -> - UnionM a - -instance (NFData a) => NFData (UnionM a) where - rnf = rnf1 - -instance NFData1 UnionM where - liftRnf _a (UAny m) = liftRnf _a m - liftRnf _a (UMrg _ m) = liftRnf _a m - -instance (Lift a) => Lift (UnionM a) where - liftTyped (UAny v) = [||UAny v||] - liftTyped (UMrg _ v) = [||UAny v||] - lift = unTypeSplice . liftTyped - -instance (Show a) => (Show (UnionM a)) where - showsPrec = showsPrec1 - -liftShowsPrecUnion :: - forall a. - (Int -> a -> ShowS) -> - ([a] -> ShowS) -> - Int -> - Union a -> - ShowS -liftShowsPrecUnion sp _ i (UnionSingle a) = sp i a -liftShowsPrecUnion sp sl i (UnionIf _ _ cond t f) = - showParen (i > 10) $ - showString "If" - . showChar ' ' - . showsPrec 11 cond - . showChar ' ' - . sp1 11 t - . showChar ' ' - . sp1 11 f - where - sp1 = liftShowsPrecUnion sp sl - -wrapBracket :: Char -> Char -> ShowS -> ShowS -wrapBracket l r p = showChar l . p . showChar r - -instance Show1 UnionM where - liftShowsPrec sp sl _ (UAny a) = - wrapBracket '<' '>' - . liftShowsPrecUnion sp sl 0 - $ a - liftShowsPrec sp sl _ (UMrg _ a) = - wrapBracket '{' '}' - . liftShowsPrecUnion sp sl 0 - $ a - -instance (GPretty a) => GPretty (UnionM a) where - gpretty = \case - (UAny a) -> groupedEnclose "<" ">" $ gpretty a - (UMrg _ a) -> groupedEnclose "{" "}" $ gpretty a - --- | Extract the underlying Union. May be unmerged. -underlyingUnion :: UnionM a -> Union a -underlyingUnion (UAny a) = a -underlyingUnion (UMrg _ a) = a -{-# INLINE underlyingUnion #-} - --- | Check if a UnionM is already merged. -isMerged :: UnionM a -> Bool -isMerged UAny {} = False -isMerged UMrg {} = True -{-# INLINE isMerged #-} - -instance UnionPrjOp UnionM where - singleView = singleView . underlyingUnion - {-# INLINE singleView #-} - ifView (UAny u) = case ifView u of - Just (c, t, f) -> Just (c, UAny t, UAny f) - Nothing -> Nothing - ifView (UMrg m u) = case ifView u of - Just (c, t, f) -> Just (c, UMrg m t, UMrg m f) - Nothing -> Nothing - {-# INLINE ifView #-} - leftMost = leftMost . underlyingUnion - {-# INLINE leftMost #-} - -instance Functor UnionM where - fmap f fa = fa >>= return . f - {-# INLINE fmap #-} - -instance Applicative UnionM where - pure = single - {-# INLINE pure #-} - f <*> a = f >>= (\xf -> a >>= (return . xf)) - {-# INLINE (<*>) #-} - -bindUnion :: Union a -> (a -> UnionM b) -> UnionM b -bindUnion (UnionSingle a') f' = f' a' -bindUnion (UnionIf _ _ cond ifTrue ifFalse) f' = - unionIf cond (bindUnion ifTrue f') (bindUnion ifFalse f') -{-# INLINE bindUnion #-} - -instance Monad UnionM where - a >>= f = bindUnion (underlyingUnion a) f - {-# INLINE (>>=) #-} - -parBindUnion'' :: (Mergeable b, NFData b) => Union a -> (a -> UnionM b) -> UnionM b -parBindUnion'' (UnionSingle a) f = merge $ f a -parBindUnion'' u f = parBindUnion' u f - -parBindUnion' :: (Mergeable b, NFData b) => Union a -> (a -> UnionM b) -> UnionM b -parBindUnion' (UnionSingle a') f' = f' a' -parBindUnion' (UnionIf _ _ cond ifTrue ifFalse) f' = runEval $ do - l <- rpar $ force $ parBindUnion' ifTrue f' - r <- rpar $ force $ parBindUnion' ifFalse f' - l' <- rseq l - r' <- rseq r - rseq $ mrgIf cond l' r' -{-# INLINE parBindUnion' #-} - -instance MonadParallelUnion UnionM where - parBindUnion = parBindUnion'' . underlyingUnion - {-# INLINE parBindUnion #-} - -instance (Mergeable a) => Mergeable (UnionM a) where - rootStrategy = SimpleStrategy $ \cond t f -> unionIf cond t f >>= mrgSingle - {-# INLINE rootStrategy #-} - -instance (Mergeable a) => SimpleMergeable (UnionM a) where - mrgIte = mrgIf - {-# INLINE mrgIte #-} - -instance Mergeable1 UnionM where - liftRootStrategy m = SimpleStrategy $ - \cond t f -> unionIf cond t f >>= (UMrg m . UnionSingle) - {-# INLINE liftRootStrategy #-} - -instance SimpleMergeable1 UnionM where - liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) - {-# INLINE liftMrgIte #-} - -instance UnionLike UnionM where - mergeWithStrategy _ m@(UMrg _ _) = m - mergeWithStrategy s (UAny u) = UMrg s $ fullReconstruct s u - {-# INLINE mergeWithStrategy #-} - mrgIfWithStrategy s (Con c) l r = if c then mergeWithStrategy s l else mergeWithStrategy s r - mrgIfWithStrategy s cond l r = - mergeWithStrategy s $ unionIf cond l r - {-# INLINE mrgIfWithStrategy #-} - single = UAny . single - {-# INLINE single #-} - unionIf cond (UAny a) (UAny b) = UAny $ unionIf cond a b - unionIf cond (UMrg m a) (UAny b) = UMrg m $ ifWithStrategy m cond a b - unionIf cond a (UMrg m b) = UMrg m $ ifWithStrategy m cond (underlyingUnion a) b - {-# INLINE unionIf #-} - -instance (SEq a) => SEq (UnionM a) where - x .== y = simpleMerge $ do - x1 <- x - y1 <- y - mrgSingle $ x1 .== y1 - --- | Lift the 'UnionM' to any 'MonadUnion'. -liftToMonadUnion :: (Mergeable a, MonadUnion u) => UnionM a -> u a -liftToMonadUnion u = go (underlyingUnion u) - where - go (UnionSingle v) = mrgSingle v - go (UnionIf _ _ c t f) = mrgIf c (go t) (go f) - -instance {-# INCOHERENT #-} (ToSym a b, Mergeable b) => ToSym a (UnionM b) where - toSym = mrgSingle . toSym - -instance (ToSym a b, Mergeable b) => ToSym (UnionM a) (UnionM b) where - toSym = merge . fmap toSym - -#define TO_SYM_FROM_UNION_CON_SIMPLE(contype, symtype) \ -instance ToSym (UnionM contype) symtype where \ - toSym = simpleMerge . fmap con - -#define TO_SYM_FROM_UNION_CON_BV(contype, symtype) \ -instance (KnownNat n, 1 <= n) => ToSym (UnionM (contype n)) (symtype n) where \ - toSym = simpleMerge . fmap con - -#define TO_SYM_FROM_UNION_CON_FUN(conop, symop) \ -instance (SupportedPrim ca, SupportedPrim cb, LinkedRep ca sa, LinkedRep cb sb) => ToSym (UnionM (conop ca cb)) (symop sa sb) where \ - toSym = simpleMerge . fmap con - -#define TO_SYM_FROM_UNION_CON_BV_SOME(contype, symtype) \ -instance ToSym (UnionM contype) symtype where \ - toSym = simpleMerge . fmap (toSym :: contype -> symtype) - -#if 1 -TO_SYM_FROM_UNION_CON_SIMPLE(Bool, SymBool) -TO_SYM_FROM_UNION_CON_SIMPLE(Integer, SymInteger) -TO_SYM_FROM_UNION_CON_BV(IntN, SymIntN) -TO_SYM_FROM_UNION_CON_BV(WordN, SymWordN) -TO_SYM_FROM_UNION_CON_FUN((=->), (=~>)) -TO_SYM_FROM_UNION_CON_FUN((-->), (-~>)) -#endif - -instance {-# INCOHERENT #-} (ToCon a b) => ToCon (UnionM a) b where - toCon v = go $ underlyingUnion v - where - go (UnionSingle x) = toCon x - go _ = Nothing - -instance (ToCon a b, Mergeable b) => ToCon (UnionM a) (UnionM b) where - toCon v = go $ underlyingUnion v - where - go (UnionSingle x) = case toCon x of - Nothing -> Nothing - Just v -> Just $ mrgSingle v - go (UnionIf _ _ c t f) = do - t' <- go t - f' <- go f - return $ mrgIf c t' f' - -instance (Mergeable a, EvaluateSym a) => EvaluateSym (UnionM a) where - evaluateSym fillDefault model x = go $ underlyingUnion x - where - go :: Union a -> UnionM a - go (UnionSingle v) = mrgSingle $ evaluateSym fillDefault model v - go (UnionIf _ _ cond t f) = - mrgIf - (evaluateSym fillDefault model cond) - (go t) - (go f) - -instance (Mergeable a, SubstituteSym a) => SubstituteSym (UnionM a) where - substituteSym sym val x = go $ underlyingUnion x - where - go :: Union a -> UnionM a - go (UnionSingle v) = mrgSingle $ substituteSym sym val v - go (UnionIf _ _ cond t f) = - mrgIf - (substituteSym sym val cond) - (go t) - (go f) - -instance - (ExtractSymbolics a) => - ExtractSymbolics (UnionM a) - where - extractSymbolics v = go $ underlyingUnion v - where - go (UnionSingle x) = extractSymbolics x - go (UnionIf _ _ cond t f) = extractSymbolics cond <> go t <> go f - -instance (Hashable a) => Hashable (UnionM a) where - s `hashWithSalt` (UAny u) = s `hashWithSalt` (0 :: Int) `hashWithSalt` u - s `hashWithSalt` (UMrg _ u) = s `hashWithSalt` (1 :: Int) `hashWithSalt` u - -instance (Eq a) => Eq (UnionM a) where - UAny l == UAny r = l == r - UMrg _ l == UMrg _ r = l == r - _ == _ = False - -instance Eq1 UnionM where - liftEq e l r = liftEq e (underlyingUnion l) (underlyingUnion r) - -instance (Num a, Mergeable a) => Num (UnionM a) where - fromInteger = mrgSingle . fromInteger - negate x = x >>= (mrgSingle . negate) - x + y = x >>= \x1 -> y >>= \y1 -> mrgSingle $ x1 + y1 - x - y = x >>= \x1 -> y >>= \y1 -> mrgSingle $ x1 - y1 - x * y = x >>= \x1 -> y >>= \y1 -> mrgSingle $ x1 * y1 - abs x = x >>= mrgSingle . abs - signum x = x >>= mrgSingle . signum - -instance (ITEOp a, Mergeable a) => ITEOp (UnionM a) where - symIte = mrgIf - -instance (LogicalOp a, Mergeable a) => LogicalOp (UnionM a) where - a .|| b = do - a1 <- a - b1 <- b - mrgSingle $ a1 .|| b1 - a .&& b = do - a1 <- a - b1 <- b - mrgSingle $ a1 .&& b1 - symNot x = do - x1 <- x - mrgSingle $ symNot x1 - symXor a b = do - a1 <- a - b1 <- b - mrgSingle $ a1 `symXor` b1 - symImplies a b = do - a1 <- a - b1 <- b - mrgSingle $ a1 `symImplies` b1 - -instance (Solvable c t, Mergeable t) => Solvable c (UnionM t) where - con = mrgSingle . con - {-# INLINE con #-} - ssym = mrgSingle . ssym - {-# INLINE ssym #-} - isym i s = mrgSingle $ isym i s - {-# INLINE isym #-} - sinfosym s info = mrgSingle $ sinfosym s info - {-# INLINE sinfosym #-} - iinfosym i s info = mrgSingle $ iinfosym i s info - {-# INLINE iinfosym #-} - conView v = do - c <- singleView v - conView c - {-# INLINE conView #-} - -instance - (Function f, Mergeable f, Mergeable a, Ret f ~ a) => - Function (UnionM f) - where - type Arg (UnionM f) = Arg f - type Ret (UnionM f) = UnionM (Ret f) - f # a = do - f1 <- f - mrgSingle $ f1 # a - -instance (IsString a, Mergeable a) => IsString (UnionM a) where - fromString = mrgSingle . fromString - --- AllSyms -instance (AllSyms a) => AllSyms (UnionM a) where - allSymsS = allSymsS . underlyingUnion - --- Concrete Key HashMaps - --- | Tag for concrete types. --- Useful for specifying the merge strategy for some parametrized types where we should have different --- merge strategy for symbolic and concrete ones. -class (Eq t, Ord t, Hashable t) => IsConcrete t - -instance IsConcrete Bool - -instance IsConcrete Integer - -instance (IsConcrete k, Mergeable t) => Mergeable (HML.HashMap k (UnionM (Maybe t))) where - rootStrategy = SimpleStrategy mrgIte - -instance (IsConcrete k, Mergeable t) => SimpleMergeable (HML.HashMap k (UnionM (Maybe t))) where - mrgIte cond l r = - HML.unionWith (mrgIf cond) ul ur - where - ul = - foldr - ( \k m -> case HML.lookup k m of - Nothing -> HML.insert k (mrgSingle Nothing) m - _ -> m - ) - l - (HML.keys r) - ur = - foldr - ( \k m -> case HML.lookup k m of - Nothing -> HML.insert k (mrgSingle Nothing) m - _ -> m - ) - r - (HML.keys l) - -instance UnionWithExcept (UnionM (Either e v)) UnionM e v where - extractUnionExcept = id - --- | The size of a union is defined as the number of branches. --- For example, --- --- >>> unionSize (single True) --- 1 --- >>> unionSize (mrgIf "a" (single 1) (single 2) :: UnionM Integer) --- 2 --- >>> unionSize (choose [1..7] "a" :: UnionM Integer) --- 7 -unionSize :: UnionM a -> Int -unionSize = unionSize' . underlyingUnion - where - unionSize' (UnionSingle _) = 1 - unionSize' (UnionIf _ _ _ l r) = unionSize' l + unionSize' r diff --git a/src/Grisette/Core/Data/BV.hs b/src/Grisette/Core/Data/BV.hs deleted file mode 100644 --- a/src/Grisette/Core/Data/BV.hs +++ /dev/null @@ -1,844 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskellQuotes #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -funbox-strict-fields #-} - --- | --- Module : Grisette.Core.Data.BV --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Core.Data.BV - ( BitwidthMismatch (..), - IntN (..), - WordN (..), - SomeIntN (..), - SomeWordN (..), - unarySomeIntN, - unarySomeIntNR1, - binSomeIntN, - binSomeIntNR1, - binSomeIntNR2, - unarySomeWordN, - unarySomeWordNR1, - binSomeWordN, - binSomeWordNR1, - binSomeWordNR2, - ) -where - -import Control.Applicative (Alternative ((<|>))) -import Control.DeepSeq (NFData (rnf)) -import Control.Exception - ( ArithException (Overflow), - Exception (displayException), - throw, - ) -import Data.Bits - ( Bits - ( bit, - bitSize, - bitSizeMaybe, - clearBit, - complement, - complementBit, - isSigned, - popCount, - rotate, - rotateL, - rotateR, - setBit, - shift, - shiftL, - shiftR, - testBit, - unsafeShiftL, - unsafeShiftR, - xor, - zeroBits, - (.&.), - (.|.) - ), - FiniteBits (countLeadingZeros, countTrailingZeros, finiteBitSize), - ) -import Data.Hashable (Hashable (hashWithSalt)) -import Data.Maybe (fromMaybe, isJust) -import Data.Proxy (Proxy (Proxy)) -import Data.Typeable (type (:~:) (Refl)) -import GHC.Enum - ( boundedEnumFrom, - boundedEnumFromThen, - predError, - succError, - toEnumError, - ) -import GHC.Generics (Generic) -import GHC.Read - ( Read (readListPrec, readPrec), - parens, - readListDefault, - readListPrecDefault, - readNumber, - ) -import GHC.Real ((%)) -import GHC.TypeNats - ( KnownNat, - Nat, - natVal, - sameNat, - type (+), - type (<=), - ) -import Grisette.Core.Data.Class.BitVector - ( BV (bvConcat, bvExt, bvSelect, bvSext, bvZext), - SizedBV - ( sizedBVConcat, - sizedBVExt, - sizedBVSelect, - sizedBVSext, - sizedBVZext - ), - ) -import Grisette.Core.Data.Class.SignConversion - ( SignConversion (toSigned, toUnsigned), - ) -import Grisette.Core.Data.Class.SymRotate - ( DefaultFiniteBitsSymRotate (DefaultFiniteBitsSymRotate), - SymRotate, - ) -import Grisette.Core.Data.Class.SymShift - ( DefaultFiniteBitsSymShift (DefaultFiniteBitsSymShift), - SymShift, - ) -import Grisette.Utils.Parameterized - ( KnownProof (KnownProof), - LeqProof (LeqProof), - knownAdd, - leqAddPos, - unsafeKnownProof, - unsafeLeqProof, - ) -import Language.Haskell.TH.Syntax (Lift (liftTyped)) -import Numeric (showHex, showIntAtBase) -import qualified Test.QuickCheck as QC -import Text.ParserCombinators.ReadP (string) -import Text.ParserCombinators.ReadPrec - ( ReadPrec, - get, - look, - pfail, - ) -import Text.Read (lift) -import qualified Text.Read.Lex as L - -data BitwidthMismatch = BitwidthMismatch - deriving (Show, Eq, Ord, Generic) - -instance Exception BitwidthMismatch where - displayException BitwidthMismatch = "Bit width does not match" - --- | --- Symbolic unsigned bit vectors. -newtype WordN (n :: Nat) = WordN {unWordN :: Integer} - deriving (Eq, Ord, Generic, Lift, Hashable, NFData) - --- | --- A non-indexed version of 'WordN'. -data SomeWordN where - SomeWordN :: (KnownNat n, 1 <= n) => WordN n -> SomeWordN - -unarySomeWordN :: (forall n. (KnownNat n, 1 <= n) => WordN n -> r) -> SomeWordN -> r -unarySomeWordN op (SomeWordN (w :: WordN w)) = op w -{-# INLINE unarySomeWordN #-} - -unarySomeWordNR1 :: (forall n. (KnownNat n, 1 <= n) => WordN n -> WordN n) -> SomeWordN -> SomeWordN -unarySomeWordNR1 op (SomeWordN (w :: WordN w)) = SomeWordN $ op w -{-# INLINE unarySomeWordNR1 #-} - -binSomeWordN :: (forall n. (KnownNat n, 1 <= n) => WordN n -> WordN n -> r) -> SomeWordN -> SomeWordN -> r -binSomeWordN op (SomeWordN (l :: WordN l)) (SomeWordN (r :: WordN r)) = - case sameNat (Proxy @l) (Proxy @r) of - Just Refl -> op l r - Nothing -> throw BitwidthMismatch -{-# INLINE binSomeWordN #-} - -binSomeWordNR1 :: (forall n. (KnownNat n, 1 <= n) => WordN n -> WordN n -> WordN n) -> SomeWordN -> SomeWordN -> SomeWordN -binSomeWordNR1 op (SomeWordN (l :: WordN l)) (SomeWordN (r :: WordN r)) = - case sameNat (Proxy @l) (Proxy @r) of - Just Refl -> SomeWordN $ op l r - Nothing -> throw BitwidthMismatch -{-# INLINE binSomeWordNR1 #-} - -binSomeWordNR2 :: (forall n. (KnownNat n, 1 <= n) => WordN n -> WordN n -> (WordN n, WordN n)) -> SomeWordN -> SomeWordN -> (SomeWordN, SomeWordN) -binSomeWordNR2 op (SomeWordN (l :: WordN l)) (SomeWordN (r :: WordN r)) = - case sameNat (Proxy @l) (Proxy @r) of - Just Refl -> - case op l r of - (a, b) -> (SomeWordN a, SomeWordN b) - Nothing -> throw BitwidthMismatch -{-# INLINE binSomeWordNR2 #-} - -instance Eq SomeWordN where - SomeWordN (l :: WordN l) == SomeWordN (r :: WordN r) = - case sameNat (Proxy @l) (Proxy @r) of - Just Refl -> l == r - Nothing -> False - {-# INLINE (==) #-} - SomeWordN (l :: WordN l) /= SomeWordN (r :: WordN r) = - case sameNat (Proxy @l) (Proxy @r) of - Just Refl -> l /= r - Nothing -> True - {-# INLINE (/=) #-} - -instance Ord SomeWordN where - (<=) = binSomeWordN (<=) - {-# INLINE (<=) #-} - (<) = binSomeWordN (<) - {-# INLINE (<) #-} - (>=) = binSomeWordN (>=) - {-# INLINE (>=) #-} - (>) = binSomeWordN (>) - {-# INLINE (>) #-} - max = binSomeWordNR1 max - {-# INLINE max #-} - min = binSomeWordNR1 min - {-# INLINE min #-} - compare = binSomeWordN compare - {-# INLINE compare #-} - -instance Lift SomeWordN where - liftTyped (SomeWordN w) = [||SomeWordN w||] - -instance Hashable SomeWordN where - s `hashWithSalt` (SomeWordN (w :: WordN n)) = s `hashWithSalt` natVal (Proxy @n) `hashWithSalt` w - -instance NFData SomeWordN where - rnf (SomeWordN w) = rnf w - -instance (KnownNat n, 1 <= n) => Show (WordN n) where - show (WordN w) = if (bitwidth `mod` 4) == 0 then hexRepPre ++ hexRep else binRepPre ++ binRep - where - bitwidth = natVal (Proxy :: Proxy n) - hexRepPre = "0x" ++ replicate (fromIntegral (bitwidth `div` 4) - length hexRep) '0' - hexRep = showHex w "" - binRepPre = "0b" ++ replicate (fromIntegral bitwidth - length binRep) '0' - binRep = showIntAtBase 2 (\x -> if x == 0 then '0' else '1') w "" - -convertInt :: (Num a) => L.Lexeme -> ReadPrec a -convertInt (L.Number n) - | Just i <- L.numberToInteger n = return (fromInteger i) -convertInt _ = pfail - -readBinary :: (Num a) => ReadPrec a -readBinary = parens $ do - r0 <- look - case r0 of - ('-' : _) -> do - _ <- get - negate <$> parens parse0b - _ -> parse0b - where - isDigit c = isJust (valDig c) - valDigit c = fromMaybe 0 (valDig c) - valDig '0' = Just 0 - valDig '1' = Just 1 - valDig _ = Nothing - parse0b = do - _ <- Text.Read.lift $ string "0b" - fromInteger <$> Text.Read.lift (L.readIntP 2 isDigit valDigit) - -instance (KnownNat n, 1 <= n) => Read (WordN n) where - readPrec = readNumber convertInt <|> readBinary - readListPrec = readListPrecDefault - readList = readListDefault - -instance Show SomeWordN where - show (SomeWordN w) = show w - --- | --- Symbolic signed bit vectors. -newtype IntN (n :: Nat) = IntN {unIntN :: Integer} - deriving (Eq, Generic, Lift, Hashable, NFData) - --- | --- A non-indexed version of 'IntN'. -data SomeIntN where - SomeIntN :: (KnownNat n, 1 <= n) => IntN n -> SomeIntN - -unarySomeIntN :: (forall n. (KnownNat n, 1 <= n) => IntN n -> r) -> SomeIntN -> r -unarySomeIntN op (SomeIntN (w :: IntN w)) = op w -{-# INLINE unarySomeIntN #-} - -unarySomeIntNR1 :: (forall n. (KnownNat n, 1 <= n) => IntN n -> IntN n) -> SomeIntN -> SomeIntN -unarySomeIntNR1 op (SomeIntN (w :: IntN w)) = SomeIntN $ op w -{-# INLINE unarySomeIntNR1 #-} - -binSomeIntN :: (forall n. (KnownNat n, 1 <= n) => IntN n -> IntN n -> r) -> SomeIntN -> SomeIntN -> r -binSomeIntN op (SomeIntN (l :: IntN l)) (SomeIntN (r :: IntN r)) = - case sameNat (Proxy @l) (Proxy @r) of - Just Refl -> op l r - Nothing -> throw BitwidthMismatch -{-# INLINE binSomeIntN #-} - -binSomeIntNR1 :: (forall n. (KnownNat n, 1 <= n) => IntN n -> IntN n -> IntN n) -> SomeIntN -> SomeIntN -> SomeIntN -binSomeIntNR1 op (SomeIntN (l :: IntN l)) (SomeIntN (r :: IntN r)) = - case sameNat (Proxy @l) (Proxy @r) of - Just Refl -> SomeIntN $ op l r - Nothing -> throw BitwidthMismatch -{-# INLINE binSomeIntNR1 #-} - -binSomeIntNR2 :: (forall n. (KnownNat n, 1 <= n) => IntN n -> IntN n -> (IntN n, IntN n)) -> SomeIntN -> SomeIntN -> (SomeIntN, SomeIntN) -binSomeIntNR2 op (SomeIntN (l :: IntN l)) (SomeIntN (r :: IntN r)) = - case sameNat (Proxy @l) (Proxy @r) of - Just Refl -> - case op l r of - (a, b) -> (SomeIntN a, SomeIntN b) - Nothing -> throw BitwidthMismatch -{-# INLINE binSomeIntNR2 #-} - -instance Eq SomeIntN where - SomeIntN (l :: IntN l) == SomeIntN (r :: IntN r) = - case sameNat (Proxy @l) (Proxy @r) of - Just Refl -> l == r - Nothing -> False - {-# INLINE (==) #-} - SomeIntN (l :: IntN l) /= SomeIntN (r :: IntN r) = - case sameNat (Proxy @l) (Proxy @r) of - Just Refl -> l /= r - Nothing -> True - {-# INLINE (/=) #-} - -instance Ord SomeIntN where - (<=) = binSomeIntN (<=) - {-# INLINE (<=) #-} - (<) = binSomeIntN (<) - {-# INLINE (<) #-} - (>=) = binSomeIntN (>=) - {-# INLINE (>=) #-} - (>) = binSomeIntN (>) - {-# INLINE (>) #-} - max = binSomeIntNR1 max - {-# INLINE max #-} - min = binSomeIntNR1 min - {-# INLINE min #-} - compare = binSomeIntN compare - {-# INLINE compare #-} - -instance Lift SomeIntN where - liftTyped (SomeIntN w) = [||SomeIntN w||] - -instance Hashable SomeIntN where - s `hashWithSalt` (SomeIntN (w :: IntN n)) = s `hashWithSalt` natVal (Proxy @n) `hashWithSalt` w - -instance NFData SomeIntN where - rnf (SomeIntN w) = rnf w - -instance (KnownNat n, 1 <= n) => Show (IntN n) where - show (IntN w) = if (bitwidth `mod` 4) == 0 then hexRepPre ++ hexRep else binRepPre ++ binRep - where - bitwidth = natVal (Proxy :: Proxy n) - hexRepPre = "0x" ++ replicate (fromIntegral (bitwidth `div` 4) - length hexRep) '0' - hexRep = showHex w "" - binRepPre = "0b" ++ replicate (fromIntegral bitwidth - length binRep) '0' - binRep = showIntAtBase 2 (\x -> if x == 0 then '0' else '1') w "" - -instance (KnownNat n, 1 <= n) => Read (IntN n) where - readPrec = readNumber convertInt <|> readBinary - readListPrec = readListPrecDefault - readList = readListDefault - -instance Show SomeIntN where - show (SomeIntN w) = show w - -instance (KnownNat n, 1 <= n) => Bits (WordN n) where - WordN a .&. WordN b = WordN (a .&. b) - WordN a .|. WordN b = WordN (a .|. b) - WordN a `xor` WordN b = WordN (a `xor` b) - complement a = maxBound `xor` a - - -- shift use default implementation - -- rotate use default implementation - zeroBits = WordN 0 - bit i - | i < 0 || i >= fromIntegral (natVal (Proxy :: Proxy n)) = zeroBits - | otherwise = WordN (bit i) - - -- setBit use default implementation - clearBit (WordN a) i = WordN (clearBit a i) - - -- complementBit use default implementation - testBit (WordN a) = testBit a - bitSizeMaybe = Just . finiteBitSize - bitSize = finiteBitSize - isSigned _ = False - shiftL w i | i >= finiteBitSize w = 0 - shiftL (WordN a) i = WordN (a `shiftL` i) .&. maxBound - - -- unsafeShiftL use default implementation - shiftR w i | i >= finiteBitSize w = 0 - shiftR (WordN a) i = WordN (a `shiftR` i) - - -- unsafeShiftR use default implementation - rotateL a 0 = a - rotateL (WordN a) k - | k >= n = rotateL (WordN a) (k `mod` n) - | otherwise = WordN $ l + h - where - n = fromIntegral $ natVal (Proxy :: Proxy n) - s = n - k - l = a `shiftR` s - h = (a - (l `shiftL` s)) `shiftL` k - rotateR a 0 = a - rotateR (WordN a) k - | k >= n = rotateR (WordN a) (k `mod` n) - | otherwise = WordN $ l + h - where - n = fromIntegral $ natVal (Proxy :: Proxy n) - s = n - k - l = a `shiftR` k - h = (a - (l `shiftL` k)) `shiftL` s - popCount (WordN n) = popCount n - -instance Bits SomeWordN where - (.&.) = binSomeWordNR1 (.&.) - (.|.) = binSomeWordNR1 (.|.) - xor = binSomeWordNR1 xor - complement = unarySomeWordNR1 complement - shift s i = unarySomeWordNR1 (`shift` i) s - rotate s i = unarySomeWordNR1 (`rotate` i) s - zeroBits = error "zeroBits is not defined for SomeWordN as no bitwidth is known" - bit = error "bit is not defined for SomeWordN as no bitwidth is known" - setBit s i = unarySomeWordNR1 (`setBit` i) s - clearBit s i = unarySomeWordNR1 (`clearBit` i) s - complementBit s i = unarySomeWordNR1 (`complementBit` i) s - testBit s i = unarySomeWordN (`testBit` i) s - bitSizeMaybe = Just . finiteBitSize - bitSize = finiteBitSize - isSigned _ = False - shiftL s i = unarySomeWordNR1 (`shiftL` i) s - unsafeShiftL s i = unarySomeWordNR1 (`unsafeShiftL` i) s - shiftR s i = unarySomeWordNR1 (`shiftR` i) s - unsafeShiftR s i = unarySomeWordNR1 (`unsafeShiftR` i) s - rotateL s i = unarySomeWordNR1 (`rotateL` i) s - rotateR s i = unarySomeWordNR1 (`rotateR` i) s - popCount = unarySomeWordN popCount - -instance (KnownNat n, 1 <= n) => FiniteBits (WordN n) where - finiteBitSize _ = fromIntegral (natVal (Proxy :: Proxy n)) - -instance FiniteBits SomeWordN where - finiteBitSize (SomeWordN (n :: WordN n)) = fromIntegral $ natVal n - countLeadingZeros = unarySomeWordN countLeadingZeros - countTrailingZeros = unarySomeWordN countTrailingZeros - -instance (KnownNat n, 1 <= n) => Bounded (WordN n) where - maxBound = WordN ((1 `shiftL` fromIntegral (natVal (Proxy :: Proxy n))) - 1) - minBound = WordN 0 - -instance (KnownNat n, 1 <= n) => Enum (WordN n) where - succ x - | x /= maxBound = x + 1 - | otherwise = succError $ "WordN " ++ show (natVal (Proxy :: Proxy n)) - pred x - | x /= minBound = x - 1 - | otherwise = predError $ "WordN " ++ show (natVal (Proxy :: Proxy n)) - toEnum i - | i >= 0 && toInteger i <= toInteger (maxBound :: WordN n) = WordN (toInteger i) - | otherwise = toEnumError ("WordN " ++ show (natVal (Proxy :: Proxy n))) i (minBound :: WordN n, maxBound :: WordN n) - fromEnum (WordN n) = fromEnum n - enumFrom = boundedEnumFrom - {-# INLINE enumFrom #-} - enumFromThen = boundedEnumFromThen - {-# INLINE enumFromThen #-} - -instance Enum SomeWordN where - toEnum = error "SomeWordN is not really a Enum type as the bit width is unknown, please consider using WordN instead" - fromEnum = error "SomeWordN is not really a Enum type as the bit width is unknown, please consider using WordN instead" - -instance (KnownNat n, 1 <= n) => Real (WordN n) where - toRational (WordN n) = n % 1 - -instance Real SomeWordN where - toRational = unarySomeWordN toRational - -instance (KnownNat n, 1 <= n) => Integral (WordN n) where - quot (WordN x) (WordN y) = WordN (x `quot` y) - rem (WordN x) (WordN y) = WordN (x `rem` y) - quotRem (WordN x) (WordN y) = case quotRem x y of - (q, r) -> (WordN q, WordN r) - div = quot - mod = rem - divMod = quotRem - toInteger (WordN n) = n - -instance Integral SomeWordN where - quot = binSomeWordNR1 quot - rem = binSomeWordNR1 rem - quotRem = binSomeWordNR2 quotRem - div = binSomeWordNR1 div - mod = binSomeWordNR1 mod - divMod = binSomeWordNR2 divMod - toInteger = unarySomeWordN toInteger - -instance (KnownNat n, 1 <= n) => Num (WordN n) where - WordN x + WordN y = WordN (x + y) .&. maxBound - WordN x * WordN y = WordN (x * y) .&. maxBound - WordN x - WordN y - | x >= y = WordN (x - y) - | otherwise = WordN ((1 `shiftL` fromIntegral (natVal (Proxy :: Proxy n))) + x - y) - negate (WordN 0) = WordN 0 - negate a = complement a + WordN 1 - abs x = x - signum (WordN 0) = 0 - signum _ = 1 - fromInteger !x - | x == 0 = WordN 0 - | x > 0 = WordN (x .&. unWordN (maxBound :: WordN n)) - | otherwise = -fromInteger (-x) - -instance Num SomeWordN where - (+) = binSomeWordNR1 (+) - (-) = binSomeWordNR1 (-) - (*) = binSomeWordNR1 (*) - negate = unarySomeWordNR1 negate - abs = unarySomeWordNR1 abs - signum = unarySomeWordNR1 signum - fromInteger = error "fromInteger is not defined for SomeWordN as no bitwidth is known" - -instance (KnownNat n, 1 <= n) => QC.Arbitrary (WordN n) where - arbitrary = QC.arbitrarySizedBoundedIntegral - - -- QC.shrinkIntegral assumes that 2 is representable by the number, which is - -- not the case for 1-bit bit vector. - shrink i - | i == 0 = [] - | i == 1 = [0] - | otherwise = QC.shrinkIntegral i - -minusOneIntN :: forall proxy n. (KnownNat n) => proxy n -> IntN n -minusOneIntN _ = IntN (1 `shiftL` fromIntegral (natVal (Proxy :: Proxy n)) - 1) - -instance (KnownNat n, 1 <= n) => Bits (IntN n) where - IntN a .&. IntN b = IntN (a .&. b) - IntN a .|. IntN b = IntN (a .|. b) - IntN a `xor` IntN b = IntN (a `xor` b) - complement a = minusOneIntN (Proxy :: Proxy n) `xor` a - - -- shift use default implementation - -- rotate use default implementation - zeroBits = IntN 0 - bit i = IntN (unWordN (bit i :: WordN n)) - - -- setBit use default implementation - clearBit (IntN a) i = IntN (clearBit a i) - - -- complementBit use default implementation - testBit (IntN a) = testBit a - bitSizeMaybe = Just . finiteBitSize - bitSize = finiteBitSize - isSigned _ = True - - shiftL (IntN a) i = IntN (unWordN $ (WordN a :: WordN n) `shiftL` i) - - -- unsafeShiftL use default implementation - shiftR i 0 = i - shiftR (IntN i) k - | k >= n = if b then IntN (maxi - 1) else IntN 0 - | otherwise = if b then IntN (maxi - noi + (i `shiftR` k)) else IntN (i `shiftR` k) - where - b = testBit i (n - 1) - n = fromIntegral $ natVal (Proxy :: Proxy n) - maxi = (1 :: Integer) `shiftL` n - noi = (1 :: Integer) `shiftL` (n - k) - - -- unsafeShiftR use default implementation - rotateL (IntN i) k = IntN $ unWordN $ rotateL (WordN i :: WordN n) k - rotateR (IntN i) k = IntN $ unWordN $ rotateR (WordN i :: WordN n) k - popCount (IntN i) = popCount i - -instance Bits SomeIntN where - (.&.) = binSomeIntNR1 (.&.) - (.|.) = binSomeIntNR1 (.|.) - xor = binSomeIntNR1 xor - complement = unarySomeIntNR1 complement - shift s i = unarySomeIntNR1 (`shift` i) s - rotate s i = unarySomeIntNR1 (`rotate` i) s - zeroBits = error "zeroBits is not defined for SomeIntN as no bitwidth is known" - bit = error "bit is not defined for SomeIntN as no bitwidth is known" - setBit s i = unarySomeIntNR1 (`setBit` i) s - clearBit s i = unarySomeIntNR1 (`clearBit` i) s - complementBit s i = unarySomeIntNR1 (`complementBit` i) s - testBit s i = unarySomeIntN (`testBit` i) s - bitSizeMaybe = Just . finiteBitSize - bitSize = finiteBitSize - isSigned _ = False - shiftL s i = unarySomeIntNR1 (`shiftL` i) s - unsafeShiftL s i = unarySomeIntNR1 (`unsafeShiftL` i) s - shiftR s i = unarySomeIntNR1 (`shiftR` i) s - unsafeShiftR s i = unarySomeIntNR1 (`unsafeShiftR` i) s - rotateL s i = unarySomeIntNR1 (`rotateL` i) s - rotateR s i = unarySomeIntNR1 (`rotateR` i) s - popCount = unarySomeIntN popCount - -instance (KnownNat n, 1 <= n) => FiniteBits (IntN n) where - finiteBitSize _ = fromIntegral (natVal (Proxy :: Proxy n)) - -instance FiniteBits SomeIntN where - finiteBitSize (SomeIntN (n :: IntN n)) = fromIntegral $ natVal n - countLeadingZeros = unarySomeIntN countLeadingZeros - countTrailingZeros = unarySomeIntN countTrailingZeros - -instance (KnownNat n, 1 <= n) => Bounded (IntN n) where - maxBound = IntN (1 `shiftL` (fromIntegral (natVal (Proxy :: Proxy n)) - 1) - 1) - minBound = maxBound + 1 - -instance (KnownNat n, 1 <= n) => Enum (IntN n) where - succ x - | x /= maxBound = x + 1 - | otherwise = succError $ "IntN " ++ show (natVal (Proxy :: Proxy n)) - pred x - | x /= minBound = x - 1 - | otherwise = predError $ "IntN " ++ show (natVal (Proxy :: Proxy n)) - toEnum i - | i >= fromIntegral (minBound :: IntN n) && i <= fromIntegral (maxBound :: IntN n) = fromIntegral i - | otherwise = toEnumError ("IntN " ++ show (natVal (Proxy :: Proxy n))) i (minBound :: WordN n, maxBound :: WordN n) - fromEnum = fromEnum . toInteger - enumFrom = boundedEnumFrom - {-# INLINE enumFrom #-} - enumFromThen = boundedEnumFromThen - {-# INLINE enumFromThen #-} - -instance Enum SomeIntN where - toEnum = error "SomeIntN is not really a Enum type as the bit width is unknown, please consider using IntN instead" - fromEnum = error "SomeIntN is not really a Enum type as the bit width is unknown, please consider using IntN instead" - -instance (KnownNat n, 1 <= n) => Real (IntN n) where - toRational i = toInteger i % 1 - -instance Real SomeIntN where - toRational = unarySomeIntN toRational - -instance (KnownNat n, 1 <= n) => Integral (IntN n) where - quot x y = - if x == minBound && y == -1 - then throw Overflow - else fromInteger (toInteger x `quot` toInteger y) - rem x y = fromInteger (toInteger x `rem` toInteger y) - quotRem x y = - if x == minBound && y == -1 - then throw Overflow - else case quotRem (toInteger x) (toInteger y) of - (q, r) -> (fromInteger q, fromInteger r) - div x y = - if x == minBound && y == -1 - then throw Overflow - else fromInteger (toInteger x `div` toInteger y) - mod x y = fromInteger (toInteger x `mod` toInteger y) - divMod x y = - if x == minBound && y == -1 - then throw Overflow - else case divMod (toInteger x) (toInteger y) of - (q, r) -> (fromInteger q, fromInteger r) - toInteger i@(IntN n) = case signum i of - 0 -> 0 - -1 -> - let x = negate i - in if signum x == -1 then -n else negate (toInteger x) - 1 -> n - _ -> undefined - -instance Integral SomeIntN where - quot = binSomeIntNR1 quot - rem = binSomeIntNR1 rem - quotRem = binSomeIntNR2 quotRem - div = binSomeIntNR1 div - mod = binSomeIntNR1 mod - divMod = binSomeIntNR2 divMod - toInteger = unarySomeIntN toInteger - -instance (KnownNat n, 1 <= n) => Num (IntN n) where - IntN x + IntN y = IntN (x + y) .&. minusOneIntN (Proxy :: Proxy n) - IntN x * IntN y = IntN (x * y) .&. minusOneIntN (Proxy :: Proxy n) - IntN x - IntN y - | x >= y = IntN (x - y) - | otherwise = IntN ((1 `shiftL` fromIntegral (natVal (Proxy :: Proxy n))) + x - y) - negate (IntN 0) = IntN 0 - negate a = complement a + IntN 1 - abs x = if testBit x (fromIntegral $ natVal (Proxy :: Proxy n) - 1) then negate x else x - signum (IntN 0) = IntN 0 - signum i = if testBit i (fromIntegral $ natVal (Proxy :: Proxy n) - 1) then -1 else 1 - fromInteger !x = IntN $ if v >= 0 then v else (1 `shiftL` n) + v - where - v = unWordN (fromInteger (x + maxn) :: WordN n) - maxn - n = fromIntegral (natVal (Proxy :: Proxy n)) - maxn = 1 `shiftL` (n - 1) - 1 - -instance Num SomeIntN where - (+) = binSomeIntNR1 (+) - (-) = binSomeIntNR1 (-) - (*) = binSomeIntNR1 (*) - negate = unarySomeIntNR1 negate - abs = unarySomeIntNR1 abs - signum = unarySomeIntNR1 signum - fromInteger = error "fromInteger is not defined for SomeIntN as no bitwidth is known" - -instance (KnownNat n, 1 <= n) => Ord (IntN n) where - IntN a <= IntN b - | as && not bs = True - | not as && bs = False - | otherwise = a <= b - where - n = fromIntegral (natVal (Proxy :: Proxy n)) - as = testBit a (n - 1) - bs = testBit b (n - 1) - -instance (KnownNat n, 1 <= n) => QC.Arbitrary (IntN n) where - arbitrary = QC.arbitrarySizedBoundedIntegral - - -- QC.shrinkIntegral assumes that 2 is representable by the number, which is - -- not the case for 1-bit bit vector. - shrink i - | i == 0 = [] - | i == 1 = [0] - | otherwise = QC.shrinkIntegral i - -instance SizedBV WordN where - sizedBVConcat :: forall l r. (KnownNat l, KnownNat r, 1 <= l, 1 <= r) => WordN l -> WordN r -> WordN (l + r) - sizedBVConcat (WordN a) (WordN b) = WordN ((a `shiftL` fromIntegral (natVal (Proxy :: Proxy r))) .|. b) - sizedBVZext _ (WordN v) = WordN v - sizedBVSext :: forall l r proxy. (KnownNat l, KnownNat r, 1 <= l, KnownNat r, l <= r) => proxy r -> WordN l -> WordN r - sizedBVSext pr (WordN v) = if s then WordN (maxi - noi + v) else WordN v - where - r = fromIntegral $ natVal pr - l = fromIntegral $ natVal (Proxy :: Proxy l) - s = testBit v (l - 1) - maxi = (1 :: Integer) `shiftL` r - noi = (1 :: Integer) `shiftL` l - sizedBVExt = sizedBVZext - sizedBVSelect :: - forall n ix w p q. - (KnownNat n, KnownNat ix, KnownNat w, 1 <= n, 1 <= w, ix + w <= n) => - p ix -> - q w -> - WordN n -> - WordN w - sizedBVSelect pix pw (WordN v) = WordN ((v `shiftR` ix) .&. mask) - where - ix = fromIntegral $ natVal pix - w = fromIntegral $ natVal pw - mask = (1 `shiftL` w) - 1 - -instance SizedBV IntN where - sizedBVConcat :: forall l r. (KnownNat l, KnownNat r, 1 <= l, 1 <= r) => IntN l -> IntN r -> IntN (l + r) - sizedBVConcat (IntN a) (IntN b) = IntN $ unWordN $ sizedBVConcat (WordN a :: WordN l) (WordN b :: WordN r) - sizedBVZext _ (IntN v) = IntN v - sizedBVSext :: forall l r proxy. (KnownNat l, KnownNat r, 1 <= l, KnownNat r, l <= r) => proxy r -> IntN l -> IntN r - sizedBVSext pr (IntN v) = IntN $ unWordN $ sizedBVSext pr (WordN v :: WordN l) - sizedBVExt = sizedBVSext - sizedBVSelect :: - forall n ix w p q. - (KnownNat n, KnownNat ix, KnownNat w, 1 <= n, 1 <= w, ix + w <= n) => - p ix -> - q w -> - IntN n -> - IntN w - sizedBVSelect pix pw (IntN v) = IntN $ unWordN $ sizedBVSelect pix pw (WordN v :: WordN n) - -instance BV SomeWordN where - bvConcat (SomeWordN (a :: WordN l)) (SomeWordN (b :: WordN r)) = - case (leqAddPos (Proxy @l) (Proxy @r), knownAdd @l @r KnownProof KnownProof) of - (LeqProof, KnownProof) -> - SomeWordN $ sizedBVConcat a b - {-# INLINE bvConcat #-} - bvZext l (SomeWordN (a :: WordN n)) - | l < n = error "bvZext: trying to zero extend a value to a smaller size" - | otherwise = res (Proxy @n) - where - n = fromIntegral $ natVal (Proxy @n) - res :: forall (l :: Nat). Proxy l -> SomeWordN - res p = - case (unsafeKnownProof @l (fromIntegral l), unsafeLeqProof @1 @l, unsafeLeqProof @n @l) of - (KnownProof, LeqProof, LeqProof) -> SomeWordN $ sizedBVZext p a - bvSext l (SomeWordN (a :: WordN n)) - | l < n = error "bvSext: trying to zero extend a value to a smaller size" - | otherwise = res (Proxy @n) - where - n = fromIntegral $ natVal (Proxy @n) - res :: forall (l :: Nat). Proxy l -> SomeWordN - res p = - case (unsafeKnownProof @l (fromIntegral l), unsafeLeqProof @1 @l, unsafeLeqProof @n @l) of - (KnownProof, LeqProof, LeqProof) -> SomeWordN $ sizedBVSext p a - bvExt = bvZext - bvSelect ix w (SomeWordN (a :: WordN n)) - | ix + w > n = error "bvSelect: trying to select a bitvector outside the bounds of the input" - | w == 0 = error "bvSelect: trying to select a bitvector of size 0" - | otherwise = res (Proxy @n) (Proxy @n) - where - n = fromIntegral $ natVal (Proxy @n) - res :: forall (w :: Nat) (ix :: Nat). Proxy w -> Proxy ix -> SomeWordN - res _ _ = - case ( unsafeKnownProof @ix (fromIntegral ix), - unsafeKnownProof @w (fromIntegral w), - unsafeLeqProof @1 @w, - unsafeLeqProof @(ix + w) @n - ) of - (KnownProof, KnownProof, LeqProof, LeqProof) -> - SomeWordN $ sizedBVSelect (Proxy @ix) (Proxy @w) a - -instance BV SomeIntN where - bvConcat l r = toSigned $ bvConcat (toUnsigned l) (toUnsigned r) - {-# INLINE bvConcat #-} - bvZext l = toSigned . bvZext l . toUnsigned - {-# INLINE bvZext #-} - bvSext l = toSigned . bvSext l . toUnsigned - {-# INLINE bvSext #-} - bvExt l = toSigned . bvExt l . toUnsigned - {-# INLINE bvExt #-} - bvSelect ix w = toSigned . bvSelect ix w . toUnsigned - {-# INLINE bvSelect #-} - -instance (KnownNat n, 1 <= n) => SignConversion (WordN n) (IntN n) where - toSigned (WordN i) = IntN i - toUnsigned (IntN i) = WordN i - -instance SignConversion SomeWordN SomeIntN where - toSigned (SomeWordN i) = SomeIntN $ toSigned i - toUnsigned (SomeIntN i) = SomeWordN $ toUnsigned i - -deriving via - (DefaultFiniteBitsSymShift (IntN n)) - instance - (KnownNat n, 1 <= n) => SymShift (IntN n) - -deriving via - (DefaultFiniteBitsSymShift (WordN n)) - instance - (KnownNat n, 1 <= n) => SymShift (WordN n) - -deriving via - (DefaultFiniteBitsSymRotate (IntN n)) - instance - (KnownNat n, 1 <= n) => SymRotate (IntN n) - -deriving via - (DefaultFiniteBitsSymRotate (WordN n)) - instance - (KnownNat n, 1 <= n) => SymRotate (WordN n) diff --git a/src/Grisette/Core/Data/Class/BitVector.hs b/src/Grisette/Core/Data/Class/BitVector.hs deleted file mode 100644 --- a/src/Grisette/Core/Data/Class/BitVector.hs +++ /dev/null @@ -1,234 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} - --- | --- Module : Grisette.Core.Data.Class.BitVector --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Core.Data.Class.BitVector - ( -- * Bit vector operations - BV (..), - bvExtract, - SizedBV (..), - sizedBVExtract, - ) -where - -import Data.Proxy (Proxy (Proxy)) -import GHC.TypeNats (KnownNat, type (+), type (-), type (<=)) -import Grisette.Utils.Parameterized - ( KnownProof (KnownProof), - LeqProof (LeqProof), - addNat, - hasRepr, - natRepr, - subNat, - unsafeLeqProof, - ) - --- $setup --- >>> import Grisette.Core --- >>> import Grisette.IR.SymPrim --- >>> import Grisette.Utils.Parameterized --- >>> :set -XDataKinds --- >>> :set -XBinaryLiterals --- >>> :set -XFlexibleContexts --- >>> :set -XFlexibleInstances --- >>> :set -XFunctionalDependencies - --- | Bit vector operations. Including concatenation ('bvConcat'), --- extension ('bvZext', 'bvSext', 'bvExt'), and selection --- ('bvSelect'). -class BV bv where - -- | Concatenation of two bit vectors. - -- - -- >>> bvConcat (SomeSymWordN (0b101 :: SymWordN 3)) (SomeSymWordN (0b010 :: SymWordN 3)) - -- 0b101010 - bvConcat :: bv -> bv -> bv - - -- | Zero extension of a bit vector. - -- - -- >>> bvZext 6 (SomeSymWordN (0b101 :: SymWordN 3)) - -- 0b000101 - bvZext :: - -- | Desired output length - Int -> - -- | Bit vector to extend - bv -> - bv - - -- | Sign extension of a bit vector. - -- - -- >>> bvSext 6 (SomeSymWordN (0b101 :: SymWordN 3)) - -- 0b111101 - bvSext :: - -- | Desired output length - Int -> - -- | Bit vector to extend - bv -> - bv - - -- | Extension of a bit vector. - -- Signedness is determined by the input bit vector type. - -- - -- >>> bvExt 6 (SomeSymIntN (0b101 :: SymIntN 3)) - -- 0b111101 - -- >>> bvExt 6 (SomeSymIntN (0b001 :: SymIntN 3)) - -- 0b000001 - -- >>> bvExt 6 (SomeSymWordN (0b101 :: SymWordN 3)) - -- 0b000101 - -- >>> bvExt 6 (SomeSymWordN (0b001 :: SymWordN 3)) - -- 0b000001 - bvExt :: - -- | Desired output length - Int -> - -- | Bit vector to extend - bv -> - bv - - -- | Slicing out a smaller bit vector from a larger one, - -- selecting a slice with width @w@ starting from index @ix@. - -- - -- The least significant bit is indexed as 0. - -- - -- >>> bvSelect 1 3 (SomeSymIntN (0b001010 :: SymIntN 6)) - -- 0b101 - bvSelect :: - -- | Index of the least significant bit of the slice - Int -> - -- | Desired output width, @ix + w <= n@ must hold where @n@ is - -- the size of the input bit vector - Int -> - -- | Bit vector to select from - bv -> - bv - --- | Slicing out a smaller bit vector from a larger one, extract a slice from --- bit @i@ down to @j@. --- --- The least significant bit is indexed as 0. --- --- >>> bvExtract 4 2 (SomeSymIntN (0b010100 :: SymIntN 6)) --- 0b101 -bvExtract :: - (BV bv) => - -- | The start position to extract from, @i < n@ must hold where @n@ is - -- the size of the output bit vector - Int -> - -- | The end position to extract from, @j <= i@ must hold - Int -> - -- | Bit vector to extract from - bv -> - bv -bvExtract i j = bvSelect j (i - j + 1) -{-# INLINE bvExtract #-} - --- | Sized bit vector operations. Including concatenation ('sizedBVConcat'), --- extension ('sizedBVZext', 'sizedBVSext', 'sizedBVExt'), and selection --- ('sizedBVSelect'). -class SizedBV bv where - -- | Concatenation of two bit vectors. - -- - -- >>> sizedBVConcat (0b101 :: SymIntN 3) (0b010 :: SymIntN 3) - -- 0b101010 - sizedBVConcat :: (KnownNat l, KnownNat r, 1 <= l, 1 <= r) => bv l -> bv r -> bv (l + r) - - -- | Zero extension of a bit vector. - -- - -- >>> sizedBVZext (Proxy @6) (0b101 :: SymIntN 3) - -- 0b000101 - sizedBVZext :: - (KnownNat l, KnownNat r, 1 <= l, KnownNat r, l <= r) => - -- | Desired output width - proxy r -> - -- | Bit vector to extend - bv l -> - bv r - - -- | Signed extension of a bit vector. - -- - -- >>> sizedBVSext (Proxy @6) (0b101 :: SymIntN 3) - -- 0b111101 - sizedBVSext :: - (KnownNat l, KnownNat r, 1 <= l, KnownNat r, l <= r) => - -- | Desired output width - proxy r -> - -- | Bit vector to extend - bv l -> - bv r - - -- | Extension of a bit vector. - -- Signedness is determined by the input bit vector type. - -- - -- >>> sizedBVExt (Proxy @6) (0b101 :: SymIntN 3) - -- 0b111101 - -- >>> sizedBVExt (Proxy @6) (0b001 :: SymIntN 3) - -- 0b000001 - -- >>> sizedBVExt (Proxy @6) (0b101 :: SymWordN 3) - -- 0b000101 - -- >>> sizedBVExt (Proxy @6) (0b001 :: SymWordN 3) - -- 0b000001 - sizedBVExt :: - (KnownNat l, KnownNat r, 1 <= l, KnownNat r, l <= r) => - -- | Desired output width - proxy r -> - -- | Bit vector to extend - bv l -> - bv r - - -- | Slicing out a smaller bit vector from a larger one, selecting a slice with - -- width @w@ starting from index @ix@. - -- - -- The least significant bit is indexed as 0. - -- - -- >>> sizedBVSelect (Proxy @2) (Proxy @3) (con 0b010100 :: SymIntN 6) - -- 0b101 - sizedBVSelect :: - (KnownNat n, KnownNat ix, KnownNat w, 1 <= n, 1 <= w, ix + w <= n) => - -- | Index of the least significant bit of the slice - p ix -> - -- | Desired output width, @ix + w <= n@ must hold where @n@ is - -- the size of the input bit vector - q w -> - -- | Bit vector to select from - bv n -> - bv w - --- | Slicing out a smaller bit vector from a larger one, extract a slice from --- bit @i@ down to @j@. --- --- The least significant bit is indexed as 0. --- --- >>> sizedBVExtract (Proxy @4) (Proxy @2) (con 0b010100 :: SymIntN 6) --- 0b101 -sizedBVExtract :: - forall p i q j n bv. - (SizedBV bv, KnownNat n, KnownNat i, KnownNat j, 1 <= n, i + 1 <= n, j <= i) => - -- | The start position to extract from, @i < n@ must hold where @n@ is - -- the size of the output bit vector - p i -> - -- | The end position to extract from, @j <= i@ must hold - q j -> - -- | Bit vector to extract from - bv n -> - bv (i - j + 1) -sizedBVExtract _ _ = - case ( hasRepr (addNat (subNat (natRepr @i) (natRepr @j)) (natRepr @1)), - unsafeLeqProof @(j + (i - j + 1)) @n, - unsafeLeqProof @1 @(i - j + 1) - ) of - (KnownProof, LeqProof, LeqProof) -> - sizedBVSelect (Proxy @j) (Proxy @(i - j + 1)) -{-# INLINE sizedBVExtract #-} diff --git a/src/Grisette/Core/Data/Class/CEGISSolver.hs b/src/Grisette/Core/Data/Class/CEGISSolver.hs deleted file mode 100644 --- a/src/Grisette/Core/Data/Class/CEGISSolver.hs +++ /dev/null @@ -1,614 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE Trustworthy #-} - --- | --- Module : Grisette.Core.Data.Class.CEGISSolver --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Core.Data.Class.CEGISSolver - ( -- * Note for the examples - - -- - - -- | The examples assumes that the [z3](https://github.com/Z3Prover/z3) - -- solver is available in @PATH@. - - -- * Generic CEGIS interface - SynthesisConstraintFun, - VerifierResult (..), - StatefulVerifierFun, - CEGISResult (..), - genericCEGIS, - - -- * CEGIS interfaces with pre/post conditions - CEGISCondition (..), - cegisPostCond, - cegisPrePost, - cegisMultiInputs, - cegis, - cegisExcept, - cegisExceptStdVC, - cegisExceptVC, - cegisExceptMultiInputs, - cegisExceptStdVCMultiInputs, - cegisExceptVCMultiInputs, - cegisForAll, - cegisForAllExcept, - cegisForAllExceptStdVC, - cegisForAllExceptVC, - ) -where - -import Control.Monad (foldM, unless) -import Data.List (partition) -import GHC.Generics (Generic) -import Generics.Deriving (Default (Default)) -import Grisette.Core.Control.Exception - ( VerificationConditions (AssertionViolation, AssumptionViolation), - ) -import Grisette.Core.Data.Class.EvaluateSym (EvaluateSym, evaluateSym) -import Grisette.Core.Data.Class.ExtractSymbolics - ( ExtractSymbolics, - extractSymbolics, - ) -import Grisette.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.&&))) -import Grisette.Core.Data.Class.Mergeable (Mergeable) -import Grisette.Core.Data.Class.ModelOps - ( ModelOps (exact, exceptFor), - SymbolSetOps (isEmptySet), - ) -import Grisette.Core.Data.Class.SEq (SEq) -import Grisette.Core.Data.Class.SimpleMergeable - ( SimpleMergeable, - UnionPrjOp, - simpleMerge, - ) -import Grisette.Core.Data.Class.Solvable (Solvable (con)) -import Grisette.Core.Data.Class.Solver - ( ConfigurableSolver, - Solver (solverSolve), - SolvingFailure (Unsat), - UnionWithExcept (extractUnionExcept), - solve, - withSolver, - ) -import Grisette.IR.SymPrim.Data.Prim.Model (Model) -import Grisette.IR.SymPrim.Data.SymPrim (SymBool) - --- $setup --- >>> import Grisette.Core --- >>> import Grisette.Lib.Base --- >>> import Grisette.IR.SymPrim --- >>> import Grisette.Backend.SBV - --- | Synthesis constraint function. --- --- The first argument is the iteration number, for angelic programs, you can use --- it to instantiate the angelic variables in the program. --- --- The second argument is the counter-example generated by the verifier. --- --- The synthesizer will try to find a program that is true for all the synthesis --- constraints. -type SynthesisConstraintFun input = Int -> input -> IO SymBool - --- | The result of the verifier. -data VerifierResult input exception - = CEGISVerifierFoundCex input - | CEGISVerifierNoCex - | CEGISVerifierException exception - --- | The verifier function. --- --- The first argument is the state of the verifier. --- --- The second argument is the candidate model proposed by the synthesizer. -type StatefulVerifierFun state input exception = - state -> Model -> IO (state, VerifierResult input exception) - --- | The result of the CEGIS procedure. -data CEGISResult exception - = CEGISSuccess Model - | CEGISVerifierFailure exception - | CEGISSolverFailure SolvingFailure - deriving (Show) - --- | Generic CEGIS procedure. --- --- The CEGIS procedure will try to find a model that satisfies the initial --- synthesis constraint, and satisfies all the inputs generated by the verifier. -genericCEGIS :: - (ConfigurableSolver config handle) => - -- | Configuration of the solver. - config -> - -- | The initial synthesis constraint. - SymBool -> - -- | The synthesis constraint function. - SynthesisConstraintFun input -> - -- | The initial state of the verifier. - verifierState -> - -- | The verifier function. - StatefulVerifierFun verifierState input exception -> - IO ([input], CEGISResult exception) -genericCEGIS config initConstr synthConstr initVerifierState verifier = - withSolver config $ \solver -> do - firstResult <- solverSolve solver initConstr - case firstResult of - Left err -> return ([], CEGISSolverFailure err) - Right model -> go solver model 0 initVerifierState - where - go solver prevModel iterNum verifierState = do - (newVerifierState, verifierResult) <- - verifier verifierState prevModel - case verifierResult of - CEGISVerifierFoundCex cex -> do - newResult <- solverSolve solver =<< synthConstr iterNum cex - case newResult of - Left err -> return ([], CEGISSolverFailure err) - Right model -> do - (cexes, result) <- go solver model (iterNum + 1) newVerifierState - return (cex : cexes, result) - CEGISVerifierNoCex -> return ([], CEGISSuccess prevModel) - CEGISVerifierException exception -> - return ([], CEGISVerifierFailure exception) - -data CEGISMultiInputsState input = CEGISMultiInputsState - { _cegisMultiInputsRemainingSymInputs :: [input], - _cegisMultiInputsPre :: SymBool, - _cegisMultiInputsPost :: SymBool - } - --- | The condition for CEGIS to solve. --- --- The first argument is the pre-condition, and the second argument is the --- post-condition. --- --- The CEGIS procedures would try to find a model for the formula --- --- \[ --- \forall P. (\exists I. \mathrm{pre}(P, I)) \wedge (\forall I. \mathrm{pre}(P, I)\implies \mathrm{post}(P, I)) --- \] --- --- In program synthesis tasks, \(P\) is the symbolic constants in the symbolic --- program, and \(I\) is the input. The pre-condition is used to restrict the --- search space of the program. The procedure would only return programs that --- meets the pre-conditions on every possible inputs, and there are at least --- one possible input. The post-condition is used to specify the desired program --- behaviors. -data CEGISCondition = CEGISCondition SymBool SymBool - deriving (Generic) - deriving (EvaluateSym) via (Default CEGISCondition) - --- | Construct a CEGIS condition with only a post-condition. The pre-condition --- would be set to true, meaning that all programs in the program space are --- allowed. -cegisPostCond :: SymBool -> CEGISCondition -cegisPostCond = CEGISCondition (con True) - --- | Construct a CEGIS condition with both pre- and post-conditions. -cegisPrePost :: SymBool -> SymBool -> CEGISCondition -cegisPrePost = CEGISCondition - -deriving via (Default CEGISCondition) instance Mergeable CEGISCondition - -deriving via (Default CEGISCondition) instance SimpleMergeable CEGISCondition - --- | --- CEGIS with multiple (possibly symbolic) inputs. Solves the following formula --- (see 'CEGISCondition' for details). --- --- \[ --- \forall P. (\exists I\in\mathrm{inputs}. \mathrm{pre}(P, I)) \wedge (\forall I\in\mathrm{inputs}. \mathrm{pre}(P, I)\implies \mathrm{post}(P, I)) --- \] --- --- For simpler queries, where the inputs are representable by a single --- symbolic value, you may want to use 'cegis' or 'cegisExcept' instead. --- We have an example for the 'cegis' call. -cegisMultiInputs :: - ( EvaluateSym input, - ExtractSymbolics input, - ConfigurableSolver config handle - ) => - config -> - [input] -> - (input -> CEGISCondition) -> - IO ([input], CEGISResult SolvingFailure) -cegisMultiInputs config inputs toCEGISCondition = do - initConstr <- cexesAssertFun conInputs - genericCEGIS - config - initConstr - synthConstr - (CEGISMultiInputsState symInputs (con True) (con True)) - verifier - where - (conInputs, symInputs) = partition (isEmptySet . extractSymbolics) inputs - forallSymbols = extractSymbolics symInputs - cexAssertFun input = do - unless (isEmptySet (extractSymbolics input)) $ error "BUG" - CEGISCondition pre post <- return $ toCEGISCondition input - return $ pre .&& post - cexesAssertFun = foldM (\acc x -> (acc .&&) <$> cexAssertFun x) (con True) - synthConstr _ = cexAssertFun - verifier state@(CEGISMultiInputsState [] _ _) _ = - return (state, CEGISVerifierNoCex) - verifier - (CEGISMultiInputsState (nextSymInput : symInputs) pre post) - candidate = do - CEGISCondition nextPre nextPost <- - return $ toCEGISCondition nextSymInput - let newPre = pre .&& nextPre - let newPost = post .&& nextPost - let evaluated = - evaluateSym False (exceptFor forallSymbols candidate) $ - newPre .&& symNot newPost - r <- solve config evaluated - case r of - Left Unsat -> - verifier (CEGISMultiInputsState symInputs newPre newPost) candidate - Left err -> - return - ( CEGISMultiInputsState [] newPre newPost, - CEGISVerifierException err - ) - Right model -> - return - ( CEGISMultiInputsState (nextSymInput : symInputs) newPre newPost, - CEGISVerifierFoundCex $ - evaluateSym False (exact forallSymbols model) nextSymInput - ) - --- | --- CEGIS with a single symbolic input to represent a set of inputs. --- --- The following example tries to find the value of @c@ such that for all --- positive @x@, @x * c < 0 && c > -2@. The @c .> -2@ clause is used to make --- the solution unique. --- --- >>> :set -XOverloadedStrings --- >>> let [x,c] = ["x","c"] :: [SymInteger] --- >>> cegis (precise z3) x (\x -> cegisPrePost (x .> 0) (x * c .< 0 .&& c .> -2)) --- (...,CEGISSuccess (Model {c -> -1 :: Integer})) -cegis :: - ( ConfigurableSolver config handle, - EvaluateSym inputs, - ExtractSymbolics inputs, - SEq inputs - ) => - -- | The configuration of the solver - config -> - -- | Initial symbolic inputs. The solver will try to find a - -- program that works on all the inputs representable by it (see - -- 'CEGISCondition'). - inputs -> - -- | The condition for the solver to solve. All the - -- symbolic constants that are not in the inputs will - -- be considered as part of the symbolic program. - (inputs -> CEGISCondition) -> - -- | The counter-examples generated - -- during the CEGIS loop, and the - -- model found by the solver. - IO ([inputs], CEGISResult SolvingFailure) -cegis config inputs = cegisMultiInputs config [inputs] - --- | --- CEGIS for symbolic programs with error handling, using multiple (possibly --- symbolic) inputs to represent a set of inputs. -cegisExceptMultiInputs :: - ( ConfigurableSolver config handle, - EvaluateSym inputs, - ExtractSymbolics inputs, - UnionWithExcept t u e v, - UnionPrjOp u, - Monad u - ) => - config -> - [inputs] -> - (Either e v -> CEGISCondition) -> - (inputs -> t) -> - IO ([inputs], CEGISResult SolvingFailure) -cegisExceptMultiInputs config cexes interpretFun f = - cegisMultiInputs - config - cexes - (simpleMerge . (interpretFun <$>) . extractUnionExcept . f) - --- | --- CEGIS for symbolic programs with error handling, using multiple (possibly --- symbolic) inputs to represent a set of inputs. --- --- The errors should be translated to assertion or assumption violations. -cegisExceptVCMultiInputs :: - ( ConfigurableSolver config handle, - EvaluateSym inputs, - ExtractSymbolics inputs, - UnionWithExcept t u e v, - UnionPrjOp u, - Monad u - ) => - config -> - [inputs] -> - (Either e v -> u (Either VerificationConditions ())) -> - (inputs -> t) -> - IO ([inputs], CEGISResult SolvingFailure) -cegisExceptVCMultiInputs config cexes interpretFun f = - cegisMultiInputs - config - cexes - ( \v -> - simpleMerge - ( ( \case - Left AssumptionViolation -> cegisPrePost (con False) (con True) - Left AssertionViolation -> cegisPostCond (con False) - _ -> cegisPostCond (con True) - ) - <$> (extractUnionExcept (f v) >>= interpretFun) - ) - ) - --- | --- CEGIS for symbolic programs with error handling, using multiple (possibly --- symbolic) inputs to represent a set of inputs. This function saves the --- efforts to implement the translation function for the standard error type --- 'VerificationConditions', and the standard result type '()'. --- --- This function translates assumption violations to failed pre-conditions, --- and translates assertion violations to failed post-conditions. --- The '()' result will not fail any conditions. -cegisExceptStdVCMultiInputs :: - ( ConfigurableSolver config handle, - EvaluateSym inputs, - ExtractSymbolics inputs, - UnionWithExcept t u VerificationConditions (), - UnionPrjOp u, - Monad u - ) => - config -> - [inputs] -> - (inputs -> t) -> - IO ([inputs], CEGISResult SolvingFailure) -cegisExceptStdVCMultiInputs config cexes = - cegisExceptVCMultiInputs config cexes return - --- | --- CEGIS for symbolic programs with error handling, using a single symbolic --- input to represent a set of inputs. --- --- 'cegisExcept' is particularly useful when custom error types are used. --- With 'cegisExcept', you define how the errors are interpreted to the --- CEGIS conditions after the symbolic evaluation. This could increase the --- readability and modularity of the code. --- --- The following example tries to find the value of @c@ such that for all --- positive @x@, @x * c < 0 && c > -2@. The @c .> -2@ assertion is used to make --- the solution unique. --- --- >>> :set -XOverloadedStrings --- >>> let [x,c] = ["x","c"] :: [SymInteger] --- >>> import Control.Monad.Except --- >>> :{ --- res :: SymInteger -> ExceptT VerificationConditions UnionM () --- res x = do --- symAssume $ x .> 0 --- symAssert $ x * c .< 0 --- symAssert $ c .> -2 --- :} --- --- >>> :{ --- translation (Left AssumptionViolation) = cegisPrePost (con False) (con True) --- translation (Left AssertionViolation) = cegisPostCond (con False) --- translation _ = cegisPostCond (con True) --- :} --- --- >>> cegisExcept (precise z3) x translation res --- ([...],CEGISSuccess (Model {c -> -1 :: Integer})) -cegisExcept :: - ( UnionWithExcept t u e v, - UnionPrjOp u, - Functor u, - EvaluateSym inputs, - ExtractSymbolics inputs, - ConfigurableSolver config handle, - SEq inputs - ) => - config -> - inputs -> - (Either e v -> CEGISCondition) -> - (inputs -> t) -> - IO ([inputs], CEGISResult SolvingFailure) -cegisExcept config inputs f v = - cegis config inputs $ \i -> simpleMerge $ f <$> extractUnionExcept (v i) - --- | --- CEGIS for symbolic programs with error handling, using a single symbolic --- input to represent a set of inputs. --- --- The errors should be translated to assertion or assumption violations. -cegisExceptVC :: - ( UnionWithExcept t u e v, - UnionPrjOp u, - Monad u, - EvaluateSym inputs, - ExtractSymbolics inputs, - ConfigurableSolver config handle, - SEq inputs - ) => - config -> - inputs -> - (Either e v -> u (Either VerificationConditions ())) -> - (inputs -> t) -> - IO ([inputs], CEGISResult SolvingFailure) -cegisExceptVC config inputs f v = do - cegis config inputs $ \i -> - simpleMerge $ - ( \case - Left AssumptionViolation -> cegisPrePost (con False) (con True) - Left AssertionViolation -> cegisPostCond (con False) - _ -> cegisPostCond (con True) - ) - <$> (extractUnionExcept (v i) >>= f) - --- | --- CEGIS for symbolic programs with error handling, using a single symbolic --- input to represent a set of inputs. This function saves the efforts to --- implement the translation function for the standard error type --- 'VerificationConditions', and the standard result type '()'. --- --- This function translates assumption violations to failed pre-conditions, --- and translates assertion violations to failed post-conditions. --- The '()' result will not fail any conditions. --- --- The following example tries to find the value of @c@ such that for all --- positive @x@, @x * c < 0 && c > -2@. The @c .> -2@ assertion is used to make --- the solution unique. --- --- >>> :set -XOverloadedStrings --- >>> let [x,c] = ["x","c"] :: [SymInteger] --- >>> import Control.Monad.Except --- >>> :{ --- res :: SymInteger -> ExceptT VerificationConditions UnionM () --- res x = do --- symAssume $ x .> 0 --- symAssert $ x * c .< 0 --- symAssert $ c .> -2 --- :} --- --- >>> cegisExceptStdVC (precise z3) x res --- ([...],CEGISSuccess (Model {c -> -1 :: Integer})) -cegisExceptStdVC :: - ( UnionWithExcept t u VerificationConditions (), - UnionPrjOp u, - Monad u, - EvaluateSym inputs, - ExtractSymbolics inputs, - ConfigurableSolver config handle, - SEq inputs - ) => - config -> - inputs -> - (inputs -> t) -> - IO ([inputs], CEGISResult SolvingFailure) -cegisExceptStdVC config inputs = cegisExceptVC config inputs return - --- | --- CEGIS with a single symbolic input to represent a set of inputs. --- --- The following example tries to find the value of @c@ such that for all --- positive @x@, @x * c < 0 && c > -2@. The @c .> -2@ clause is used to make --- the solution unique. --- --- >>> :set -XOverloadedStrings --- >>> let [x,c] = ["x","c"] :: [SymInteger] --- >>> cegisForAll (precise z3) x $ cegisPrePost (x .> 0) (x * c .< 0 .&& c .> -2) --- (...,CEGISSuccess (Model {c -> -1 :: Integer})) -cegisForAll :: - ( ExtractSymbolics forallInput, - ConfigurableSolver config handle - ) => - config -> - -- | A symbolic value. All the symbolic constants in the value are treated as - -- for-all variables. - forallInput -> - CEGISCondition -> - -- | First output are the counter-examples for all the for-all variables, and - -- the second output is the model for all other variables if CEGIS succeeds. - IO ([Model], CEGISResult SolvingFailure) -cegisForAll config input (CEGISCondition pre post) = do - (models, result) <- genericCEGIS config phi synthConstr () verifier - let exactResult = case result of - CEGISSuccess model -> CEGISSuccess $ exceptFor forallSymbols model - _ -> result - return (models, exactResult) - where - phi = pre .&& post - negphi = pre .&& symNot post - forallSymbols = extractSymbolics input - synthConstr _ model = return $ evaluateSym False model phi - verifier () candidate = do - let evaluated = - evaluateSym False (exceptFor forallSymbols candidate) negphi - r <- solve config evaluated - case r of - Left Unsat -> return ((), CEGISVerifierNoCex) - Left err -> return ((), CEGISVerifierException err) - Right model -> - return ((), CEGISVerifierFoundCex $ exact forallSymbols model) - --- | --- CEGIS for symbolic programs with error handling, with a forall variable. --- --- See 'cegisForAll' and 'cegisExcept'. -cegisForAllExcept :: - ( UnionWithExcept t u e v, - UnionPrjOp u, - Functor u, - EvaluateSym inputs, - ExtractSymbolics inputs, - ConfigurableSolver config handle, - SEq inputs - ) => - config -> - inputs -> - (Either e v -> CEGISCondition) -> - t -> - IO ([Model], CEGISResult SolvingFailure) -cegisForAllExcept config inputs f v = - cegisForAll config inputs $ simpleMerge $ f <$> extractUnionExcept v - --- | --- CEGIS for symbolic programs with error handling, with a forall variable. --- --- See 'cegisForAll' and 'cegisExceptVC'. -cegisForAllExceptVC :: - ( UnionWithExcept t u e v, - UnionPrjOp u, - Monad u, - EvaluateSym inputs, - ExtractSymbolics inputs, - ConfigurableSolver config handle, - SEq inputs - ) => - config -> - inputs -> - (Either e v -> u (Either VerificationConditions ())) -> - t -> - IO ([Model], CEGISResult SolvingFailure) -cegisForAllExceptVC config inputs f v = do - cegisForAll config inputs $ - simpleMerge $ - ( \case - Left AssumptionViolation -> cegisPrePost (con False) (con True) - Left AssertionViolation -> cegisPostCond (con False) - _ -> cegisPostCond (con True) - ) - <$> (extractUnionExcept v >>= f) - --- | --- CEGIS for symbolic programs with error handling, with a forall variable. --- --- See 'cegisForAll' and 'cegisExceptStdVC'. -cegisForAllExceptStdVC :: - ( UnionWithExcept t u VerificationConditions (), - UnionPrjOp u, - Monad u, - EvaluateSym inputs, - ExtractSymbolics inputs, - ConfigurableSolver config handle, - SEq inputs - ) => - config -> - inputs -> - t -> - IO ([Model], CEGISResult SolvingFailure) -cegisForAllExceptStdVC config inputs = cegisForAllExceptVC config inputs return diff --git a/src/Grisette/Core/Data/Class/Error.hs b/src/Grisette/Core/Data/Class/Error.hs deleted file mode 100644 --- a/src/Grisette/Core/Data/Class/Error.hs +++ /dev/null @@ -1,205 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE Trustworthy #-} - --- | --- Module : Grisette.Core.Data.Class.Error --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Core.Data.Class.Error - ( -- * Error transformation - TransformError (..), - - -- * Throwing error - symAssertWith, - symAssertTransformableError, - symThrowTransformableError, - symAssert, - symAssume, - ) -where - -import Control.Exception (ArithException, ArrayException) -import Control.Monad.Except (MonadError (throwError)) -import Grisette.Core.Control.Exception - ( AssertionError (AssertionError), - VerificationConditions (AssertionViolation, AssumptionViolation), - ) -import Grisette.Core.Control.Monad.Union (MonadUnion) -import Grisette.Core.Data.Class.Mergeable (Mergeable) -import Grisette.Core.Data.Class.SimpleMergeable (merge, mrgIf) -import Grisette.IR.SymPrim.Data.SymPrim (SymBool) - --- $setup --- >>> import Control.Exception --- >>> import Grisette.Core --- >>> import Grisette.IR.SymPrim --- >>> import Grisette.Lib.Control.Monad --- >>> import Control.Monad.Except --- >>> :set -XOverloadedStrings --- >>> :set -XFlexibleContexts - --- | This class indicates that the error type @to@ can always represent the --- error type @from@. --- --- This is useful in implementing generic procedures that may throw errors. --- For example, we support symbolic division and modulo operations. These --- operations should throw an error when the divisor is zero, and we use the --- standard error type 'Control.Exception.ArithException' for this purpose. --- However, the user may use other type to represent errors, so we need this --- type class to transform the 'Control.Exception.ArithException' to the --- user-defined types. --- --- Another example of these generic procedures is the --- 'Grisette.Core.symAssert' and 'Grisette.Core.symAssume' functions. --- They can be used with any error types that are --- compatible with the 'Grisette.Core.AssertionError' and --- 'Grisette.Core.VerificationConditions' types, respectively. -class TransformError from to where - -- | Transforms an error with type @from@ to an error with type @to@. - transformError :: from -> to - -instance {-# OVERLAPPABLE #-} TransformError a a where - transformError = id - {-# INLINE transformError #-} - -instance {-# OVERLAPS #-} TransformError a () where - transformError _ = () - {-# INLINE transformError #-} - -instance {-# OVERLAPPING #-} TransformError () () where - transformError _ = () - {-# INLINE transformError #-} - --- | Used within a monadic multi path computation to begin exception processing. --- --- Terminate the current execution path with the specified error. Compatible --- errors can be transformed. --- --- >>> symThrowTransformableError Overflow :: ExceptT AssertionError UnionM () --- ExceptT {Left AssertionError} -symThrowTransformableError :: - ( Mergeable to, - Mergeable a, - TransformError from to, - MonadError to erm, - MonadUnion erm - ) => - from -> - erm a -symThrowTransformableError = merge . throwError . transformError -{-# INLINE symThrowTransformableError #-} - --- | Used within a monadic multi path computation for exception processing. --- --- Terminate the current execution path with the specified error if the condition does not hold. --- Compatible error can be transformed. --- --- >>> let assert = symAssertTransformableError AssertionError --- >>> assert "a" :: ExceptT AssertionError UnionM () --- ExceptT {If (! a) (Left AssertionError) (Right ())} -symAssertTransformableError :: - ( Mergeable to, - TransformError from to, - MonadError to erm, - MonadUnion erm - ) => - from -> - SymBool -> - erm () -symAssertTransformableError err cond = mrgIf cond (return ()) (symThrowTransformableError err) -{-# INLINE symAssertTransformableError #-} - -symAssertWith :: - ( Mergeable e, - MonadError e erm, - MonadUnion erm - ) => - e -> - SymBool -> - erm () -symAssertWith err cond = mrgIf cond (return ()) (throwError err) -{-# INLINE symAssertWith #-} - -instance TransformError VerificationConditions VerificationConditions where - transformError = id - -instance TransformError AssertionError VerificationConditions where - transformError _ = AssertionViolation - -instance TransformError ArithException AssertionError where - transformError _ = AssertionError - -instance TransformError ArrayException AssertionError where - transformError _ = AssertionError - -instance TransformError AssertionError AssertionError where - transformError = id - --- | Used within a monadic multi path computation to begin exception processing. --- --- Checks the condition passed to the function. --- The current execution path will be terminated with assertion error if the condition is false. --- --- If the condition is symbolic, Grisette will split the execution into two paths based on the condition. --- The symbolic execution will continue on the then-branch, where the condition is true. --- For the else branch, where the condition is false, the execution will be terminated. --- --- The resulting monadic environment should be compatible with the 'AssertionError' --- error type. See 'TransformError' type class for details. --- --- __/Examples/__: --- --- Terminates the execution if the condition is false. --- Note that we may lose the 'Mergeable' knowledge here if no possible execution --- path is viable. This may affect the efficiency in theory, but in practice this --- should not be a problem as all paths are terminated and no further evaluation --- would be performed. --- --- >>> symAssert (con False) :: ExceptT AssertionError UnionM () --- ExceptT {Left AssertionError} --- >>> do; symAssert (con False); mrgReturn 1 :: ExceptT AssertionError UnionM Integer --- ExceptT --- --- No effect if the condition is true: --- --- >>> symAssert (con True) :: ExceptT AssertionError UnionM () --- ExceptT {Right ()} --- >>> do; symAssert (con True); mrgReturn 1 :: ExceptT AssertionError UnionM Integer --- ExceptT {Right 1} --- --- Splitting the path and terminate one of them when the condition is symbolic. --- --- >>> symAssert (ssym "a") :: ExceptT AssertionError UnionM () --- ExceptT {If (! a) (Left AssertionError) (Right ())} --- >>> do; symAssert (ssym "a"); mrgReturn 1 :: ExceptT AssertionError UnionM Integer --- ExceptT {If (! a) (Left AssertionError) (Right 1)} --- --- 'AssertionError' is compatible with 'VerificationConditions': --- --- >>> symAssert (ssym "a") :: ExceptT VerificationConditions UnionM () --- ExceptT {If (! a) (Left AssertionViolation) (Right ())} -symAssert :: - (TransformError AssertionError to, Mergeable to, MonadError to erm, MonadUnion erm) => - SymBool -> - erm () -symAssert = symAssertTransformableError AssertionError - --- | Used within a monadic multi path computation to begin exception processing. --- --- Similar to 'symAssert', but terminates the execution path with 'AssumptionViolation' error. --- --- /Examples/: --- --- >>> symAssume (ssym "a") :: ExceptT VerificationConditions UnionM () --- ExceptT {If (! a) (Left AssumptionViolation) (Right ())} -symAssume :: - (TransformError VerificationConditions to, Mergeable to, MonadError to erm, MonadUnion erm) => - SymBool -> - erm () -symAssume = symAssertTransformableError AssumptionViolation diff --git a/src/Grisette/Core/Data/Class/EvaluateSym.hs b/src/Grisette/Core/Data/Class/EvaluateSym.hs deleted file mode 100644 --- a/src/Grisette/Core/Data/Class/EvaluateSym.hs +++ /dev/null @@ -1,286 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- Module : Grisette.Core.Data.Class.EvaluateSym --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Core.Data.Class.EvaluateSym - ( -- * Evaluating symbolic values with model - EvaluateSym (..), - evaluateSymToCon, - ) -where - -import Control.Monad.Except (ExceptT (ExceptT)) -import Control.Monad.Identity - ( Identity (Identity), - IdentityT (IdentityT), - ) -import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) -import qualified Control.Monad.Writer.Lazy as WriterLazy -import qualified Control.Monad.Writer.Strict as WriterStrict -import qualified Data.ByteString as B -import Data.Functor.Sum (Sum) -import Data.Int (Int16, Int32, Int64, Int8) -import Data.Maybe (fromJust) -import qualified Data.Text as T -import Data.Word (Word16, Word32, Word64, Word8) -import GHC.TypeNats (KnownNat, type (<=)) -import Generics.Deriving - ( Default (Default, unDefault), - Generic (Rep, from, to), - K1 (K1), - M1 (M1), - U1, - type (:*:) ((:*:)), - type (:+:) (L1, R1), - ) -import Generics.Deriving.Instances () -import Grisette.Core.Control.Exception (AssertionError, VerificationConditions) -import Grisette.Core.Data.BV (IntN, SomeIntN, SomeWordN, WordN) -import Grisette.Core.Data.Class.ToCon (ToCon (toCon)) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term (LinkedRep, SupportedPrim) -import Grisette.IR.SymPrim.Data.Prim.Model (Model, evaluateTerm) -import Grisette.IR.SymPrim.Data.SymPrim - ( SomeSymIntN (SomeSymIntN), - SomeSymWordN (SomeSymWordN), - SymBool (SymBool), - SymIntN (SymIntN), - SymInteger (SymInteger), - SymWordN (SymWordN), - type (-~>) (SymGeneralFun), - type (=~>) (SymTabularFun), - ) - --- $setup --- >>> import Grisette.Core --- >>> import Grisette.IR.SymPrim --- >>> import Data.Proxy --- >>> :set -XTypeApplications - --- | Evaluating symbolic values with some model. --- --- >>> let model = insertValue (SimpleSymbol "a") (1 :: Integer) emptyModel :: Model --- >>> evaluateSym False model ([ssym "a", ssym "b"] :: [SymInteger]) --- [1,b] --- --- If we set the first argument true, the missing variables will be filled in with --- some default values: --- --- >>> evaluateSym True model ([ssym "a", ssym "b"] :: [SymInteger]) --- [1,0] --- --- __Note 1:__ This type class can be derived for algebraic data types. --- You may need the @DerivingVia@ and @DerivingStrategies@ extensions. --- --- > data X = ... deriving Generic deriving EvaluateSym via (Default X) -class EvaluateSym a where - -- | Evaluate a symbolic variable with some model, possibly fill in values for the missing variables. - evaluateSym :: Bool -> Model -> a -> a - --- | Evaluate a symbolic variable with some model, fill in values for the missing variables, --- and transform to concrete ones --- --- >>> let model = insertValue (SimpleSymbol "a") (1 :: Integer) emptyModel :: Model --- >>> evaluateSymToCon model ([ssym "a", ssym "b"] :: [SymInteger]) :: [Integer] --- [1,0] -evaluateSymToCon :: (ToCon a b, EvaluateSym a) => Model -> a -> b -evaluateSymToCon model a = fromJust $ toCon $ evaluateSym True model a - --- instances - -#define CONCRETE_EVALUATESYM(type) \ -instance EvaluateSym type where \ - evaluateSym _ _ = id - -#define CONCRETE_EVALUATESYM_BV(type) \ -instance (KnownNat n, 1 <= n) => EvaluateSym (type n) where \ - evaluateSym _ _ = id - -#if 1 -CONCRETE_EVALUATESYM(Bool) -CONCRETE_EVALUATESYM(Integer) -CONCRETE_EVALUATESYM(Char) -CONCRETE_EVALUATESYM(Int) -CONCRETE_EVALUATESYM(Int8) -CONCRETE_EVALUATESYM(Int16) -CONCRETE_EVALUATESYM(Int32) -CONCRETE_EVALUATESYM(Int64) -CONCRETE_EVALUATESYM(Word) -CONCRETE_EVALUATESYM(Word8) -CONCRETE_EVALUATESYM(Word16) -CONCRETE_EVALUATESYM(Word32) -CONCRETE_EVALUATESYM(Word64) -CONCRETE_EVALUATESYM(SomeIntN) -CONCRETE_EVALUATESYM(SomeWordN) -CONCRETE_EVALUATESYM(B.ByteString) -CONCRETE_EVALUATESYM(T.Text) -CONCRETE_EVALUATESYM_BV(IntN) -CONCRETE_EVALUATESYM_BV(WordN) -#endif - --- () -instance EvaluateSym () where - evaluateSym _ _ = id - --- Either -deriving via (Default (Either a b)) instance (EvaluateSym a, EvaluateSym b) => EvaluateSym (Either a b) - --- Maybe -deriving via (Default (Maybe a)) instance (EvaluateSym a) => EvaluateSym (Maybe a) - --- List -deriving via (Default [a]) instance (EvaluateSym a) => EvaluateSym [a] - --- (,) -deriving via (Default (a, b)) instance (EvaluateSym a, EvaluateSym b) => EvaluateSym (a, b) - --- (,,) -deriving via (Default (a, b, c)) instance (EvaluateSym a, EvaluateSym b, EvaluateSym c) => EvaluateSym (a, b, c) - --- (,,,) -deriving via - (Default (a, b, c, d)) - instance - (EvaluateSym a, EvaluateSym b, EvaluateSym c, EvaluateSym d) => EvaluateSym (a, b, c, d) - --- (,,,,) -deriving via - (Default (a, b, c, d, e)) - instance - (EvaluateSym a, EvaluateSym b, EvaluateSym c, EvaluateSym d, EvaluateSym e) => - EvaluateSym (a, b, c, d, e) - --- (,,,,,) -deriving via - (Default (a, b, c, d, e, f)) - instance - (EvaluateSym a, EvaluateSym b, EvaluateSym c, EvaluateSym d, EvaluateSym e, EvaluateSym f) => - EvaluateSym (a, b, c, d, e, f) - --- (,,,,,,) -deriving via - (Default (a, b, c, d, e, f, g)) - instance - ( EvaluateSym a, - EvaluateSym b, - EvaluateSym c, - EvaluateSym d, - EvaluateSym e, - EvaluateSym f, - EvaluateSym g - ) => - EvaluateSym (a, b, c, d, e, f, g) - --- (,,,,,,,) -deriving via - (Default (a, b, c, d, e, f, g, h)) - instance - ( EvaluateSym a, - EvaluateSym b, - EvaluateSym c, - EvaluateSym d, - EvaluateSym e, - EvaluateSym f, - EvaluateSym g, - EvaluateSym h - ) => - EvaluateSym ((,,,,,,,) a b c d e f g h) - --- MaybeT -instance (EvaluateSym (m (Maybe a))) => EvaluateSym (MaybeT m a) where - evaluateSym fillDefault model (MaybeT v) = MaybeT $ evaluateSym fillDefault model v - --- ExceptT -instance (EvaluateSym (m (Either e a))) => EvaluateSym (ExceptT e m a) where - evaluateSym fillDefault model (ExceptT v) = ExceptT $ evaluateSym fillDefault model v - --- Sum -deriving via - (Default (Sum f g a)) - instance - (EvaluateSym (f a), EvaluateSym (g a)) => EvaluateSym (Sum f g a) - --- WriterT -instance (EvaluateSym (m (a, s))) => EvaluateSym (WriterLazy.WriterT s m a) where - evaluateSym fillDefault model (WriterLazy.WriterT v) = WriterLazy.WriterT $ evaluateSym fillDefault model v - -instance (EvaluateSym (m (a, s))) => EvaluateSym (WriterStrict.WriterT s m a) where - evaluateSym fillDefault model (WriterStrict.WriterT v) = WriterStrict.WriterT $ evaluateSym fillDefault model v - --- Identity -instance (EvaluateSym a) => EvaluateSym (Identity a) where - evaluateSym fillDefault model (Identity a) = Identity $ evaluateSym fillDefault model a - --- IdentityT -instance (EvaluateSym (m a)) => EvaluateSym (IdentityT m a) where - evaluateSym fillDefault model (IdentityT a) = IdentityT $ evaluateSym fillDefault model a - --- Symbolic primitives -#define EVALUATE_SYM_SIMPLE(symtype) \ -instance EvaluateSym symtype where \ - evaluateSym fillDefault model (symtype t) = symtype $ evaluateTerm fillDefault model t - -#define EVALUATE_SYM_BV(symtype) \ -instance (KnownNat n, 1 <= n) => EvaluateSym (symtype n) where \ - evaluateSym fillDefault model (symtype t) = symtype $ evaluateTerm fillDefault model t - -#define EVALUATE_SYM_FUN(op, cons) \ -instance (SupportedPrim ca, SupportedPrim cb, LinkedRep ca sa, LinkedRep cb sb) => EvaluateSym (sa op sb) where \ - evaluateSym fillDefault model (cons t) = cons $ evaluateTerm fillDefault model t - -#define EVALUATE_SYM_BV_SOME(somety, origty) \ -instance EvaluateSym somety where \ - evaluateSym fillDefault model (somety (origty t)) = somety $ origty $ evaluateTerm fillDefault model t - -#if 1 -EVALUATE_SYM_SIMPLE(SymBool) -EVALUATE_SYM_SIMPLE(SymInteger) -EVALUATE_SYM_BV(SymIntN) -EVALUATE_SYM_BV(SymWordN) -EVALUATE_SYM_FUN(=~>, SymTabularFun) -EVALUATE_SYM_FUN(-~>, SymGeneralFun) -EVALUATE_SYM_BV_SOME(SomeSymIntN, SymIntN) -EVALUATE_SYM_BV_SOME(SomeSymWordN, SymWordN) -#endif - --- Exception -deriving via (Default AssertionError) instance EvaluateSym AssertionError - -deriving via (Default VerificationConditions) instance EvaluateSym VerificationConditions - -instance (Generic a, EvaluateSym' (Rep a)) => EvaluateSym (Default a) where - evaluateSym fillDefault model = Default . to . evaluateSym' fillDefault model . from . unDefault - -class EvaluateSym' a where - evaluateSym' :: Bool -> Model -> a c -> a c - -instance EvaluateSym' U1 where - evaluateSym' _ _ = id - -instance (EvaluateSym c) => EvaluateSym' (K1 i c) where - evaluateSym' fillDefault model (K1 v) = K1 $ evaluateSym fillDefault model v - -instance (EvaluateSym' a) => EvaluateSym' (M1 i c a) where - evaluateSym' fillDefault model (M1 v) = M1 $ evaluateSym' fillDefault model v - -instance (EvaluateSym' a, EvaluateSym' b) => EvaluateSym' (a :+: b) where - evaluateSym' fillDefault model (L1 l) = L1 $ evaluateSym' fillDefault model l - evaluateSym' fillDefault model (R1 r) = R1 $ evaluateSym' fillDefault model r - -instance (EvaluateSym' a, EvaluateSym' b) => EvaluateSym' (a :*: b) where - evaluateSym' fillDefault model (a :*: b) = evaluateSym' fillDefault model a :*: evaluateSym' fillDefault model b diff --git a/src/Grisette/Core/Data/Class/ExtractSymbolics.hs b/src/Grisette/Core/Data/Class/ExtractSymbolics.hs deleted file mode 100644 --- a/src/Grisette/Core/Data/Class/ExtractSymbolics.hs +++ /dev/null @@ -1,323 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- Module : Grisette.Core.Data.Class.ExtractSymbolics --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Core.Data.Class.ExtractSymbolics - ( -- * Extracting symbolic constant set from a value - ExtractSymbolics (..), - ) -where - -import Control.Monad.Except (ExceptT (ExceptT)) -import Control.Monad.Identity - ( Identity (Identity), - IdentityT (IdentityT), - ) -import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) -import qualified Control.Monad.Writer.Lazy as WriterLazy -import qualified Control.Monad.Writer.Strict as WriterStrict -import qualified Data.ByteString as B -import Data.Functor.Sum (Sum) -import Data.Int (Int16, Int32, Int64, Int8) -import qualified Data.Text as T -import Data.Word (Word16, Word32, Word64, Word8) -import GHC.TypeNats (KnownNat, type (<=)) -import Generics.Deriving - ( Default (Default, unDefault), - Generic (Rep, from), - K1 (unK1), - M1 (unM1), - U1, - type (:*:) ((:*:)), - type (:+:) (L1, R1), - ) -import Grisette.Core.Control.Exception (AssertionError, VerificationConditions) -import Grisette.Core.Data.BV (IntN, SomeIntN, SomeWordN, WordN) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term - ( LinkedRep, - SupportedPrim, - ) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermUtils (extractSymbolicsTerm) -import Grisette.IR.SymPrim.Data.Prim.Model - ( SymbolSet (SymbolSet), - ) -import Grisette.IR.SymPrim.Data.SymPrim - ( SomeSymIntN (SomeSymIntN), - SomeSymWordN (SomeSymWordN), - SymBool (SymBool), - SymIntN (SymIntN), - SymInteger (SymInteger), - SymWordN (SymWordN), - type (-~>) (SymGeneralFun), - type (=~>) (SymTabularFun), - ) - --- $setup --- >>> import Grisette.Core --- >>> import Grisette.IR.SymPrim --- >>> import Grisette.Lib.Base --- >>> import Data.HashSet as HashSet --- >>> import Data.List (sort) - --- | Extracts all the symbolic variables that are transitively contained in the given value. --- --- >>> extractSymbolics ("a" :: SymBool) :: SymbolSet --- SymbolSet {a :: Bool} --- --- >>> extractSymbolics (mrgIf "a" (mrgReturn ["b"]) (mrgReturn ["c", "d"]) :: UnionM [SymBool]) :: SymbolSet --- SymbolSet {a :: Bool, b :: Bool, c :: Bool, d :: Bool} --- --- __Note 1:__ This type class can be derived for algebraic data types. --- You may need the @DerivingVia@ and @DerivingStrategies@ extensions. --- --- > data X = ... deriving Generic deriving ExtractSymbolics via (Default X) -class ExtractSymbolics a where - extractSymbolics :: a -> SymbolSet - --- instances -#define CONCRETE_EXTRACT_SYMBOLICS(type) \ -instance ExtractSymbolics type where \ - extractSymbolics _ = mempty - -#define CONCRETE_EXTRACT_SYMBOLICS_BV(type) \ -instance (KnownNat n, 1 <= n) => ExtractSymbolics (type n) where \ - extractSymbolics _ = mempty - -#if 1 -CONCRETE_EXTRACT_SYMBOLICS(Bool) -CONCRETE_EXTRACT_SYMBOLICS(Integer) -CONCRETE_EXTRACT_SYMBOLICS(Char) -CONCRETE_EXTRACT_SYMBOLICS(Int) -CONCRETE_EXTRACT_SYMBOLICS(Int8) -CONCRETE_EXTRACT_SYMBOLICS(Int16) -CONCRETE_EXTRACT_SYMBOLICS(Int32) -CONCRETE_EXTRACT_SYMBOLICS(Int64) -CONCRETE_EXTRACT_SYMBOLICS(Word) -CONCRETE_EXTRACT_SYMBOLICS(Word8) -CONCRETE_EXTRACT_SYMBOLICS(Word16) -CONCRETE_EXTRACT_SYMBOLICS(Word32) -CONCRETE_EXTRACT_SYMBOLICS(Word64) -CONCRETE_EXTRACT_SYMBOLICS(SomeWordN) -CONCRETE_EXTRACT_SYMBOLICS(SomeIntN) -CONCRETE_EXTRACT_SYMBOLICS(B.ByteString) -CONCRETE_EXTRACT_SYMBOLICS(T.Text) -CONCRETE_EXTRACT_SYMBOLICS_BV(WordN) -CONCRETE_EXTRACT_SYMBOLICS_BV(IntN) -#endif - --- () -instance ExtractSymbolics () where - extractSymbolics _ = mempty - --- Either -deriving via - (Default (Either a b)) - instance - (ExtractSymbolics a, ExtractSymbolics b) => - ExtractSymbolics (Either a b) - --- Maybe -deriving via - (Default (Maybe a)) - instance - (ExtractSymbolics a) => ExtractSymbolics (Maybe a) - --- List -deriving via - (Default [a]) - instance - (ExtractSymbolics a) => ExtractSymbolics [a] - --- (,) -deriving via - (Default (a, b)) - instance - (ExtractSymbolics a, ExtractSymbolics b) => - ExtractSymbolics (a, b) - --- (,,) -deriving via - (Default (a, b, c)) - instance - (ExtractSymbolics a, ExtractSymbolics b, ExtractSymbolics c) => - ExtractSymbolics (a, b, c) - --- (,,,) -deriving via - (Default (a, b, c, d)) - instance - ( ExtractSymbolics a, - ExtractSymbolics b, - ExtractSymbolics c, - ExtractSymbolics d - ) => - ExtractSymbolics (a, b, c, d) - --- (,,,,) -deriving via - (Default (a, b, c, d, e)) - instance - ( ExtractSymbolics a, - ExtractSymbolics b, - ExtractSymbolics c, - ExtractSymbolics d, - ExtractSymbolics e - ) => - ExtractSymbolics (a, b, c, d, e) - --- (,,,,,) -deriving via - (Default (a, b, c, d, e, f)) - instance - ( ExtractSymbolics a, - ExtractSymbolics b, - ExtractSymbolics c, - ExtractSymbolics d, - ExtractSymbolics e, - ExtractSymbolics f - ) => - ExtractSymbolics (a, b, c, d, e, f) - --- (,,,,,,) -deriving via - (Default (a, b, c, d, e, f, g)) - instance - ( ExtractSymbolics a, - ExtractSymbolics b, - ExtractSymbolics c, - ExtractSymbolics d, - ExtractSymbolics e, - ExtractSymbolics f, - ExtractSymbolics g - ) => - ExtractSymbolics (a, b, c, d, e, f, g) - --- (,,,,,,,) -deriving via - (Default (a, b, c, d, e, f, g, h)) - instance - ( ExtractSymbolics a, - ExtractSymbolics b, - ExtractSymbolics c, - ExtractSymbolics d, - ExtractSymbolics e, - ExtractSymbolics f, - ExtractSymbolics g, - ExtractSymbolics h - ) => - ExtractSymbolics (a, b, c, d, e, f, g, h) - --- MaybeT -instance (ExtractSymbolics (m (Maybe a))) => ExtractSymbolics (MaybeT m a) where - extractSymbolics (MaybeT v) = extractSymbolics v - --- ExceptT -instance - (ExtractSymbolics (m (Either e a))) => - ExtractSymbolics (ExceptT e m a) - where - extractSymbolics (ExceptT v) = extractSymbolics v - --- Sum -deriving via - (Default (Sum f g a)) - instance - (ExtractSymbolics (f a), ExtractSymbolics (g a)) => - ExtractSymbolics (Sum f g a) - --- WriterT -instance - (ExtractSymbolics (m (a, s))) => - ExtractSymbolics (WriterLazy.WriterT s m a) - where - extractSymbolics (WriterLazy.WriterT f) = extractSymbolics f - -instance - (ExtractSymbolics (m (a, s))) => - ExtractSymbolics (WriterStrict.WriterT s m a) - where - extractSymbolics (WriterStrict.WriterT f) = extractSymbolics f - --- Identity -instance (ExtractSymbolics a) => ExtractSymbolics (Identity a) where - extractSymbolics (Identity a) = extractSymbolics a - --- IdentityT -instance (ExtractSymbolics (m a)) => ExtractSymbolics (IdentityT m a) where - extractSymbolics (IdentityT a) = extractSymbolics a - -#define EXTRACT_SYMBOLICS_SIMPLE(symtype) \ -instance ExtractSymbolics symtype where \ - extractSymbolics (symtype t) = SymbolSet $ extractSymbolicsTerm t - -#define EXTRACT_SYMBOLICS_BV(symtype) \ -instance (KnownNat n, 1 <= n) => ExtractSymbolics (symtype n) where \ - extractSymbolics (symtype t) = SymbolSet $ extractSymbolicsTerm t - -#define EXTRACT_SYMBOLICS_FUN(op, cons) \ -instance (SupportedPrim ca, SupportedPrim cb, LinkedRep ca sa, LinkedRep cb sb) => ExtractSymbolics (sa op sb) where \ - extractSymbolics (cons t) = SymbolSet $ extractSymbolicsTerm t - -#define EXTRACT_SYMBOLICS_BV_SOME(somety, origty) \ -instance ExtractSymbolics somety where \ - extractSymbolics (somety (origty t)) = SymbolSet $ extractSymbolicsTerm t - -#if 1 -EXTRACT_SYMBOLICS_SIMPLE(SymBool) -EXTRACT_SYMBOLICS_SIMPLE(SymInteger) -EXTRACT_SYMBOLICS_BV(SymIntN) -EXTRACT_SYMBOLICS_BV(SymWordN) -EXTRACT_SYMBOLICS_FUN(=~>, SymTabularFun) -EXTRACT_SYMBOLICS_FUN(-~>, SymGeneralFun) -EXTRACT_SYMBOLICS_BV_SOME(SomeSymIntN, SymIntN) -EXTRACT_SYMBOLICS_BV_SOME(SomeSymWordN, SymWordN) -#endif - --- Exception -deriving via (Default AssertionError) instance ExtractSymbolics AssertionError - -deriving via (Default VerificationConditions) instance ExtractSymbolics VerificationConditions - -instance (Generic a, ExtractSymbolics' (Rep a)) => ExtractSymbolics (Default a) where - extractSymbolics = extractSymbolics' . from . unDefault - -class ExtractSymbolics' a where - extractSymbolics' :: a c -> SymbolSet - -instance ExtractSymbolics' U1 where - extractSymbolics' _ = mempty - -instance (ExtractSymbolics c) => ExtractSymbolics' (K1 i c) where - extractSymbolics' = extractSymbolics . unK1 - -instance (ExtractSymbolics' a) => ExtractSymbolics' (M1 i c a) where - extractSymbolics' = extractSymbolics' . unM1 - -instance - (ExtractSymbolics' a, ExtractSymbolics' b) => - ExtractSymbolics' (a :+: b) - where - extractSymbolics' (L1 l) = extractSymbolics' l - extractSymbolics' (R1 r) = extractSymbolics' r - -instance - (ExtractSymbolics' a, ExtractSymbolics' b) => - ExtractSymbolics' (a :*: b) - where - extractSymbolics' (l :*: r) = extractSymbolics' l <> extractSymbolics' r diff --git a/src/Grisette/Core/Data/Class/Function.hs b/src/Grisette/Core/Data/Class/Function.hs deleted file mode 100644 --- a/src/Grisette/Core/Data/Class/Function.hs +++ /dev/null @@ -1,72 +0,0 @@ -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeFamilies #-} - --- | --- Module : Grisette.Core.Data.Class.Function --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Core.Data.Class.Function - ( -- * Function operations - Function (..), - Apply (..), - ) -where - --- $setup --- >>> import Grisette.Core --- >>> import Grisette.IR.SymPrim --- >>> :set -XDataKinds --- >>> :set -XBinaryLiterals --- >>> :set -XFlexibleContexts --- >>> :set -XFlexibleInstances --- >>> :set -XFunctionalDependencies --- >>> :set -XOverloadedStrings --- >>> :set -XTypeOperators - --- | Abstraction for function-like types. -class Function f where - -- | Argument type - type Arg f - - -- | Return type - type Ret f - - -- | Function application operator. - -- - -- The operator is not right associated (like `($)`). It is left associated, - -- and you can provide many arguments with this operator once at a time. - -- - -- >>> (+1) # 2 - -- 3 - -- - -- >>> (+) # 2 # 3 - -- 5 - (#) :: f -> Arg f -> Ret f - - infixl 9 # - -instance Function (a -> b) where - type Arg (a -> b) = a - type Ret (a -> b) = b - f # a = f a - --- | Applying an uninterpreted function. --- --- >>> let f = "f" :: SymInteger =~> SymInteger =~> SymInteger --- >>> apply f "a" "b" --- (apply (apply f a) b) --- --- Note that for implementation reasons, you can also use `apply` function on --- a non-function symbolic value. In this case, the function is treated as an --- `id` function. -class Apply uf where - type FunType uf - apply :: uf -> FunType uf - -instance (Apply b) => Apply (a -> b) where - type FunType (a -> b) = a -> FunType b - apply f a = apply (f a) diff --git a/src/Grisette/Core/Data/Class/GPretty.hs b/src/Grisette/Core/Data/Class/GPretty.hs deleted file mode 100644 --- a/src/Grisette/Core/Data/Class/GPretty.hs +++ /dev/null @@ -1,466 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE EmptyCase #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -module Grisette.Core.Data.Class.GPretty - ( GPretty (..), - groupedEnclose, - condEnclose, - ) -where - -import Control.Monad.Except (ExceptT (ExceptT)) -import Control.Monad.Identity - ( Identity (Identity), - IdentityT (IdentityT), - ) -import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) -import qualified Control.Monad.Writer.Lazy as WriterLazy -import qualified Control.Monad.Writer.Strict as WriterStrict -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as C -import Data.Functor.Sum (Sum) -import Data.Int (Int16, Int32, Int64, Int8) -import Data.String (IsString (fromString)) -import qualified Data.Text as T -import Data.Word (Word16, Word32, Word64, Word8) -import GHC.Generics - ( C, - C1, - Constructor (conFixity, conIsRecord, conName), - D, - Fixity (Infix, Prefix), - Generic (Rep, from), - K1 (K1), - M1 (M1), - S, - Selector (selName), - U1 (U1), - V1, - type (:*:) ((:*:)), - type (:+:) (L1, R1), - ) -import GHC.TypeLits (KnownNat, type (<=)) -import Generics.Deriving (Default (Default, unDefault)) -import Grisette.Core.Data.BV (IntN, SomeIntN, SomeWordN, WordN) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term - ( LinkedRep, - SupportedPrim, - prettyPrintTerm, - ) -import Grisette.IR.SymPrim.Data.SymPrim - ( SomeSymIntN (SomeSymIntN), - SomeSymWordN (SomeSymWordN), - SymBool (SymBool), - SymIntN (SymIntN), - SymInteger (SymInteger), - SymWordN (SymWordN), - type (-~>) (SymGeneralFun), - type (=~>) (SymTabularFun), - ) - -#if MIN_VERSION_prettyprinter(1,7,0) -import Prettyprinter - ( (<+>), - align, - encloseSep, - flatAlt, - group, - nest, - vcat, - viaShow, - vsep, - Doc, - Pretty(pretty), - ) -#else -import Data.Text.Prettyprint.Doc - ( (<+>), - align, - encloseSep, - flatAlt, - group, - nest, - vcat, - viaShow, - vsep, - Doc, - Pretty(pretty), - ) -#endif - -glist :: [Doc ann] -> Doc ann -glist l - | null l = "[]" - | length l == 1 = "[" <> head l <> "]" - | otherwise = groupedEnclose "[" "]" $ encloseSep "" "" (flatAlt ", " ",") l - -class GPretty a where - gpretty :: a -> Doc ann - gprettyPrec :: Int -> a -> Doc ann - gprettyList :: [a] -> Doc ann - gprettyList = align . glist . map gpretty - - gpretty = gprettyPrec 0 - gprettyPrec _ = gpretty - - {-# MINIMAL gpretty | gprettyPrec #-} - -#define GPRETTY_SIMPLE(type) \ -instance GPretty type where gprettyPrec = viaShowsPrec showsPrec - -instance GPretty Char where - gpretty = viaShow - gprettyList v = pretty (fromString v :: T.Text) - -#if 1 -GPRETTY_SIMPLE(Bool) -GPRETTY_SIMPLE(Integer) -GPRETTY_SIMPLE(Int) -GPRETTY_SIMPLE(Int8) -GPRETTY_SIMPLE(Int16) -GPRETTY_SIMPLE(Int32) -GPRETTY_SIMPLE(Int64) -GPRETTY_SIMPLE(Word) -GPRETTY_SIMPLE(Word8) -GPRETTY_SIMPLE(Word16) -GPRETTY_SIMPLE(Word32) -GPRETTY_SIMPLE(Word64) -GPRETTY_SIMPLE(SomeIntN) -GPRETTY_SIMPLE(SomeWordN) -#endif - -instance GPretty B.ByteString where - gpretty = pretty . C.unpack - -instance GPretty T.Text where - gpretty = pretty - -instance (KnownNat n, 1 <= n) => GPretty (IntN n) where - gpretty = viaShow - -instance (KnownNat n, 1 <= n) => GPretty (WordN n) where - gpretty = viaShow - --- () -instance GPretty () where - gpretty = viaShow - --- Either -deriving via - (Default (Either a b)) - instance - (GPretty a, GPretty b) => GPretty (Either a b) - --- Maybe -deriving via - (Default (Maybe a)) - instance - (GPretty a) => GPretty (Maybe a) - --- List -instance (GPretty a) => GPretty [a] where - gpretty = gprettyList - --- (,) -deriving via - (Default (a, b)) - instance - (GPretty a, GPretty b) => GPretty (a, b) - --- (,,) -deriving via - (Default (a, b, c)) - instance - (GPretty a, GPretty b, GPretty c) => GPretty (a, b, c) - --- (,,,) -deriving via - (Default (a, b, c, d)) - instance - ( GPretty a, - GPretty b, - GPretty c, - GPretty d - ) => - GPretty (a, b, c, d) - --- (,,,,) -deriving via - (Default (a, b, c, d, e)) - instance - ( GPretty a, - GPretty b, - GPretty c, - GPretty d, - GPretty e - ) => - GPretty (a, b, c, d, e) - --- (,,,,,) -deriving via - (Default (a, b, c, d, e, f)) - instance - ( GPretty a, - GPretty b, - GPretty c, - GPretty d, - GPretty e, - GPretty f - ) => - GPretty (a, b, c, d, e, f) - --- (,,,,,,) -deriving via - (Default (a, b, c, d, e, f, g)) - instance - ( GPretty a, - GPretty b, - GPretty c, - GPretty d, - GPretty e, - GPretty f, - GPretty g - ) => - GPretty (a, b, c, d, e, f, g) - --- (,,,,,,,) -deriving via - (Default (a, b, c, d, e, f, g, h)) - instance - ( GPretty a, - GPretty b, - GPretty c, - GPretty d, - GPretty e, - GPretty f, - GPretty g, - GPretty h - ) => - GPretty (a, b, c, d, e, f, g, h) - --- Sum -deriving via - (Default (Sum f g a)) - instance - (GPretty (f a), GPretty (g a)) => - GPretty (Sum f g a) - --- MaybeT -instance - (GPretty (m (Maybe a))) => - GPretty (MaybeT m a) - where - gprettyPrec _ (MaybeT a) = - group $ - nest 2 $ - vsep - [ "MaybeT", - gprettyPrec 11 a - ] - --- ExceptT -instance - (GPretty (m (Either e a))) => - GPretty (ExceptT e m a) - where - gprettyPrec _ (ExceptT a) = - group $ - nest 2 $ - vsep - [ "ExceptT", - gprettyPrec 11 a - ] - --- WriterT -instance - (GPretty (m (a, w))) => - GPretty (WriterLazy.WriterT w m a) - where - gprettyPrec _ (WriterLazy.WriterT a) = - group $ - nest 2 $ - vsep - [ "WriterT", - gprettyPrec 11 a - ] - -instance - (GPretty (m (a, w))) => - GPretty (WriterStrict.WriterT w m a) - where - gprettyPrec _ (WriterStrict.WriterT a) = - group $ - nest 2 $ - vsep - [ "WriterT", - gprettyPrec 11 a - ] - --- Identity -instance (GPretty a) => GPretty (Identity a) where - gprettyPrec _ (Identity a) = - group $ - nest 2 $ - vsep - [ "Identity", - gprettyPrec 11 a - ] - --- IdentityT -instance (GPretty (m a)) => GPretty (IdentityT m a) where - gprettyPrec _ (IdentityT a) = - group $ - nest 2 $ - vsep - [ "IdentityT", - gprettyPrec 11 a - ] - --- Prettyprint -#define GPRETTY_SYM_SIMPLE(symtype) \ -instance GPretty symtype where \ - gpretty (symtype t) = prettyPrintTerm t - -#define GPRETTY_SYM_BV(symtype) \ -instance (KnownNat n, 1 <= n) => GPretty (symtype n) where \ - gpretty (symtype t) = prettyPrintTerm t - -#define GPRETTY_SYM_FUN(op, cons) \ -instance (SupportedPrim ca, SupportedPrim cb, LinkedRep ca sa, LinkedRep cb sb)\ - => GPretty (sa op sb) where \ - gpretty (cons t) = prettyPrintTerm t - -#define GPRETTY_SYM_SOME_BV(symtype) \ -instance GPretty symtype where \ - gpretty (symtype t) = gpretty t - -#if 1 -GPRETTY_SYM_SIMPLE(SymBool) -GPRETTY_SYM_SIMPLE(SymInteger) -GPRETTY_SYM_BV(SymIntN) -GPRETTY_SYM_BV(SymWordN) -GPRETTY_SYM_FUN(=~>, SymTabularFun) -GPRETTY_SYM_FUN(-~>, SymGeneralFun) -GPRETTY_SYM_SOME_BV(SomeSymIntN) -GPRETTY_SYM_SOME_BV(SomeSymWordN) -#endif - -instance (Generic a, GPretty' (Rep a)) => GPretty (Default a) where - gprettyPrec i v = gprettyPrec' Pref i $ from $ unDefault v - -data Type = Rec | Tup | Pref | Inf String Int - -class GPretty' a where - gprettyPrec' :: Type -> Int -> a c -> Doc ann - isNullary :: a c -> Bool - isNullary = error "generic gpretty (isNullary): unnecessary case" - -instance GPretty' V1 where - gprettyPrec' _ _ x = case x of {} - -instance GPretty' U1 where - gprettyPrec' _ _ U1 = "" - isNullary _ = True - -instance (GPretty c) => GPretty' (K1 i c) where - gprettyPrec' _ n (K1 a) = gprettyPrec n a - isNullary _ = False - -groupedEnclose :: Doc ann -> Doc ann -> Doc ann -> Doc ann -groupedEnclose l r d = group $ align $ vcat [l <> flatAlt " " "" <> d, r] - -condEnclose :: Bool -> Doc ann -> Doc ann -> Doc ann -> Doc ann -condEnclose b = if b then groupedEnclose else const $ const id - -instance (GPretty' a, Constructor c) => GPretty' (M1 C c a) where - gprettyPrec' _ n c@(M1 x) = - case t of - Tup -> - prettyBraces t (gprettyPrec' t 0 x) - Inf _ m -> - group $ condEnclose (n > m) "(" ")" $ gprettyPrec' t m x - _ -> - if isNullary x - then pretty (conName c) - else - group $ - condEnclose (n > 10) "(" ")" $ - align $ - nest 2 $ - vsep - [ pretty (conName c), - prettyBraces t (gprettyPrec' t 11 x) - ] - where - prettyBraces :: Type -> Doc ann -> Doc ann - prettyBraces Rec = groupedEnclose "{" "}" - prettyBraces Tup = groupedEnclose "(" ")" - prettyBraces Pref = id - prettyBraces (Inf _ _) = id - fixity = conFixity c - t - | conIsRecord c = Rec - | conIsTuple c = Tup - | otherwise = case fixity of - Prefix -> Pref - Infix _ i -> Inf (conName c) i - conIsTuple :: C1 c f p -> Bool - conIsTuple y = tupleName (conName y) - where - tupleName ('(' : ',' : _) = True - tupleName _ = False - -instance (Selector s, GPretty' a) => GPretty' (M1 S s a) where - gprettyPrec' t n s@(M1 x) - | selName s == "" = - case t of - Pref -> gprettyPrec' t (n + 1) x - _ -> gprettyPrec' t (n + 1) x - | otherwise = - pretty (selName s) <+> "=" <+> gprettyPrec' t 0 x - isNullary (M1 x) = isNullary x - -instance (GPretty' a) => GPretty' (M1 D d a) where - gprettyPrec' t n (M1 x) = gprettyPrec' t n x - -instance (GPretty' a, GPretty' b) => GPretty' (a :+: b) where - gprettyPrec' t n (L1 x) = gprettyPrec' t n x - gprettyPrec' t n (R1 x) = gprettyPrec' t n x - -instance (GPretty' a, GPretty' b) => GPretty' (a :*: b) where - gprettyPrec' t@Rec n (a :*: b) = - vcat - [ gprettyPrec' t n a, - "," <+> gprettyPrec' t n b - ] - gprettyPrec' t@(Inf s _) n (a :*: b) = - align $ - nest 2 $ - vsep - [ gprettyPrec' t n a, - pretty s <+> gprettyPrec' t n b - ] - gprettyPrec' t@Tup _ (a :*: b) = - vcat - [ gprettyPrec' t 0 a, - "," <> flatAlt " " "" <> gprettyPrec' t 0 b - ] - gprettyPrec' t@Pref n (a :*: b) = - vsep - [ gprettyPrec' t (n + 1) a, - gprettyPrec' t (n + 1) b - ] - isNullary _ = False - -viaShowsPrec :: (Int -> a -> ShowS) -> Int -> a -> Doc ann -viaShowsPrec f n a = pretty (f n a "") diff --git a/src/Grisette/Core/Data/Class/GenSym.hs b/src/Grisette/Core/Data/Class/GenSym.hs deleted file mode 100644 --- a/src/Grisette/Core/Data/Class/GenSym.hs +++ /dev/null @@ -1,1815 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskellQuotes #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- Module : Grisette.Core.Data.Class.GenSym --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Core.Data.Class.GenSym - ( -- * Indices and identifiers for fresh symbolic value generation - FreshIndex (..), - FreshIdent (..), - name, - nameWithInfo, - - -- * Monad for fresh symbolic value generation - MonadFresh (..), - nextFreshIndex, - liftFresh, - FreshT (FreshT, runFreshTFromIndex), - Fresh, - runFreshT, - runFresh, - mrgRunFreshT, - - -- * Symbolic value generation - GenSym (..), - GenSymSimple (..), - genSym, - genSymSimple, - derivedNoSpecFresh, - derivedNoSpecSimpleFresh, - derivedSameShapeSimpleFresh, - - -- * Symbolic choices - chooseFresh, - chooseSimpleFresh, - chooseUnionFresh, - choose, - chooseSimple, - chooseUnion, - - -- * Some common GenSym specifications - ListSpec (..), - SimpleListSpec (..), - EnumGenBound (..), - EnumGenUpperBound (..), - ) -where - -import Control.DeepSeq (NFData (rnf)) -import Control.Monad.Except - ( ExceptT (ExceptT), - MonadError (catchError, throwError), - ) -import Control.Monad.Identity (Identity (runIdentity)) -import Control.Monad.RWS.Class - ( MonadRWS, - MonadReader (ask, local), - MonadState (get, put), - MonadWriter (listen, pass, writer), - asks, - gets, - ) -import qualified Control.Monad.RWS.Lazy as RWSLazy -import qualified Control.Monad.RWS.Strict as RWSStrict -import Control.Monad.Reader (ReaderT) -import Control.Monad.Signatures (Catch) -import qualified Control.Monad.State.Lazy as StateLazy -import qualified Control.Monad.State.Strict as StateStrict -import Control.Monad.Trans.Class - ( MonadTrans (lift), - ) -import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) -import qualified Control.Monad.Writer.Lazy as WriterLazy -import qualified Control.Monad.Writer.Strict as WriterStrict -import Data.Bifunctor (Bifunctor (first)) -import qualified Data.ByteString as B -import Data.Hashable (Hashable (hashWithSalt)) -import Data.Int (Int16, Int32, Int64, Int8) -import Data.String (IsString (fromString)) -import qualified Data.Text as T -import Data.Typeable - ( Proxy (Proxy), - Typeable, - eqT, - typeRep, - type (:~:) (Refl), - ) -import Data.Word (Word16, Word32, Word64, Word8) -import GHC.TypeNats (KnownNat, Nat, type (<=)) -import Generics.Deriving - ( Generic (Rep, from, to), - K1 (K1), - M1 (M1), - U1 (U1), - type (:*:) ((:*:)), - type (:+:) (L1, R1), - ) -import Grisette.Core.Control.Monad.UnionM (UnionM, isMerged, underlyingUnion) -import Grisette.Core.Data.BV (IntN, SomeIntN, SomeWordN, WordN) -import Grisette.Core.Data.Class.Mergeable - ( Mergeable (rootStrategy), - Mergeable1 (liftRootStrategy), - Mergeable2 (liftRootStrategy2), - MergingStrategy (SimpleStrategy), - rootStrategy1, - wrapStrategy, - ) -import Grisette.Core.Data.Class.SimpleMergeable - ( SimpleMergeable (mrgIte), - SimpleMergeable1 (liftMrgIte), - UnionLike (mergeWithStrategy, mrgIfWithStrategy, single, unionIf), - merge, - mrgIf, - mrgSingle, - ) -import Grisette.Core.Data.Class.Solvable - ( Solvable (iinfosym, isym), - ) -import Grisette.Core.Data.Union (Union (UnionIf, UnionSingle)) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term - ( LinkedRep, - SupportedPrim, - ) -import Grisette.IR.SymPrim.Data.SymPrim - ( SomeSymIntN (SomeSymIntN), - SomeSymWordN (SomeSymWordN), - SymBool, - SymIntN, - SymInteger, - SymWordN, - type (-~>), - type (=~>), - ) -import Grisette.Utils.Parameterized - ( KnownProof (KnownProof), - LeqProof (LeqProof), - unsafeKnownProof, - unsafeLeqProof, - ) -import Language.Haskell.TH.Syntax (Lift (liftTyped)) - --- $setup --- >>> import Grisette.Core --- >>> import Grisette.IR.SymPrim --- >>> :set -XOverloadedStrings --- >>> :set -XTypeApplications - --- | Index type used for 'GenSym'. --- --- To generate fresh variables, a monadic stateful context will be maintained. --- The index should be increased every time a new symbolic constant is --- generated. -newtype FreshIndex = FreshIndex Int - deriving (Show) - deriving (Eq, Ord, Num) via Int - -instance Mergeable FreshIndex where - rootStrategy = SimpleStrategy $ \_ t f -> max t f - -instance SimpleMergeable FreshIndex where - mrgIte _ = max - --- | Identifier type used for 'GenSym' --- --- The constructor is hidden intentionally. --- You can construct an identifier by: --- --- * a raw name --- --- The following two expressions will refer to the same identifier (the --- solver won't distinguish them and would assign the same value to them). --- The user may need to use unique names to avoid unintentional identifier --- collision. --- --- >>> name "a" --- a --- --- >>> "a" :: FreshIdent -- available when OverloadedStrings is enabled --- a --- --- * bundle the calling file location with the name to ensure global uniqueness --- --- Identifiers created at different locations will not be the --- same. The identifiers created at the same location will be the same. --- --- >>> $$(nameWithLoc "a") -- a sample result could be "a::18:4-18" --- a::... --- --- * bundle the calling file location with some user provided information --- --- Identifiers created with different name or different additional --- information will not be the same. --- --- >>> nameWithInfo "a" (1 :: Int) --- a:1 -data FreshIdent where - FreshIdent :: T.Text -> FreshIdent - FreshIdentWithInfo :: (Typeable a, Ord a, Lift a, NFData a, Show a, Hashable a) => T.Text -> a -> FreshIdent - -instance Show FreshIdent where - show (FreshIdent i) = T.unpack i - show (FreshIdentWithInfo s i) = T.unpack s ++ ":" ++ show i - -instance IsString FreshIdent where - fromString = name . T.pack - -instance Eq FreshIdent where - FreshIdent l == FreshIdent r = l == r - FreshIdentWithInfo l (linfo :: linfo) == FreshIdentWithInfo r (rinfo :: rinfo) = case eqT @linfo @rinfo of - Just Refl -> l == r && linfo == rinfo - _ -> False - _ == _ = False - -instance Ord FreshIdent where - FreshIdent l <= FreshIdent r = l <= r - FreshIdent _ <= _ = True - _ <= FreshIdent _ = False - FreshIdentWithInfo l (linfo :: linfo) <= FreshIdentWithInfo r (rinfo :: rinfo) = - l < r - || ( l == r - && ( case eqT @linfo @rinfo of - Just Refl -> linfo <= rinfo - _ -> typeRep (Proxy @linfo) <= typeRep (Proxy @rinfo) - ) - ) - -instance Hashable FreshIdent where - hashWithSalt s (FreshIdent n) = s `hashWithSalt` n - hashWithSalt s (FreshIdentWithInfo n i) = s `hashWithSalt` n `hashWithSalt` i - -instance Lift FreshIdent where - liftTyped (FreshIdent n) = [||FreshIdent n||] - liftTyped (FreshIdentWithInfo n i) = [||FreshIdentWithInfo n i||] - -instance NFData FreshIdent where - rnf (FreshIdent n) = rnf n - rnf (FreshIdentWithInfo n i) = rnf n `seq` rnf i - --- | Simple name identifier. --- The same identifier refers to the same symbolic variable in the whole program. --- --- The user may need to use unique names to avoid unintentional identifier --- collision. -name :: T.Text -> FreshIdent -name = FreshIdent - --- | Identifier with extra information. --- The same name with the same information --- refers to the same symbolic variable in the whole program. --- --- The user may need to use unique names or additional information to avoid --- unintentional identifier collision. -nameWithInfo :: forall a. (Typeable a, Ord a, Lift a, NFData a, Show a, Hashable a) => T.Text -> a -> FreshIdent -nameWithInfo = FreshIdentWithInfo - --- | Monad class for fresh symbolic value generation. --- --- The monad should be a reader monad for the 'FreshIdent' and a state monad for --- the 'FreshIndex'. -class (Monad m) => MonadFresh m where - -- | Get the current index for fresh variable generation. - getFreshIndex :: m FreshIndex - - -- | Set the current index for fresh variable generation. - setFreshIndex :: FreshIndex -> m () - - -- | Get the identifier. - getFreshIdent :: m FreshIdent - --- | Get the next fresh index and increase the current index. -nextFreshIndex :: (MonadFresh m) => m FreshIndex -nextFreshIndex = do - curr <- getFreshIndex - let new = curr + 1 - setFreshIndex new - return curr - --- | Lifts an @`Fresh` a@ into any `MonadFresh`. -liftFresh :: (MonadFresh m) => Fresh a -> m a -liftFresh (FreshT f) = do - index <- nextFreshIndex - ident <- getFreshIdent - let (a, newIdx) = runIdentity $ f ident index - setFreshIndex newIdx - return a - --- | A symbolic generation monad transformer. --- It is a reader monad transformer for identifiers and --- a state monad transformer for indices. --- --- Each time a fresh symbolic variable is generated, the index should be increased. -newtype FreshT m a = FreshT - { runFreshTFromIndex :: FreshIdent -> FreshIndex -> m (a, FreshIndex) - } - -instance - (Mergeable a, Mergeable1 m) => - Mergeable (FreshT m a) - where - rootStrategy = - wrapStrategy (liftRootStrategy (liftRootStrategy rootStrategy1)) FreshT runFreshTFromIndex - -instance (Mergeable1 m) => Mergeable1 (FreshT m) where - liftRootStrategy m = - wrapStrategy - (liftRootStrategy (liftRootStrategy (liftRootStrategy (liftRootStrategy2 m rootStrategy)))) - FreshT - runFreshTFromIndex - -instance - (UnionLike m, Mergeable a) => - SimpleMergeable (FreshT m a) - where - mrgIte = mrgIf - -instance - (UnionLike m) => - SimpleMergeable1 (FreshT m) - where - liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) - -instance - (UnionLike m) => - UnionLike (FreshT m) - where - mergeWithStrategy s (FreshT f) = - FreshT $ \ident index -> mergeWithStrategy (liftRootStrategy2 s rootStrategy) $ f ident index - mrgIfWithStrategy s cond (FreshT t) (FreshT f) = - FreshT $ \ident index -> mrgIfWithStrategy (liftRootStrategy2 s rootStrategy) cond (t ident index) (f ident index) - single x = FreshT $ \_ i -> single (x, i) - unionIf cond (FreshT t) (FreshT f) = - FreshT $ \ident index -> unionIf cond (t ident index) (f ident index) - --- | Run the symbolic generation with the given identifier and 0 as the initial index. -runFreshT :: (Monad m) => FreshT m a -> FreshIdent -> m a -runFreshT m ident = fst <$> runFreshTFromIndex m ident (FreshIndex 0) - -mrgRunFreshT :: - (Monad m, UnionLike m, Mergeable a) => - FreshT m a -> - FreshIdent -> - m a -mrgRunFreshT m ident = merge $ runFreshT m ident - -instance (Functor f) => Functor (FreshT f) where - fmap f (FreshT s) = FreshT $ \ident idx -> first f <$> s ident idx - -instance (Applicative m, Monad m) => Applicative (FreshT m) where - pure a = FreshT $ \_ idx -> pure (a, idx) - FreshT fs <*> FreshT as = FreshT $ \ident idx -> do - (f, idx') <- fs ident idx - (a, idx'') <- as ident idx' - return (f a, idx'') - -instance (Monad m) => Monad (FreshT m) where - (FreshT s) >>= f = FreshT $ \ident idx -> do - (a, idx') <- s ident idx - runFreshTFromIndex (f a) ident idx' - -instance MonadTrans FreshT where - lift x = FreshT $ \_ index -> (,index) <$> x - -liftFreshTCache :: (Functor m) => Catch e m (a, FreshIndex) -> Catch e (FreshT m) a -liftFreshTCache catchE (FreshT m) h = - FreshT $ \ident index -> m ident index `catchE` \e -> runFreshTFromIndex (h e) ident index - -instance (MonadError e m) => MonadError e (FreshT m) where - throwError = lift . throwError - catchError = liftFreshTCache catchError - -instance (MonadWriter w m) => MonadWriter w (FreshT m) where - writer p = FreshT $ \_ index -> (,index) <$> writer p - listen (FreshT r) = FreshT $ \ident index -> (\((a, b), c) -> ((a, c), b)) <$> listen (r ident index) - pass (FreshT r) = FreshT $ \ident index -> pass $ (\((a, b), c) -> ((a, c), b)) <$> r ident index - -instance (MonadState s m) => MonadState s (FreshT m) where - get = FreshT $ \_ index -> gets (,index) - put s = FreshT $ \_ index -> (,index) <$> put s - -instance (MonadReader r m) => MonadReader r (FreshT m) where - local t (FreshT r) = FreshT $ \ident index -> local t (r ident index) - ask = FreshT $ \_ index -> asks (,index) - -instance (MonadRWS r w s m) => MonadRWS r w s (FreshT m) - -instance (MonadFresh m) => MonadFresh (ExceptT e m) where - getFreshIndex = lift getFreshIndex - setFreshIndex newIdx = lift $ setFreshIndex newIdx - getFreshIdent = lift getFreshIdent - -instance (MonadFresh m, Monoid w) => MonadFresh (WriterLazy.WriterT w m) where - getFreshIndex = lift getFreshIndex - setFreshIndex newIdx = lift $ setFreshIndex newIdx - getFreshIdent = lift getFreshIdent - -instance (MonadFresh m, Monoid w) => MonadFresh (WriterStrict.WriterT w m) where - getFreshIndex = lift getFreshIndex - setFreshIndex newIdx = lift $ setFreshIndex newIdx - getFreshIdent = lift getFreshIdent - -instance (MonadFresh m) => MonadFresh (StateLazy.StateT s m) where - getFreshIndex = lift getFreshIndex - setFreshIndex newIdx = lift $ setFreshIndex newIdx - getFreshIdent = lift getFreshIdent - -instance (MonadFresh m) => MonadFresh (StateStrict.StateT s m) where - getFreshIndex = lift getFreshIndex - setFreshIndex newIdx = lift $ setFreshIndex newIdx - getFreshIdent = lift getFreshIdent - -instance (MonadFresh m) => MonadFresh (ReaderT r m) where - getFreshIndex = lift getFreshIndex - setFreshIndex newIdx = lift $ setFreshIndex newIdx - getFreshIdent = lift getFreshIdent - -instance (MonadFresh m, Monoid w) => MonadFresh (RWSLazy.RWST r w s m) where - getFreshIndex = lift getFreshIndex - setFreshIndex newIdx = lift $ setFreshIndex newIdx - getFreshIdent = lift getFreshIdent - -instance (MonadFresh m, Monoid w) => MonadFresh (RWSStrict.RWST r w s m) where - getFreshIndex = lift getFreshIndex - setFreshIndex newIdx = lift $ setFreshIndex newIdx - getFreshIdent = lift getFreshIdent - --- | 'FreshT' specialized with Identity. -type Fresh = FreshT Identity - --- | Run the symbolic generation with the given identifier and 0 as the initial index. -runFresh :: Fresh a -> FreshIdent -> a -runFresh m ident = runIdentity $ runFreshT m ident - -instance (Monad m) => MonadFresh (FreshT m) where - getFreshIndex = FreshT $ \_ idx -> return (idx, idx) - setFreshIndex newIdx = FreshT $ \_ _ -> return ((), newIdx) - getFreshIdent = FreshT $ curry return - --- | Class of types in which symbolic values can be generated with respect to some specification. --- --- The result will be wrapped in a union-like monad. --- This ensures that we can generate those types with complex merging rules. --- --- The uniqueness of symbolic constants is managed with the a monadic context. --- 'Fresh' and 'FreshT' can be useful. -class (Mergeable a) => GenSym spec a where - -- | Generate a symbolic value given some specification. Within a single - -- `MonadFresh` context, calls to `fresh` would generate unique symbolic - -- constants. - -- - -- The following example generates a symbolic boolean. No specification is - -- needed. - -- - -- >>> runFresh (fresh ()) "a" :: UnionM SymBool - -- {a@0} - -- - -- The following example generates booleans, which cannot be merged into a - -- single value with type 'Bool'. No specification is needed. - -- - -- >>> runFresh (fresh ()) "a" :: UnionM Bool - -- {If a@0 False True} - -- - -- The following example generates @Maybe Bool@s. - -- There are more than one symbolic constants introduced, and their uniqueness - -- is ensured. No specification is needed. - -- - -- >>> runFresh (fresh ()) "a" :: UnionM (Maybe Bool) - -- {If a@0 Nothing (If a@1 (Just False) (Just True))} - -- - -- The following example generates lists of symbolic booleans with length 1 to 2. - -- - -- >>> runFresh (fresh (ListSpec 1 2 ())) "a" :: UnionM [SymBool] - -- {If a@2 [a@1] [a@0,a@1]} - -- - -- When multiple symbolic values are generated, there will not be any - -- identifier collision - -- - -- >>> runFresh (do; a <- fresh (); b <- fresh (); return (a, b)) "a" :: (UnionM SymBool, UnionM SymBool) - -- ({a@0},{a@1}) - fresh :: - (MonadFresh m) => - spec -> - m (UnionM a) - default fresh :: - (GenSymSimple spec a) => - ( MonadFresh m - ) => - spec -> - m (UnionM a) - fresh spec = mrgSingle <$> simpleFresh spec - --- | Generate a symbolic variable wrapped in a Union without the monadic context. --- A globally unique identifier should be supplied to ensure the uniqueness of --- symbolic constants in the generated symbolic values. --- --- >>> genSym (ListSpec 1 2 ()) "a" :: UnionM [SymBool] --- {If a@2 [a@1] [a@0,a@1]} -genSym :: (GenSym spec a) => spec -> FreshIdent -> UnionM a -genSym = runFresh . fresh - --- | Class of types in which symbolic values can be generated with respect to some specification. --- --- The result will __/not/__ be wrapped in a union-like monad. --- --- The uniqueness of symbolic constants is managed with the a monadic context. --- 'Fresh' and 'FreshT' can be useful. -class GenSymSimple spec a where - -- | Generate a symbolic value given some specification. The uniqueness is ensured. - -- - -- The following example generates a symbolic boolean. No specification is needed. - -- - -- >>> runFresh (simpleFresh ()) "a" :: SymBool - -- a@0 - -- - -- The following code generates list of symbolic boolean with length 2. - -- As the length is fixed, we don't have to wrap the result in unions. - -- - -- >>> runFresh (simpleFresh (SimpleListSpec 2 ())) "a" :: [SymBool] - -- [a@0,a@1] - simpleFresh :: - ( MonadFresh m - ) => - spec -> - m a - --- | Generate a simple symbolic variable wrapped in a Union without the monadic context. --- A globally unique identifier should be supplied to ensure the uniqueness of --- symbolic constants in the generated symbolic values. --- --- >>> genSymSimple (SimpleListSpec 2 ()) "a" :: [SymBool] --- [a@0,a@1] -genSymSimple :: forall spec a. (GenSymSimple spec a) => spec -> FreshIdent -> a -genSymSimple = runFresh . simpleFresh - -class GenSymNoSpec a where - freshNoSpec :: - ( MonadFresh m - ) => - m (UnionM (a c)) - -instance GenSymNoSpec U1 where - freshNoSpec = return $ mrgSingle U1 - -instance (GenSym () c) => GenSymNoSpec (K1 i c) where - freshNoSpec = fmap K1 <$> fresh () - -instance (GenSymNoSpec a) => GenSymNoSpec (M1 i c a) where - freshNoSpec = fmap M1 <$> freshNoSpec - -instance - ( GenSymNoSpec a, - GenSymNoSpec b, - forall x. Mergeable (a x), - forall x. Mergeable (b x) - ) => - GenSymNoSpec (a :+: b) - where - freshNoSpec :: - forall m c. - ( MonadFresh m - ) => - m (UnionM ((a :+: b) c)) - freshNoSpec = do - cond :: bool <- simpleFresh () - l :: UnionM (a c) <- freshNoSpec - r :: UnionM (b c) <- freshNoSpec - return $ mrgIf cond (fmap L1 l) (fmap R1 r) - -instance - (GenSymNoSpec a, GenSymNoSpec b) => - GenSymNoSpec (a :*: b) - where - freshNoSpec :: - forall m c. - ( MonadFresh m - ) => - m (UnionM ((a :*: b) c)) - freshNoSpec = do - l :: UnionM (a c) <- freshNoSpec - r :: UnionM (b c) <- freshNoSpec - return $ do - l1 <- l - r1 <- r - return $ l1 :*: r1 - --- | We cannot provide DerivingVia style derivation for 'GenSym', while you can --- use this 'fresh' implementation to implement 'GenSym' for your own types. --- --- This 'fresh' implementation is for the types that does not need any specification. --- It will generate product types by generating each fields with @()@ as specification, --- and generate all possible values for a sum type. --- --- __Note:__ __Never__ use on recursive types. -derivedNoSpecFresh :: - forall a m. - ( Generic a, - GenSymNoSpec (Rep a), - Mergeable a, - MonadFresh m - ) => - () -> - m (UnionM a) -derivedNoSpecFresh _ = merge . fmap to <$> freshNoSpec - -class GenSymSimpleNoSpec a where - simpleFreshNoSpec :: (MonadFresh m) => m (a c) - -instance GenSymSimpleNoSpec U1 where - simpleFreshNoSpec = return U1 - -instance (GenSymSimple () c) => GenSymSimpleNoSpec (K1 i c) where - simpleFreshNoSpec = K1 <$> simpleFresh () - -instance (GenSymSimpleNoSpec a) => GenSymSimpleNoSpec (M1 i c a) where - simpleFreshNoSpec = M1 <$> simpleFreshNoSpec - -instance - (GenSymSimpleNoSpec a, GenSymSimpleNoSpec b) => - GenSymSimpleNoSpec (a :*: b) - where - simpleFreshNoSpec = do - l :: a c <- simpleFreshNoSpec - r :: b c <- simpleFreshNoSpec - return $ l :*: r - --- | We cannot provide DerivingVia style derivation for 'GenSymSimple', while --- you can use this 'simpleFresh' implementation to implement 'GenSymSimple' fo --- your own types. --- --- This 'simpleFresh' implementation is for the types that does not need any specification. --- It will generate product types by generating each fields with '()' as specification. --- It will not work on sum types. --- --- __Note:__ __Never__ use on recursive types. -derivedNoSpecSimpleFresh :: - forall a m. - ( Generic a, - GenSymSimpleNoSpec (Rep a), - MonadFresh m - ) => - () -> - m a -derivedNoSpecSimpleFresh _ = to <$> simpleFreshNoSpec - -class GenSymSameShape a where - genSymSameShapeFresh :: - ( MonadFresh m - ) => - a c -> - m (a c) - -instance GenSymSameShape U1 where - genSymSameShapeFresh _ = return U1 - -instance (GenSymSimple c c) => GenSymSameShape (K1 i c) where - genSymSameShapeFresh (K1 c) = K1 <$> simpleFresh c - -instance (GenSymSameShape a) => GenSymSameShape (M1 i c a) where - genSymSameShapeFresh (M1 a) = M1 <$> genSymSameShapeFresh a - -instance - (GenSymSameShape a, GenSymSameShape b) => - GenSymSameShape (a :+: b) - where - genSymSameShapeFresh (L1 a) = L1 <$> genSymSameShapeFresh a - genSymSameShapeFresh (R1 a) = R1 <$> genSymSameShapeFresh a - -instance - (GenSymSameShape a, GenSymSameShape b) => - GenSymSameShape (a :*: b) - where - genSymSameShapeFresh (a :*: b) = do - l :: a c <- genSymSameShapeFresh a - r :: b c <- genSymSameShapeFresh b - return $ l :*: r - --- | We cannot provide DerivingVia style derivation for 'GenSymSimple', while --- you can use this 'simpleFresh' implementation to implement 'GenSymSimple' fo --- your own types. --- --- This 'simpleFresh' implementation is for the types that can be generated with --- a reference value of the same type. --- --- For sum types, it will generate the result with the same data constructor. --- For product types, it will generate the result by generating each field with --- the corresponding reference value. --- --- __Note:__ __Can__ be used on recursive types. -derivedSameShapeSimpleFresh :: - forall a m. - ( Generic a, - GenSymSameShape (Rep a), - MonadFresh m - ) => - a -> - m a -derivedSameShapeSimpleFresh a = to <$> genSymSameShapeFresh (from a) - --- | Symbolically chooses one of the provided values. --- The procedure creates @n - 1@ fresh symbolic boolean variables every time it --- is evaluated, and use these variables to conditionally select one of the @n@ --- provided expressions. --- --- The result will be wrapped in a union-like monad, and also a monad --- maintaining the 'MonadFresh' context. --- --- >>> runFresh (chooseFresh [1,2,3]) "a" :: UnionM Integer --- {If a@0 1 (If a@1 2 3)} -chooseFresh :: - forall a m. - ( Mergeable a, - MonadFresh m - ) => - [a] -> - m (UnionM a) -chooseFresh [x] = return $ mrgSingle x -chooseFresh (r : rs) = do - b <- simpleFresh () - res <- chooseFresh rs - return $ mrgIf b (mrgSingle r) res -chooseFresh [] = error "chooseFresh expects at least one value" - --- | A wrapper for `chooseFresh` that executes the `MonadFresh` context. --- A globally unique identifier should be supplied to ensure the uniqueness of --- symbolic constants in the generated symbolic values. -choose :: - forall a. - ( Mergeable a - ) => - [a] -> - FreshIdent -> - UnionM a -choose = runFresh . chooseFresh - --- | Symbolically chooses one of the provided values. --- The procedure creates @n - 1@ fresh symbolic boolean variables every time it is evaluated, and use --- these variables to conditionally select one of the @n@ provided expressions. --- --- The result will __/not/__ be wrapped in a union-like monad, but will be --- wrapped in a monad maintaining the 'Fresh' context. --- --- >>> import Data.Proxy --- >>> runFresh (chooseSimpleFresh [ssym "b", ssym "c", ssym "d"]) "a" :: SymInteger --- (ite a@0 b (ite a@1 c d)) -chooseSimpleFresh :: - forall a m. - ( SimpleMergeable a, - MonadFresh m - ) => - [a] -> - m a -chooseSimpleFresh [x] = return x -chooseSimpleFresh (r : rs) = do - b :: bool <- simpleFresh () - res <- chooseSimpleFresh rs - return $ mrgIte b r res -chooseSimpleFresh [] = error "chooseSimpleFresh expects at least one value" - --- | A wrapper for `chooseSimpleFresh` that executes the `MonadFresh` context. --- A globally unique identifier should be supplied to ensure the uniqueness of --- symbolic constants in the generated symbolic values. -chooseSimple :: - forall a. - ( SimpleMergeable a - ) => - [a] -> - FreshIdent -> - a -chooseSimple = runFresh . chooseSimpleFresh - --- | Symbolically chooses one of the provided values wrapped in union-like --- monads. The procedure creates @n - 1@ fresh symbolic boolean variables every --- time it is evaluated, and use these variables to conditionally select one of --- the @n@ provided expressions. --- --- The result will be wrapped in a union-like monad, and also a monad --- maintaining the 'Fresh' context. --- --- >>> let a = runFresh (chooseFresh [1, 2]) "a" :: UnionM Integer --- >>> let b = runFresh (chooseFresh [2, 3]) "b" :: UnionM Integer --- >>> runFresh (chooseUnionFresh [a, b]) "c" :: UnionM Integer --- {If (&& c@0 a@0) 1 (If (|| c@0 b@0) 2 3)} -chooseUnionFresh :: - forall a m. - ( Mergeable a, - MonadFresh m - ) => - [UnionM a] -> - m (UnionM a) -chooseUnionFresh [x] = return x -chooseUnionFresh (r : rs) = do - b <- simpleFresh () - res <- chooseUnionFresh rs - return $ mrgIf b r res -chooseUnionFresh [] = error "chooseUnionFresh expects at least one value" - --- | A wrapper for `chooseUnionFresh` that executes the `MonadFresh` context. --- A globally unique identifier should be supplied to ensure the uniqueness of --- symbolic constants in the generated symbolic values. -chooseUnion :: - forall a. - ( Mergeable a - ) => - [UnionM a] -> - FreshIdent -> - UnionM a -chooseUnion = runFresh . chooseUnionFresh - -#define CONCRETE_GENSYM_SAME_SHAPE(type) \ -instance GenSym type type where fresh = return . mrgSingle - -#define CONCRETE_GENSYMSIMPLE_SAME_SHAPE(type) \ -instance GenSymSimple type type where simpleFresh = return - -#define CONCRETE_GENSYM_SAME_SHAPE_BV(type) \ -instance (KnownNat n, 1 <= n) => GenSym (type n) (type n) where fresh = return . mrgSingle - -#define CONCRETE_GENSYMSIMPLE_SAME_SHAPE_BV(type) \ -instance (KnownNat n, 1 <= n) => GenSymSimple (type n) (type n) where simpleFresh = return - -#if 1 -CONCRETE_GENSYM_SAME_SHAPE(Bool) -CONCRETE_GENSYM_SAME_SHAPE(Integer) -CONCRETE_GENSYM_SAME_SHAPE(Char) -CONCRETE_GENSYM_SAME_SHAPE(Int) -CONCRETE_GENSYM_SAME_SHAPE(Int8) -CONCRETE_GENSYM_SAME_SHAPE(Int16) -CONCRETE_GENSYM_SAME_SHAPE(Int32) -CONCRETE_GENSYM_SAME_SHAPE(Int64) -CONCRETE_GENSYM_SAME_SHAPE(Word) -CONCRETE_GENSYM_SAME_SHAPE(Word8) -CONCRETE_GENSYM_SAME_SHAPE(Word16) -CONCRETE_GENSYM_SAME_SHAPE(Word32) -CONCRETE_GENSYM_SAME_SHAPE(Word64) -CONCRETE_GENSYM_SAME_SHAPE(SomeWordN) -CONCRETE_GENSYM_SAME_SHAPE(SomeIntN) -CONCRETE_GENSYM_SAME_SHAPE(B.ByteString) -CONCRETE_GENSYM_SAME_SHAPE(T.Text) -CONCRETE_GENSYM_SAME_SHAPE_BV(WordN) -CONCRETE_GENSYM_SAME_SHAPE_BV(IntN) - -CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Bool) -CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Integer) -CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Char) -CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Int) -CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Int8) -CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Int16) -CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Int32) -CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Int64) -CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Word) -CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Word8) -CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Word16) -CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Word32) -CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Word64) -CONCRETE_GENSYMSIMPLE_SAME_SHAPE(SomeWordN) -CONCRETE_GENSYMSIMPLE_SAME_SHAPE(SomeIntN) -CONCRETE_GENSYMSIMPLE_SAME_SHAPE(B.ByteString) -CONCRETE_GENSYMSIMPLE_SAME_SHAPE(T.Text) -CONCRETE_GENSYMSIMPLE_SAME_SHAPE_BV(WordN) -CONCRETE_GENSYMSIMPLE_SAME_SHAPE_BV(IntN) -#endif - --- Bool -instance GenSym () Bool where - fresh = derivedNoSpecFresh - --- Enums - --- | Specification for enum values with upper bound (exclusive). The result would chosen from [0 .. upperbound]. --- --- >>> runFresh (fresh (EnumGenUpperBound @Integer 4)) "c" :: UnionM Integer --- {If c@0 0 (If c@1 1 (If c@2 2 3))} -newtype EnumGenUpperBound a = EnumGenUpperBound a - -instance (Enum v, Mergeable v) => GenSym (EnumGenUpperBound v) v where - fresh (EnumGenUpperBound u) = chooseFresh (toEnum <$> [0 .. fromEnum u - 1]) - --- | Specification for numbers with lower bound (inclusive) and upper bound (exclusive) --- --- >>> runFresh (fresh (EnumGenBound @Integer 0 4)) "c" :: UnionM Integer --- {If c@0 0 (If c@1 1 (If c@2 2 3))} -data EnumGenBound a = EnumGenBound a a - -instance (Enum v, Mergeable v) => GenSym (EnumGenBound v) v where - fresh (EnumGenBound l u) = chooseFresh (toEnum <$> [fromEnum l .. fromEnum u - 1]) - --- Either -instance - ( GenSym aspec a, - Mergeable a, - GenSym bspec b, - Mergeable b - ) => - GenSym (Either aspec bspec) (Either a b) - where - fresh (Left aspec) = (merge . fmap Left) <$> fresh aspec - fresh (Right bspec) = (merge . fmap Right) <$> fresh bspec - -instance - ( GenSymSimple aspec a, - GenSymSimple bspec b - ) => - GenSymSimple (Either aspec bspec) (Either a b) - where - simpleFresh (Left a) = Left <$> simpleFresh a - simpleFresh (Right b) = Right <$> simpleFresh b - -instance - (GenSym () a, Mergeable a, GenSym () b, Mergeable b) => - GenSym () (Either a b) - where - fresh = derivedNoSpecFresh - -instance - ( GenSym aspec a, - Mergeable a, - GenSym bspec b, - Mergeable b - ) => - GenSym (aspec, bspec) (Either a b) - where - fresh (aspec, bspec) = do - l :: UnionM a <- fresh aspec - r :: UnionM b <- fresh bspec - chooseUnionFresh [Left <$> l, Right <$> r] - --- Maybe -instance - {-# OVERLAPPING #-} - (GenSym aspec a, Mergeable a) => - GenSym (Maybe aspec) (Maybe a) - where - fresh Nothing = return $ mrgSingle Nothing - fresh (Just aspec) = (merge . fmap Just) <$> fresh aspec - -instance - (GenSymSimple aspec a) => - GenSymSimple (Maybe aspec) (Maybe a) - where - simpleFresh Nothing = return Nothing - simpleFresh (Just aspec) = Just <$> simpleFresh aspec - -instance - {-# OVERLAPPABLE #-} - (GenSym aspec a, Mergeable a) => - GenSym aspec (Maybe a) - where - fresh aspec = do - cond <- simpleFresh () - a :: UnionM a <- fresh aspec - return $ mrgIf cond (mrgSingle Nothing) (Just <$> a) - --- List -instance - (GenSym () a, Mergeable a) => - GenSym Integer [a] - where - fresh v = do - l <- gl v - let xs = reverse $ scanr (:) [] l - chooseUnionFresh $ merge . sequence <$> xs - where - gl :: (MonadFresh m) => Integer -> m [UnionM a] - gl v1 - | v1 <= 0 = return [] - | otherwise = do - l <- fresh () - r <- gl (v1 - 1) - return $ l : r - --- | Specification for list generation. --- --- >>> runFresh (fresh (ListSpec 0 2 ())) "c" :: UnionM [SymBool] --- {If c@2 [] (If c@3 [c@1] [c@0,c@1])} --- --- >>> runFresh (fresh (ListSpec 0 2 (SimpleListSpec 1 ()))) "c" :: UnionM [[SymBool]] --- {If c@2 [] (If c@3 [[c@1]] [[c@0],[c@1]])} -data ListSpec spec = ListSpec - { -- | The minimum length of the generated lists - genListMinLength :: Int, - -- | The maximum length of the generated lists - genListMaxLength :: Int, - -- | Each element in the lists will be generated with the sub-specification - genListSubSpec :: spec - } - deriving (Show) - -instance - (GenSym spec a, Mergeable a) => - GenSym (ListSpec spec) [a] - where - fresh (ListSpec minLen maxLen subSpec) = - if minLen < 0 || maxLen < 0 || minLen >= maxLen - then error $ "Bad lengths: " ++ show (minLen, maxLen) - else do - l <- gl maxLen - let xs = drop minLen $ reverse $ scanr (:) [] l - chooseUnionFresh $ merge . sequence <$> xs - where - gl :: (MonadFresh m) => Int -> m [UnionM a] - gl currLen - | currLen <= 0 = return [] - | otherwise = do - l <- fresh subSpec - r <- gl (currLen - 1) - return $ l : r - -instance - (GenSym a a, Mergeable a) => - GenSym [a] [a] - where - fresh l = do - r :: [UnionM a] <- traverse fresh l - return $ merge $ sequence r - -instance - (GenSymSimple a a) => - GenSymSimple [a] [a] - where - simpleFresh = derivedSameShapeSimpleFresh - --- | Specification for list generation of a specific length. --- --- >>> runFresh (simpleFresh (SimpleListSpec 2 ())) "c" :: [SymBool] --- [c@0,c@1] -data SimpleListSpec spec = SimpleListSpec - { -- | The length of the generated list - genSimpleListLength :: Int, - -- | Each element in the list will be generated with the sub-specification - genSimpleListSubSpec :: spec - } - deriving (Show) - -instance - (GenSym spec a, Mergeable a) => - GenSym (SimpleListSpec spec) [a] - where - fresh (SimpleListSpec len subSpec) = - if len < 0 - then error $ "Bad lengths: " ++ show len - else do - merge . sequence <$> gl len - where - gl :: (MonadFresh m) => Int -> m [UnionM a] - gl currLen - | currLen <= 0 = return [] - | otherwise = do - l <- fresh subSpec - r <- gl (currLen - 1) - return $ l : r - -instance - (GenSymSimple spec a) => - GenSymSimple (SimpleListSpec spec) [a] - where - simpleFresh (SimpleListSpec len subSpec) = - if len < 0 - then error $ "Bad lengths: " ++ show len - else do - gl len - where - gl :: (MonadFresh m) => Int -> m [a] - gl currLen - | currLen <= 0 = return [] - | otherwise = do - l <- simpleFresh subSpec - r <- gl (currLen - 1) - return $ l : r - --- () -instance GenSym () () - -instance GenSymSimple () () where - simpleFresh = derivedNoSpecSimpleFresh - --- (,) -instance - ( GenSym aspec a, - Mergeable a, - GenSym bspec b, - Mergeable b - ) => - GenSym (aspec, bspec) (a, b) - where - fresh (aspec, bspec) = do - a1 <- fresh aspec - b1 <- fresh bspec - return $ do - ax <- a1 - bx <- b1 - mrgSingle (ax, bx) - -instance - ( GenSymSimple aspec a, - GenSymSimple bspec b - ) => - GenSymSimple (aspec, bspec) (a, b) - where - simpleFresh (aspec, bspec) = do - (,) - <$> simpleFresh aspec - <*> simpleFresh bspec - -instance - (GenSym () a, Mergeable a, GenSym () b, Mergeable b) => - GenSym () (a, b) - where - fresh = derivedNoSpecFresh - -instance - ( GenSymSimple () a, - GenSymSimple () b - ) => - GenSymSimple () (a, b) - where - simpleFresh = derivedNoSpecSimpleFresh - --- (,,) -instance - ( GenSym aspec a, - Mergeable a, - GenSym bspec b, - Mergeable b, - GenSym cspec c, - Mergeable c - ) => - GenSym (aspec, bspec, cspec) (a, b, c) - where - fresh (aspec, bspec, cspec) = do - a1 <- fresh aspec - b1 <- fresh bspec - c1 <- fresh cspec - return $ do - ax <- a1 - bx <- b1 - cx <- c1 - mrgSingle (ax, bx, cx) - -instance - ( GenSymSimple aspec a, - GenSymSimple bspec b, - GenSymSimple cspec c - ) => - GenSymSimple (aspec, bspec, cspec) (a, b, c) - where - simpleFresh (aspec, bspec, cspec) = do - (,,) - <$> simpleFresh aspec - <*> simpleFresh bspec - <*> simpleFresh cspec - -instance - ( GenSym () a, - Mergeable a, - GenSym () b, - Mergeable b, - GenSym () c, - Mergeable c - ) => - GenSym () (a, b, c) - where - fresh = derivedNoSpecFresh - -instance - ( GenSymSimple () a, - GenSymSimple () b, - GenSymSimple () c - ) => - GenSymSimple () (a, b, c) - where - simpleFresh = derivedNoSpecSimpleFresh - --- (,,,) -instance - ( GenSym aspec a, - Mergeable a, - GenSym bspec b, - Mergeable b, - GenSym cspec c, - Mergeable c, - GenSym dspec d, - Mergeable d - ) => - GenSym (aspec, bspec, cspec, dspec) (a, b, c, d) - where - fresh (aspec, bspec, cspec, dspec) = do - a1 <- fresh aspec - b1 <- fresh bspec - c1 <- fresh cspec - d1 <- fresh dspec - return $ do - ax <- a1 - bx <- b1 - cx <- c1 - dx <- d1 - mrgSingle (ax, bx, cx, dx) - -instance - ( GenSymSimple aspec a, - GenSymSimple bspec b, - GenSymSimple cspec c, - GenSymSimple dspec d - ) => - GenSymSimple (aspec, bspec, cspec, dspec) (a, b, c, d) - where - simpleFresh (aspec, bspec, cspec, dspec) = do - (,,,) - <$> simpleFresh aspec - <*> simpleFresh bspec - <*> simpleFresh cspec - <*> simpleFresh dspec - -instance - ( GenSym () a, - Mergeable a, - GenSym () b, - Mergeable b, - GenSym () c, - Mergeable c, - GenSym () d, - Mergeable d - ) => - GenSym () (a, b, c, d) - where - fresh = derivedNoSpecFresh - -instance - ( GenSymSimple () a, - GenSymSimple () b, - GenSymSimple () c, - GenSymSimple () d - ) => - GenSymSimple () (a, b, c, d) - where - simpleFresh = derivedNoSpecSimpleFresh - --- (,,,,) -instance - ( GenSym aspec a, - Mergeable a, - GenSym bspec b, - Mergeable b, - GenSym cspec c, - Mergeable c, - GenSym dspec d, - Mergeable d, - GenSym espec e, - Mergeable e - ) => - GenSym (aspec, bspec, cspec, dspec, espec) (a, b, c, d, e) - where - fresh (aspec, bspec, cspec, dspec, espec) = do - a1 <- fresh aspec - b1 <- fresh bspec - c1 <- fresh cspec - d1 <- fresh dspec - e1 <- fresh espec - return $ do - ax <- a1 - bx <- b1 - cx <- c1 - dx <- d1 - ex <- e1 - mrgSingle (ax, bx, cx, dx, ex) - -instance - ( GenSymSimple aspec a, - GenSymSimple bspec b, - GenSymSimple cspec c, - GenSymSimple dspec d, - GenSymSimple espec e - ) => - GenSymSimple (aspec, bspec, cspec, dspec, espec) (a, b, c, d, e) - where - simpleFresh (aspec, bspec, cspec, dspec, espec) = do - (,,,,) - <$> simpleFresh aspec - <*> simpleFresh bspec - <*> simpleFresh cspec - <*> simpleFresh dspec - <*> simpleFresh espec - -instance - ( GenSym () a, - Mergeable a, - GenSym () b, - Mergeable b, - GenSym () c, - Mergeable c, - GenSym () d, - Mergeable d, - GenSym () e, - Mergeable e - ) => - GenSym () (a, b, c, d, e) - where - fresh = derivedNoSpecFresh - -instance - ( GenSymSimple () a, - GenSymSimple () b, - GenSymSimple () c, - GenSymSimple () d, - GenSymSimple () e - ) => - GenSymSimple () (a, b, c, d, e) - where - simpleFresh = derivedNoSpecSimpleFresh - --- (,,,,,) -instance - ( GenSym aspec a, - Mergeable a, - GenSym bspec b, - Mergeable b, - GenSym cspec c, - Mergeable c, - GenSym dspec d, - Mergeable d, - GenSym espec e, - Mergeable e, - GenSym fspec f, - Mergeable f - ) => - GenSym (aspec, bspec, cspec, dspec, espec, fspec) (a, b, c, d, e, f) - where - fresh (aspec, bspec, cspec, dspec, espec, fspec) = do - a1 <- fresh aspec - b1 <- fresh bspec - c1 <- fresh cspec - d1 <- fresh dspec - e1 <- fresh espec - f1 <- fresh fspec - return $ do - ax <- a1 - bx <- b1 - cx <- c1 - dx <- d1 - ex <- e1 - fx <- f1 - mrgSingle (ax, bx, cx, dx, ex, fx) - -instance - ( GenSymSimple aspec a, - GenSymSimple bspec b, - GenSymSimple cspec c, - GenSymSimple dspec d, - GenSymSimple espec e, - GenSymSimple fspec f - ) => - GenSymSimple (aspec, bspec, cspec, dspec, espec, fspec) (a, b, c, d, e, f) - where - simpleFresh (aspec, bspec, cspec, dspec, espec, fspec) = do - (,,,,,) - <$> simpleFresh aspec - <*> simpleFresh bspec - <*> simpleFresh cspec - <*> simpleFresh dspec - <*> simpleFresh espec - <*> simpleFresh fspec - -instance - ( GenSym () a, - Mergeable a, - GenSym () b, - Mergeable b, - GenSym () c, - Mergeable c, - GenSym () d, - Mergeable d, - GenSym () e, - Mergeable e, - GenSym () f, - Mergeable f - ) => - GenSym () (a, b, c, d, e, f) - where - fresh = derivedNoSpecFresh - -instance - ( GenSymSimple () a, - GenSymSimple () b, - GenSymSimple () c, - GenSymSimple () d, - GenSymSimple () e, - GenSymSimple () f - ) => - GenSymSimple () (a, b, c, d, e, f) - where - simpleFresh = derivedNoSpecSimpleFresh - --- (,,,,,,) -instance - ( GenSym aspec a, - Mergeable a, - GenSym bspec b, - Mergeable b, - GenSym cspec c, - Mergeable c, - GenSym dspec d, - Mergeable d, - GenSym espec e, - Mergeable e, - GenSym fspec f, - Mergeable f, - GenSym gspec g, - Mergeable g - ) => - GenSym (aspec, bspec, cspec, dspec, espec, fspec, gspec) (a, b, c, d, e, f, g) - where - fresh (aspec, bspec, cspec, dspec, espec, fspec, gspec) = do - a1 <- fresh aspec - b1 <- fresh bspec - c1 <- fresh cspec - d1 <- fresh dspec - e1 <- fresh espec - f1 <- fresh fspec - g1 <- fresh gspec - return $ do - ax <- a1 - bx <- b1 - cx <- c1 - dx <- d1 - ex <- e1 - fx <- f1 - gx <- g1 - mrgSingle (ax, bx, cx, dx, ex, fx, gx) - -instance - ( GenSymSimple aspec a, - GenSymSimple bspec b, - GenSymSimple cspec c, - GenSymSimple dspec d, - GenSymSimple espec e, - GenSymSimple fspec f, - GenSymSimple gspec g - ) => - GenSymSimple (aspec, bspec, cspec, dspec, espec, fspec, gspec) (a, b, c, d, e, f, g) - where - simpleFresh (aspec, bspec, cspec, dspec, espec, fspec, gspec) = do - (,,,,,,) - <$> simpleFresh aspec - <*> simpleFresh bspec - <*> simpleFresh cspec - <*> simpleFresh dspec - <*> simpleFresh espec - <*> simpleFresh fspec - <*> simpleFresh gspec - -instance - ( GenSym () a, - Mergeable a, - GenSym () b, - Mergeable b, - GenSym () c, - Mergeable c, - GenSym () d, - Mergeable d, - GenSym () e, - Mergeable e, - GenSym () f, - Mergeable f, - GenSym () g, - Mergeable g - ) => - GenSym () (a, b, c, d, e, f, g) - where - fresh = derivedNoSpecFresh - -instance - ( GenSymSimple () a, - GenSymSimple () b, - GenSymSimple () c, - GenSymSimple () d, - GenSymSimple () e, - GenSymSimple () f, - GenSymSimple () g - ) => - GenSymSimple () (a, b, c, d, e, f, g) - where - simpleFresh = derivedNoSpecSimpleFresh - --- (,,,,,,,) -instance - ( GenSym aspec a, - Mergeable a, - GenSym bspec b, - Mergeable b, - GenSym cspec c, - Mergeable c, - GenSym dspec d, - Mergeable d, - GenSym espec e, - Mergeable e, - GenSym fspec f, - Mergeable f, - GenSym gspec g, - Mergeable g, - GenSym hspec h, - Mergeable h - ) => - GenSym (aspec, bspec, cspec, dspec, espec, fspec, gspec, hspec) (a, b, c, d, e, f, g, h) - where - fresh (aspec, bspec, cspec, dspec, espec, fspec, gspec, hspec) = do - a1 <- fresh aspec - b1 <- fresh bspec - c1 <- fresh cspec - d1 <- fresh dspec - e1 <- fresh espec - f1 <- fresh fspec - g1 <- fresh gspec - h1 <- fresh hspec - return $ do - ax <- a1 - bx <- b1 - cx <- c1 - dx <- d1 - ex <- e1 - fx <- f1 - gx <- g1 - hx <- h1 - mrgSingle (ax, bx, cx, dx, ex, fx, gx, hx) - -instance - ( GenSymSimple aspec a, - GenSymSimple bspec b, - GenSymSimple cspec c, - GenSymSimple dspec d, - GenSymSimple espec e, - GenSymSimple fspec f, - GenSymSimple gspec g, - GenSymSimple hspec h - ) => - GenSymSimple (aspec, bspec, cspec, dspec, espec, fspec, gspec, hspec) (a, b, c, d, e, f, g, h) - where - simpleFresh (aspec, bspec, cspec, dspec, espec, fspec, gspec, hspec) = do - (,,,,,,,) - <$> simpleFresh aspec - <*> simpleFresh bspec - <*> simpleFresh cspec - <*> simpleFresh dspec - <*> simpleFresh espec - <*> simpleFresh fspec - <*> simpleFresh gspec - <*> simpleFresh hspec - -instance - ( GenSym () a, - Mergeable a, - GenSym () b, - Mergeable b, - GenSym () c, - Mergeable c, - GenSym () d, - Mergeable d, - GenSym () e, - Mergeable e, - GenSym () f, - Mergeable f, - GenSym () g, - Mergeable g, - GenSym () h, - Mergeable h - ) => - GenSym () (a, b, c, d, e, f, g, h) - where - fresh = derivedNoSpecFresh - -instance - ( GenSymSimple () a, - GenSymSimple () b, - GenSymSimple () c, - GenSymSimple () d, - GenSymSimple () e, - GenSymSimple () f, - GenSymSimple () g, - GenSymSimple () h - ) => - GenSymSimple () (a, b, c, d, e, f, g, h) - where - simpleFresh = derivedNoSpecSimpleFresh - --- MaybeT -instance - {-# OVERLAPPABLE #-} - ( GenSym spec (m (Maybe a)), - Mergeable1 m, - Mergeable a - ) => - GenSym spec (MaybeT m a) - where - fresh v = do - x <- fresh v - return $ merge . fmap MaybeT $ x - -instance - {-# OVERLAPPABLE #-} - ( GenSymSimple spec (m (Maybe a)) - ) => - GenSymSimple spec (MaybeT m a) - where - simpleFresh v = MaybeT <$> simpleFresh v - -instance - {-# OVERLAPPING #-} - ( GenSymSimple (m (Maybe a)) (m (Maybe a)) - ) => - GenSymSimple (MaybeT m a) (MaybeT m a) - where - simpleFresh (MaybeT v) = MaybeT <$> simpleFresh v - -instance - {-# OVERLAPPING #-} - ( GenSymSimple (m (Maybe a)) (m (Maybe a)), - Mergeable1 m, - Mergeable a - ) => - GenSym (MaybeT m a) (MaybeT m a) - --- ExceptT -instance - {-# OVERLAPPABLE #-} - ( GenSym spec (m (Either a b)), - Mergeable1 m, - Mergeable a, - Mergeable b - ) => - GenSym spec (ExceptT a m b) - where - fresh v = do - x <- fresh v - return $ merge . fmap ExceptT $ x - -instance - {-# OVERLAPPABLE #-} - ( GenSymSimple spec (m (Either a b)) - ) => - GenSymSimple spec (ExceptT a m b) - where - simpleFresh v = ExceptT <$> simpleFresh v - -instance - {-# OVERLAPPING #-} - ( GenSymSimple (m (Either e a)) (m (Either e a)) - ) => - GenSymSimple (ExceptT e m a) (ExceptT e m a) - where - simpleFresh (ExceptT v) = ExceptT <$> simpleFresh v - -instance - {-# OVERLAPPING #-} - ( GenSymSimple (m (Either e a)) (m (Either e a)), - Mergeable1 m, - Mergeable e, - Mergeable a - ) => - GenSym (ExceptT e m a) (ExceptT e m a) - -#define GENSYM_SIMPLE(symtype) \ -instance GenSym symtype symtype -#define GENSYM_SIMPLE_SIMPLE(symtype) \ -instance GenSymSimple symtype symtype where \ - simpleFresh _ = simpleFresh () -#define GENSYM_UNIT_SIMPLE(symtype) \ -instance GenSym () symtype where \ - fresh _ = mrgSingle <$> simpleFresh () -#define GENSYM_UNIT_SIMPLE_SIMPLE(symtype) \ -instance GenSymSimple () symtype where \ - simpleFresh _ = do; \ - ident <- getFreshIdent; \ - FreshIndex i <- nextFreshIndex; \ - case ident of; \ - FreshIdent s -> return $ isym s i; \ - FreshIdentWithInfo s info -> return $ iinfosym s i info - -#define GENSYM_BV(symtype) \ -instance (KnownNat n, 1 <= n) => GenSym (symtype n) (symtype n) -#define GENSYM_SIMPLE_BV(symtype) \ -instance (KnownNat n, 1 <= n) => GenSymSimple (symtype n) (symtype n) where \ - simpleFresh _ = simpleFresh () -#define GENSYM_UNIT_BV(symtype) \ -instance (KnownNat n, 1 <= n) => GenSym () (symtype n) where \ - fresh _ = mrgSingle <$> simpleFresh () -#define GENSYM_UNIT_SIMPLE_BV(symtype) \ -instance (KnownNat n, 1 <= n) => GenSymSimple () (symtype n) where \ - simpleFresh _ = do; \ - ident <- getFreshIdent; \ - FreshIndex i <- nextFreshIndex; \ - case ident of; \ - FreshIdent s -> return $ isym s i; \ - FreshIdentWithInfo s info -> return $ iinfosym s i info - -#define GENSYM_BV_SOME(symtype) \ -instance GenSym symtype symtype -#define GENSYM_SIMPLE_BV_SOME(symtype) \ -instance GenSymSimple symtype symtype where \ - simpleFresh (symtype v) = simpleFresh v -#define GENSYM_N_BV_SOME(symtype) \ -instance (KnownNat n, 1 <= n) => GenSym (p n) symtype where \ - fresh p = mrgSingle <$> simpleFresh p -#define GENSYM_N_SIMPLE_BV_SOME(symtype, origtype) \ -instance (KnownNat n, 1 <= n) => GenSymSimple (p n) symtype where \ - simpleFresh _ = do; \ - i :: origtype n <- simpleFresh (); \ - return $ symtype i -#define GENSYM_N_INT_BV_SOME(symtype) \ -instance GenSym Int symtype where \ - fresh p = mrgSingle <$> simpleFresh p -#define GENSYM_N_INT_SIMPLE_BV_SOME(symtype, origtype) \ -instance GenSymSimple Int symtype where \ - simpleFresh i = if i > 0 then f (Proxy @0) else \ - error "Can only generate bit vectors with positive bit size" \ - where \ - f :: forall p (n :: Nat) m. (MonadFresh m) => p n -> m symtype; \ - f _ = case (unsafeKnownProof @n (fromIntegral i), unsafeLeqProof @1 @n) of \ - (KnownProof, LeqProof) -> do \ - v :: origtype n <- simpleFresh (); \ - return $ symtype v; \ - -#define GENSYM_FUN(op) \ -instance (SupportedPrim ca, SupportedPrim cb, LinkedRep ca sa, LinkedRep cb sb) => GenSym (sa op sb) (sa op sb) -#define GENSYM_SIMPLE_FUN(op) \ -instance (SupportedPrim ca, SupportedPrim cb, LinkedRep ca sa, LinkedRep cb sb) => GenSymSimple (sa op sb) (sa op sb) where \ - simpleFresh _ = simpleFresh () -#define GENSYM_UNIT_FUN(op) \ -instance (SupportedPrim ca, SupportedPrim cb, LinkedRep ca sa, LinkedRep cb sb) => GenSym () (sa op sb) where \ - fresh _ = mrgSingle <$> simpleFresh () -#define GENSYM_UNIT_SIMPLE_FUN(op) \ -instance (SupportedPrim ca, SupportedPrim cb, LinkedRep ca sa, LinkedRep cb sb) => GenSymSimple () (sa op sb) where \ - simpleFresh _ = do; \ - ident <- getFreshIdent; \ - FreshIndex i <- nextFreshIndex; \ - case ident of; \ - FreshIdent s -> return $ isym s i; \ - FreshIdentWithInfo s info -> return $ iinfosym s i info - -#if 1 -GENSYM_SIMPLE(SymBool) -GENSYM_SIMPLE_SIMPLE(SymBool) -GENSYM_UNIT_SIMPLE(SymBool) -GENSYM_UNIT_SIMPLE_SIMPLE(SymBool) -GENSYM_SIMPLE(SymInteger) -GENSYM_SIMPLE_SIMPLE(SymInteger) -GENSYM_UNIT_SIMPLE(SymInteger) -GENSYM_UNIT_SIMPLE_SIMPLE(SymInteger) - -GENSYM_BV(SymIntN) -GENSYM_SIMPLE_BV(SymIntN) -GENSYM_UNIT_BV(SymIntN) -GENSYM_UNIT_SIMPLE_BV(SymIntN) -GENSYM_BV(SymWordN) -GENSYM_SIMPLE_BV(SymWordN) -GENSYM_UNIT_BV(SymWordN) -GENSYM_UNIT_SIMPLE_BV(SymWordN) - -GENSYM_BV_SOME(SomeSymIntN) -GENSYM_SIMPLE_BV_SOME(SomeSymIntN) -GENSYM_N_BV_SOME(SomeSymIntN) -GENSYM_N_SIMPLE_BV_SOME(SomeSymIntN, SymIntN) -GENSYM_N_INT_BV_SOME(SomeSymIntN) -GENSYM_N_INT_SIMPLE_BV_SOME(SomeSymIntN, SymIntN) -GENSYM_BV_SOME(SomeSymWordN) -GENSYM_SIMPLE_BV_SOME(SomeSymWordN) -GENSYM_N_BV_SOME(SomeSymWordN) -GENSYM_N_SIMPLE_BV_SOME(SomeSymWordN, SymWordN) -GENSYM_N_INT_BV_SOME(SomeSymWordN) -GENSYM_N_INT_SIMPLE_BV_SOME(SomeSymWordN, SymWordN) - -GENSYM_FUN(=~>) -GENSYM_SIMPLE_FUN(=~>) -GENSYM_UNIT_FUN(=~>) -GENSYM_UNIT_SIMPLE_FUN(=~>) -GENSYM_FUN(-~>) -GENSYM_SIMPLE_FUN(-~>) -GENSYM_UNIT_FUN(-~>) -GENSYM_UNIT_SIMPLE_FUN(-~>) -#endif - -instance (GenSym spec a, Mergeable a) => GenSym spec (UnionM a) - -instance (GenSym spec a) => GenSymSimple spec (UnionM a) where - simpleFresh spec = do - res <- fresh spec - if not (isMerged res) then error "Not merged" else return res - -instance - (GenSym a a, Mergeable a) => - GenSym (UnionM a) a - where - fresh spec = go (underlyingUnion $ merge spec) - where - go (UnionSingle x) = fresh x - go (UnionIf _ _ _ t f) = mrgIf <$> simpleFresh () <*> go t <*> go f diff --git a/src/Grisette/Core/Data/Class/ITEOp.hs b/src/Grisette/Core/Data/Class/ITEOp.hs deleted file mode 100644 --- a/src/Grisette/Core/Data/Class/ITEOp.hs +++ /dev/null @@ -1,88 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- Module : Grisette.Core.Data.Class.ITEOp --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Core.Data.Class.ITEOp - ( ITEOp (..), - ) -where - -import GHC.TypeNats (KnownNat, type (<=)) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term - ( LinkedRep, - SupportedPrim, - ) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool (pevalITETerm) -import Grisette.IR.SymPrim.Data.SymPrim - ( SomeSymIntN, - SomeSymWordN, - SymBool (SymBool), - SymIntN (SymIntN), - SymInteger (SymInteger), - SymWordN (SymWordN), - binSomeSymIntNR1, - binSomeSymWordNR1, - type (-~>) (SymGeneralFun), - type (=~>) (SymTabularFun), - ) - --- $setup --- >>> import Grisette.Core --- >>> import Grisette.IR.SymPrim --- >>> :set -XDataKinds --- >>> :set -XBinaryLiterals --- >>> :set -XFlexibleContexts --- >>> :set -XFlexibleInstances --- >>> :set -XFunctionalDependencies - --- | ITE operator for solvable (see "Grisette.Core#solvable")s, including symbolic boolean, integer, etc. --- --- >>> let a = "a" :: SymBool --- >>> let b = "b" :: SymBool --- >>> let c = "c" :: SymBool --- >>> symIte a b c --- (ite a b c) -class ITEOp v where - symIte :: SymBool -> v -> v -> v - --- ITEOp instances -#define ITEOP_SIMPLE(type) \ -instance ITEOp type where \ - symIte (SymBool c) (type t) (type f) = type $ pevalITETerm c t f; \ - {-# INLINE symIte #-} - -#define ITEOP_BV(type) \ -instance (KnownNat n, 1 <= n) => ITEOp (type n) where \ - symIte (SymBool c) (type t) (type f) = type $ pevalITETerm c t f; \ - {-# INLINE symIte #-} - -#define ITEOP_BV_SOME(symtype, bf) \ -instance ITEOp symtype where \ - symIte c = bf (symIte c) "symIte"; \ - {-# INLINE symIte #-} - -#define ITEOP_FUN(op, cons) \ -instance (SupportedPrim ca, SupportedPrim cb, LinkedRep ca sa, LinkedRep cb sb) => ITEOp (sa op sb) where \ - symIte (SymBool c) (cons t) (cons f) = cons $ pevalITETerm c t f; \ - {-# INLINE symIte #-} - -#if 1 -ITEOP_SIMPLE(SymBool) -ITEOP_SIMPLE(SymInteger) -ITEOP_BV(SymIntN) -ITEOP_BV(SymWordN) -ITEOP_BV_SOME(SomeSymIntN, binSomeSymIntNR1) -ITEOP_BV_SOME(SomeSymWordN, binSomeSymWordNR1) -ITEOP_FUN(=~>, SymTabularFun) -ITEOP_FUN(-~>, SymGeneralFun) -#endif diff --git a/src/Grisette/Core/Data/Class/LogicalOp.hs b/src/Grisette/Core/Data/Class/LogicalOp.hs deleted file mode 100644 --- a/src/Grisette/Core/Data/Class/LogicalOp.hs +++ /dev/null @@ -1,106 +0,0 @@ -module Grisette.Core.Data.Class.LogicalOp - ( LogicalOp (..), - ) -where - -import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool - ( pevalAndTerm, - pevalImplyTerm, - pevalNotTerm, - pevalOrTerm, - pevalXorTerm, - ) -import Grisette.IR.SymPrim.Data.SymPrim (SymBool (SymBool)) - --- $setup --- >>> import Grisette.Core --- >>> import Grisette.IR.SymPrim --- >>> :set -XDataKinds --- >>> :set -XBinaryLiterals --- >>> :set -XFlexibleContexts --- >>> :set -XFlexibleInstances --- >>> :set -XFunctionalDependencies - --- | Symbolic logical operators for symbolic booleans. --- --- >>> let t = con True :: SymBool --- >>> let f = con False :: SymBool --- >>> let a = "a" :: SymBool --- >>> let b = "b" :: SymBool --- >>> t .|| f --- true --- >>> a .|| t --- true --- >>> a .|| f --- a --- >>> a .|| b --- (|| a b) --- >>> t .&& f --- false --- >>> a .&& t --- a --- >>> a .&& f --- false --- >>> a .&& b --- (&& a b) --- >>> symNot t --- false --- >>> symNot f --- true --- >>> symNot a --- (! a) --- >>> t `symXor` f --- true --- >>> t `symXor` t --- false --- >>> a `symXor` t --- (! a) --- >>> a `symXor` f --- a --- >>> a `symXor` b --- (|| (&& (! a) b) (&& a (! b))) -class LogicalOp b where - -- | Symbolic disjunction - (.||) :: b -> b -> b - a .|| b = symNot $ symNot a .&& symNot b - {-# INLINE (.||) #-} - - infixr 2 .|| - - -- | Symbolic conjunction - (.&&) :: b -> b -> b - a .&& b = symNot $ symNot a .|| symNot b - {-# INLINE (.&&) #-} - - infixr 3 .&& - - -- | Symbolic negation - symNot :: b -> b - - -- | Symbolic exclusive disjunction - symXor :: b -> b -> b - a `symXor` b = (a .&& symNot b) .|| (symNot a .&& b) - {-# INLINE symXor #-} - - -- | Symbolic implication - symImplies :: b -> b -> b - a `symImplies` b = symNot a .|| b - {-# INLINE symImplies #-} - - {-# MINIMAL (.||), symNot | (.&&), symNot #-} - --- LogicalOp instances -instance LogicalOp Bool where - (.||) = (||) - {-# INLINE (.||) #-} - (.&&) = (&&) - {-# INLINE (.&&) #-} - symNot = not - {-# INLINE symNot #-} - -instance LogicalOp SymBool where - (SymBool l) .|| (SymBool r) = SymBool $ pevalOrTerm l r - (SymBool l) .&& (SymBool r) = SymBool $ pevalAndTerm l r - symNot (SymBool v) = SymBool $ pevalNotTerm v - (SymBool l) `symXor` (SymBool r) = SymBool $ pevalXorTerm l r - (SymBool l) `symImplies` (SymBool r) = SymBool $ pevalImplyTerm l r diff --git a/src/Grisette/Core/Data/Class/Mergeable.hs b/src/Grisette/Core/Data/Class/Mergeable.hs deleted file mode 100644 --- a/src/Grisette/Core/Data/Class/Mergeable.hs +++ /dev/null @@ -1,1091 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- Module : Grisette.Core.Data.Class.Mergeable --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Core.Data.Class.Mergeable - ( -- * Merging strategy - MergingStrategy (..), - - -- * Mergeable - Mergeable (..), - Mergeable1 (..), - rootStrategy1, - Mergeable2 (..), - rootStrategy2, - Mergeable3 (..), - rootStrategy3, - Mergeable' (..), - derivedRootStrategy, - - -- * Combinators for manually building merging strategies - wrapStrategy, - product2Strategy, - DynamicSortedIdx (..), - StrategyList (..), - buildStrategyList, - resolveStrategy, - resolveStrategy', - ) -where - -import Control.Exception - ( ArithException - ( Denormal, - DivideByZero, - LossOfPrecision, - Overflow, - RatioZeroDenominator, - Underflow - ), - ) -import Control.Monad.Cont (ContT (ContT)) -import Control.Monad.Except (ExceptT (ExceptT), runExceptT) -import Control.Monad.Identity - ( Identity (Identity, runIdentity), - IdentityT (IdentityT, runIdentityT), - ) -import qualified Control.Monad.RWS.Lazy as RWSLazy -import qualified Control.Monad.RWS.Strict as RWSStrict -import Control.Monad.Reader (ReaderT (ReaderT, runReaderT)) -import qualified Control.Monad.State.Lazy as StateLazy -import qualified Control.Monad.State.Strict as StateStrict -import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) -import qualified Control.Monad.Writer.Lazy as WriterLazy -import qualified Control.Monad.Writer.Strict as WriterStrict -import qualified Data.ByteString as B -import Data.Functor.Classes - ( Eq1, - Ord1, - Show1, - compare1, - eq1, - showsPrec1, - ) -import Data.Functor.Sum (Sum (InL, InR)) -import Data.Int (Int16, Int32, Int64, Int8) -import Data.Kind (Type) -import qualified Data.Monoid as Monoid -import qualified Data.Text as T -import Data.Typeable - ( Proxy (Proxy), - Typeable, - eqT, - type (:~:) (Refl), - ) -import Data.Word (Word16, Word32, Word64, Word8) -import GHC.Natural (Natural) -import GHC.TypeNats (KnownNat, natVal, type (<=)) -import Generics.Deriving - ( Default (Default), - Default1 (Default1), - Generic (Rep, from, to), - Generic1 (Rep1, from1, to1), - K1 (K1, unK1), - M1 (M1, unM1), - Par1 (Par1, unPar1), - Rec1 (Rec1, unRec1), - U1, - V1, - type (:*:) ((:*:)), - type (:+:) (L1, R1), - ) -import Grisette.Core.Control.Exception (AssertionError, VerificationConditions) -import Grisette.Core.Data.BV - ( BitwidthMismatch, - IntN (IntN), - SomeIntN (SomeIntN), - SomeWordN (SomeWordN), - WordN (WordN), - ) -import Grisette.Core.Data.Class.ITEOp (ITEOp (symIte)) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term - ( LinkedRep, - SupportedPrim, - ) -import Grisette.IR.SymPrim.Data.SymPrim - ( SomeSymIntN (SomeSymIntN), - SomeSymWordN (SomeSymWordN), - SymBool, - SymIntN, - SymInteger, - SymWordN, - type (-~>), - type (=~>), - ) -import Grisette.Utils.Parameterized (unsafeAxiom) -import Unsafe.Coerce (unsafeCoerce) - --- | Helper type for combining arbitrary number of indices into one. --- Useful when trying to write efficient merge strategy for lists/vectors. -data DynamicSortedIdx where - DynamicSortedIdx :: forall idx. (Show idx, Ord idx, Typeable idx) => idx -> DynamicSortedIdx - -instance Eq DynamicSortedIdx where - (DynamicSortedIdx (a :: a)) == (DynamicSortedIdx (b :: b)) = case eqT @a @b of - Just Refl -> a == b - _ -> False - {-# INLINE (==) #-} - -instance Ord DynamicSortedIdx where - compare (DynamicSortedIdx (a :: a)) (DynamicSortedIdx (b :: b)) = case eqT @a @b of - Just Refl -> compare a b - _ -> error "This Ord is incomplete" - {-# INLINE compare #-} - -instance Show DynamicSortedIdx where - show (DynamicSortedIdx a) = show a - --- | Resolves the indices and the terminal merge strategy for a value of some 'Mergeable' type. -resolveStrategy :: forall x. MergingStrategy x -> x -> ([DynamicSortedIdx], MergingStrategy x) -resolveStrategy s x = resolveStrategy' x s -{-# INLINE resolveStrategy #-} - --- | Resolves the indices and the terminal merge strategy for a value given a merge strategy for its type. -resolveStrategy' :: forall x. x -> MergingStrategy x -> ([DynamicSortedIdx], MergingStrategy x) -resolveStrategy' x = go - where - go :: MergingStrategy x -> ([DynamicSortedIdx], MergingStrategy x) - go (SortedStrategy idxFun subStrategy) = case go ss of - (idxs, r) -> (DynamicSortedIdx idx : idxs, r) - where - idx = idxFun x - ss = subStrategy idx - go s = ([], s) -{-# INLINE resolveStrategy' #-} - --- | Merging strategies. --- --- __You probably do not need to know the details of this type if you are only going__ --- __to use algebraic data types. You can get merging strategies for them with type__ --- __derivation.__ --- --- In Grisette, a merged union (if-then-else tree) follows the __/hierarchical/__ --- __/sorted representation invariant/__ with regards to some merging strategy. --- --- A merging strategy encodes how to merge a __/subset/__ of the values of a --- given type. We have three types of merging strategies: --- --- * Simple strategy --- * Sorted strategy --- * No strategy --- --- The 'SimpleStrategy' merges values with a simple merge function. --- For example, --- --- * the symbolic boolean values can be directly merged with 'symIte'. --- --- * the set @{1}@, which is a subset of the values of the type @Integer@, --- can be simply merged as the set contains only a single value. --- --- * all the 'Just' values of the type @Maybe SymBool@ can be simply merged --- by merging the wrapped symbolic boolean with 'symIte'. --- --- The 'SortedStrategy' merges values by first grouping the values with an --- indexing function, and the values with the same index will be organized as --- a sub-tree in the if-then-else structure of 'Grisette.Core.Data.UnionBase.UnionBase'. --- Each group (sub-tree) will be further merged with a sub-strategy for the --- index. --- The index type should be a totally ordered type (with the 'Ord' --- type class). Grisette will use the indexing function to partition the values --- into sub-trees, and organize them in a sorted way. The sub-trees will further --- be merged with the sub-strategies. For example, --- --- * all the integers can be merged with 'SortedStrategy' by indexing with --- the identity function and use the 'SimpleStrategy' shown before as the --- sub-strategies. --- --- * all the @Maybe SymBool@ values can be merged with 'SortedStrategy' by --- indexing with 'Data.Maybe.isJust', the 'Nothing' and 'Just' values can then --- then be merged with different simple strategies as sub-strategies. --- --- The 'NoStrategy' does not perform any merging. --- For example, we cannot merge values with function types that returns concrete --- lists. --- --- For ADTs, we can automatically derive the 'Mergeable' type class, which --- provides a merging strategy. --- --- If the derived version does not work for you, you should determine --- if your type can be directly merged with a merging function. If so, you can --- implement the merging strategy as a 'SimpleStrategy'. --- If the type cannot be directly merged with a merging function, but could be --- partitioned into subsets of values that can be simply merged with a function, --- you should implement the merging strategy as a 'SortedStrategy'. --- For easier building of the merging strategies, check out the combinators --- like `wrapStrategy`. --- --- For more details, please see the documents of the constructors, or refer to --- [Grisette's paper](https://lsrcz.github.io/files/POPL23.pdf). -data MergingStrategy a where - -- | Simple mergeable strategy. - -- - -- For symbolic booleans, we can implement its merge strategy as follows: - -- - -- > SimpleStrategy symIte :: MergingStrategy SymBool - SimpleStrategy :: - -- | Merge function. - (SymBool -> a -> a -> a) -> - MergingStrategy a - -- | Sorted mergeable strategy. - -- - -- For Integers, we can implement its merge strategy as follows: - -- - -- > SortedStrategy id (\_ -> SimpleStrategy $ \_ t _ -> t) - -- - -- For @Maybe SymBool@, we can implement its merge strategy as follows: - -- - -- > SortedStrategy - -- > (\case; Nothing -> False; Just _ -> True) - -- > (\idx -> - -- > if idx - -- > then SimpleStrategy $ \_ t _ -> t - -- > else SimpleStrategy $ \cond (Just l) (Just r) -> Just $ symIte cond l r) - SortedStrategy :: - (Ord idx, Typeable idx, Show idx) => - -- | Indexing function - (a -> idx) -> - -- | Sub-strategy function - (idx -> MergingStrategy a) -> - MergingStrategy a - -- | For preventing the merging intentionally. This could be - -- useful for keeping some value concrete and may help generate more efficient - -- formulas. - -- - -- See [Grisette's paper](https://lsrcz.github.io/files/POPL23.pdf) for - -- details. - NoStrategy :: MergingStrategy a - --- | Useful utility function for building merge strategies manually. --- --- For example, to build the merge strategy for the just branch of @Maybe a@, --- one could write --- --- > wrapStrategy Just fromMaybe rootStrategy :: MergingStrategy (Maybe a) -wrapStrategy :: - -- | The merge strategy to be wrapped - MergingStrategy a -> - -- | The wrap function - (a -> b) -> - -- | The unwrap function, which does not have to be defined for every value - (b -> a) -> - MergingStrategy b -wrapStrategy (SimpleStrategy m) wrap unwrap = - SimpleStrategy - ( \cond ifTrue ifFalse -> - wrap $ m cond (unwrap ifTrue) (unwrap ifFalse) - ) -wrapStrategy (SortedStrategy idxFun substrategy) wrap unwrap = - SortedStrategy - (idxFun . unwrap) - (\idx -> wrapStrategy (substrategy idx) wrap unwrap) -wrapStrategy NoStrategy _ _ = NoStrategy -{-# INLINE wrapStrategy #-} - --- | Each type is associated with a root merge strategy given by 'rootStrategy'. --- The root merge strategy should be able to merge every value of the type. --- Grisette will use the root merge strategy to merge the values of the type in --- a union. --- --- __Note 1:__ This type class can be derived for algebraic data types. --- You may need the @DerivingVia@ and @DerivingStrategies@ extensions. --- --- > data X = ... deriving Generic deriving Mergeable via (Default X) -class Mergeable a where - -- | The root merging strategy for the type. - rootStrategy :: MergingStrategy a - --- | Lifting of the 'Mergeable' class to unary type constructors. -class Mergeable1 (u :: Type -> Type) where - -- | Lift merge strategy through the type constructor. - liftRootStrategy :: MergingStrategy a -> MergingStrategy (u a) - --- | Lift the root merge strategy through the unary type constructor. -rootStrategy1 :: (Mergeable a, Mergeable1 u) => MergingStrategy (u a) -rootStrategy1 = liftRootStrategy rootStrategy -{-# INLINE rootStrategy1 #-} - --- | Lifting of the 'Mergeable' class to binary type constructors. -class Mergeable2 (u :: Type -> Type -> Type) where - -- | Lift merge strategy through the type constructor. - liftRootStrategy2 :: MergingStrategy a -> MergingStrategy b -> MergingStrategy (u a b) - --- | Lift the root merge strategy through the binary type constructor. -rootStrategy2 :: (Mergeable a, Mergeable b, Mergeable2 u) => MergingStrategy (u a b) -rootStrategy2 = liftRootStrategy2 rootStrategy rootStrategy -{-# INLINE rootStrategy2 #-} - --- | Lifting of the 'Mergeable' class to ternary type constructors. -class Mergeable3 (u :: Type -> Type -> Type -> Type) where - -- | Lift merge strategy through the type constructor. - liftRootStrategy3 :: MergingStrategy a -> MergingStrategy b -> MergingStrategy c -> MergingStrategy (u a b c) - --- | Lift the root merge strategy through the binary type constructor. -rootStrategy3 :: (Mergeable a, Mergeable b, Mergeable c, Mergeable3 u) => MergingStrategy (u a b c) -rootStrategy3 = liftRootStrategy3 rootStrategy rootStrategy rootStrategy -{-# INLINE rootStrategy3 #-} - --- | Useful utility function for building merge strategies for product types --- manually. --- --- For example, to build the merge strategy for the following product type, --- one could write --- --- > data X = X { x1 :: Int, x2 :: Bool } --- > product2Strategy X (\(X a b) -> (a, b)) rootStrategy rootStrategy --- > :: MergingStrategy X -product2Strategy :: - -- | The wrap function - (a -> b -> r) -> - -- | The unwrap function, which does not have to be defined for every value - (r -> (a, b)) -> - -- | The first merge strategy to be wrapped - MergingStrategy a -> - -- | The second merge strategy to be wrapped - MergingStrategy b -> - MergingStrategy r -product2Strategy wrap unwrap strategy1 strategy2 = - case (strategy1, strategy2) of - (NoStrategy, _) -> NoStrategy - (_, NoStrategy) -> NoStrategy - (SimpleStrategy m1, SimpleStrategy m2) -> - SimpleStrategy $ \cond t f -> case (unwrap t, unwrap f) of - ((hdt, tlt), (hdf, tlf)) -> - wrap (m1 cond hdt hdf) (m2 cond tlt tlf) - (s1@(SimpleStrategy _), SortedStrategy idxf subf) -> - SortedStrategy (idxf . snd . unwrap) (product2Strategy wrap unwrap s1 . subf) - (SortedStrategy idxf subf, s2) -> - SortedStrategy (idxf . fst . unwrap) (\idx -> product2Strategy wrap unwrap (subf idx) s2) -{-# INLINE product2Strategy #-} - -instance (Mergeable' a, Mergeable' b) => Mergeable' (a :*: b) where - rootStrategy' = product2Strategy (:*:) (\(a :*: b) -> (a, b)) rootStrategy' rootStrategy' - {-# INLINE rootStrategy' #-} - --- instances - -#define CONCRETE_ORD_MERGEABLE(type) \ -instance Mergeable type where \ - rootStrategy = \ - let sub = SimpleStrategy $ \_ t _ -> t \ - in SortedStrategy id $ const sub - -#define CONCRETE_ORD_MERGEABLE_BV(type) \ -instance (KnownNat n, 1 <= n) => Mergeable (type n) where \ - rootStrategy = \ - let sub = SimpleStrategy $ \_ t _ -> t \ - in SortedStrategy id $ const sub - -#if 1 -CONCRETE_ORD_MERGEABLE(Bool) -CONCRETE_ORD_MERGEABLE(Integer) -CONCRETE_ORD_MERGEABLE(Char) -CONCRETE_ORD_MERGEABLE(Int) -CONCRETE_ORD_MERGEABLE(Int8) -CONCRETE_ORD_MERGEABLE(Int16) -CONCRETE_ORD_MERGEABLE(Int32) -CONCRETE_ORD_MERGEABLE(Int64) -CONCRETE_ORD_MERGEABLE(Word) -CONCRETE_ORD_MERGEABLE(Word8) -CONCRETE_ORD_MERGEABLE(Word16) -CONCRETE_ORD_MERGEABLE(Word32) -CONCRETE_ORD_MERGEABLE(Word64) -CONCRETE_ORD_MERGEABLE(B.ByteString) -CONCRETE_ORD_MERGEABLE(T.Text) -CONCRETE_ORD_MERGEABLE_BV(WordN) -CONCRETE_ORD_MERGEABLE_BV(IntN) -#endif - -instance Mergeable SomeIntN where - rootStrategy = - SortedStrategy @Natural - (\(SomeIntN (_ :: IntN n)) -> natVal (Proxy @n)) - ( \_ -> - SortedStrategy @Integer - (\(SomeIntN (IntN i)) -> i) - (const $ SimpleStrategy $ \_ l _ -> l) - ) - -instance Mergeable SomeWordN where - rootStrategy = - SortedStrategy @Natural - (\(SomeWordN (_ :: WordN n)) -> natVal (Proxy @n)) - ( \_ -> - SortedStrategy @Integer - (\(SomeWordN (WordN i)) -> i) - (const $ SimpleStrategy $ \_ l _ -> l) - ) - --- () -deriving via (Default ()) instance Mergeable () - --- Either -deriving via (Default (Either e a)) instance (Mergeable e, Mergeable a) => Mergeable (Either e a) - -deriving via (Default1 (Either e)) instance (Mergeable e) => Mergeable1 (Either e) - -instance Mergeable2 Either where - liftRootStrategy2 m1 m2 = - SortedStrategy - ( \case - Left _ -> False - Right _ -> True - ) - ( \case - False -> wrapStrategy m1 Left (\case (Left v) -> v; _ -> undefined) - True -> wrapStrategy m2 Right (\case (Right v) -> v; _ -> undefined) - ) - {-# INLINE liftRootStrategy2 #-} - --- Maybe -deriving via (Default (Maybe a)) instance (Mergeable a) => Mergeable (Maybe a) - -deriving via (Default1 Maybe) instance Mergeable1 Maybe - --- | Helper type for building efficient merge strategy for list-like containers. -data StrategyList container where - StrategyList :: - forall a container. - container [DynamicSortedIdx] -> - container (MergingStrategy a) -> - StrategyList container - --- | Helper function for building efficient merge strategy for list-like containers. -buildStrategyList :: - forall a container. - (Functor container) => - MergingStrategy a -> - container a -> - StrategyList container -buildStrategyList s l = StrategyList idxs strategies - where - r = resolveStrategy s <$> l - idxs = fst <$> r - strategies = snd <$> r -{-# INLINE buildStrategyList #-} - -instance (Eq1 container) => Eq (StrategyList container) where - (StrategyList idxs1 _) == (StrategyList idxs2 _) = eq1 idxs1 idxs2 - {-# INLINE (==) #-} - -instance (Ord1 container) => Ord (StrategyList container) where - compare (StrategyList idxs1 _) (StrategyList idxs2 _) = compare1 idxs1 idxs2 - {-# INLINE compare #-} - -instance (Show1 container) => Show (StrategyList container) where - showsPrec i (StrategyList idxs1 _) = showsPrec1 i idxs1 - --- List -instance (Mergeable a) => Mergeable [a] where - rootStrategy = case rootStrategy :: MergingStrategy a of - SimpleStrategy m -> - SortedStrategy length $ \_ -> - SimpleStrategy $ \cond -> zipWith (m cond) - NoStrategy -> - SortedStrategy length $ const NoStrategy - _ -> SortedStrategy length $ \_ -> - SortedStrategy (buildStrategyList rootStrategy) $ \(StrategyList _ strategies) -> - let s :: [MergingStrategy a] = unsafeCoerce strategies - allSimple = all (\case SimpleStrategy _ -> True; _ -> False) s - in if allSimple - then SimpleStrategy $ \cond l r -> - (\case (SimpleStrategy f, l1, r1) -> f cond l1 r1; _ -> error "impossible") <$> zip3 s l r - else NoStrategy - {-# INLINE rootStrategy #-} - -instance Mergeable1 [] where - liftRootStrategy (ms :: MergingStrategy a) = case ms of - SimpleStrategy m -> - SortedStrategy length $ \_ -> - SimpleStrategy $ \cond -> zipWith (m cond) - NoStrategy -> - SortedStrategy length $ const NoStrategy - _ -> SortedStrategy length $ \_ -> - SortedStrategy (buildStrategyList ms) $ \(StrategyList _ strategies) -> - let s :: [MergingStrategy a] = unsafeCoerce strategies - allSimple = all (\case SimpleStrategy _ -> True; _ -> False) s - in if allSimple - then SimpleStrategy $ \cond l r -> - (\case (SimpleStrategy f, l1, r1) -> f cond l1 r1; _ -> error "impossible") <$> zip3 s l r - else NoStrategy - {-# INLINE liftRootStrategy #-} - --- (,) -deriving via (Default (a, b)) instance (Mergeable a, Mergeable b) => Mergeable (a, b) - -deriving via (Default1 ((,) a)) instance (Mergeable a) => Mergeable1 ((,) a) - -instance Mergeable2 (,) where - liftRootStrategy2 = product2Strategy (,) id - {-# INLINE liftRootStrategy2 #-} - --- (,,) -deriving via - (Default (a, b, c)) - instance - (Mergeable a, Mergeable b, Mergeable c) => Mergeable (a, b, c) - -deriving via - (Default1 ((,,) a b)) - instance - (Mergeable a, Mergeable b) => Mergeable1 ((,,) a b) - -instance (Mergeable a) => Mergeable2 ((,,) a) where - liftRootStrategy2 = liftRootStrategy3 rootStrategy - {-# INLINE liftRootStrategy2 #-} - -instance Mergeable3 (,,) where - liftRootStrategy3 m1 m2 m3 = - product2Strategy - (\a (b, c) -> (a, b, c)) - (\(a, b, c) -> (a, (b, c))) - m1 - (liftRootStrategy2 m2 m3) - {-# INLINE liftRootStrategy3 #-} - --- (,,,) -deriving via - (Default (a, b, c, d)) - instance - (Mergeable a, Mergeable b, Mergeable c, Mergeable d) => - Mergeable (a, b, c, d) - -deriving via - (Default1 ((,,,) a b c)) - instance - (Mergeable a, Mergeable b, Mergeable c) => - Mergeable1 ((,,,) a b c) - --- (,,,,) -deriving via - (Default (a, b, c, d, e)) - instance - (Mergeable a, Mergeable b, Mergeable c, Mergeable d, Mergeable e) => - Mergeable (a, b, c, d, e) - -deriving via - (Default1 ((,,,,) a b c d)) - instance - (Mergeable a, Mergeable b, Mergeable c, Mergeable d) => - Mergeable1 ((,,,,) a b c d) - --- (,,,,,) -deriving via - (Default (a, b, c, d, e, f)) - instance - ( Mergeable a, - Mergeable b, - Mergeable c, - Mergeable d, - Mergeable e, - Mergeable f - ) => - Mergeable (a, b, c, d, e, f) - -deriving via - (Default1 ((,,,,,) a b c d e)) - instance - (Mergeable a, Mergeable b, Mergeable c, Mergeable d, Mergeable e) => - Mergeable1 ((,,,,,) a b c d e) - --- (,,,,,,) -deriving via - (Default (a, b, c, d, e, f, g)) - instance - ( Mergeable a, - Mergeable b, - Mergeable c, - Mergeable d, - Mergeable e, - Mergeable f, - Mergeable g - ) => - Mergeable (a, b, c, d, e, f, g) - -deriving via - (Default1 ((,,,,,,) a b c d e f)) - instance - ( Mergeable a, - Mergeable b, - Mergeable c, - Mergeable d, - Mergeable e, - Mergeable f - ) => - Mergeable1 ((,,,,,,) a b c d e f) - --- (,,,,,,,) -deriving via - (Default (a, b, c, d, e, f, g, h)) - instance - ( Mergeable a, - Mergeable b, - Mergeable c, - Mergeable d, - Mergeable e, - Mergeable f, - Mergeable g, - Mergeable h - ) => - Mergeable (a, b, c, d, e, f, g, h) - -deriving via - (Default1 ((,,,,,,,) a b c d e f g)) - instance - ( Mergeable a, - Mergeable b, - Mergeable c, - Mergeable d, - Mergeable e, - Mergeable f, - Mergeable g - ) => - Mergeable1 ((,,,,,,,) a b c d e f g) - --- function -instance (Mergeable b) => Mergeable (a -> b) where - rootStrategy = case rootStrategy @b of - SimpleStrategy m -> SimpleStrategy $ \cond t f v -> m cond (t v) (f v) - _ -> NoStrategy - {-# INLINE rootStrategy #-} - -instance Mergeable1 ((->) a) where - liftRootStrategy ms = case ms of - SimpleStrategy m -> SimpleStrategy $ \cond t f v -> m cond (t v) (f v) - _ -> NoStrategy - {-# INLINE liftRootStrategy #-} - --- MaybeT -instance (Mergeable1 m, Mergeable a) => Mergeable (MaybeT m a) where - rootStrategy = wrapStrategy rootStrategy1 MaybeT runMaybeT - {-# INLINE rootStrategy #-} - -instance (Mergeable1 m) => Mergeable1 (MaybeT m) where - liftRootStrategy m = wrapStrategy (liftRootStrategy (liftRootStrategy m)) MaybeT runMaybeT - {-# INLINE liftRootStrategy #-} - --- ExceptT -instance - (Mergeable1 m, Mergeable e, Mergeable a) => - Mergeable (ExceptT e m a) - where - rootStrategy = wrapStrategy rootStrategy1 ExceptT runExceptT - {-# INLINE rootStrategy #-} - -instance (Mergeable1 m, Mergeable e) => Mergeable1 (ExceptT e m) where - liftRootStrategy m = wrapStrategy (liftRootStrategy (liftRootStrategy m)) ExceptT runExceptT - {-# INLINE liftRootStrategy #-} - --- state -instance - (Mergeable s, Mergeable a, Mergeable1 m) => - Mergeable (StateLazy.StateT s m a) - where - rootStrategy = wrapStrategy (liftRootStrategy rootStrategy1) StateLazy.StateT StateLazy.runStateT - {-# INLINE rootStrategy #-} - -instance (Mergeable s, Mergeable1 m) => Mergeable1 (StateLazy.StateT s m) where - liftRootStrategy m = - wrapStrategy - (liftRootStrategy (liftRootStrategy (liftRootStrategy2 m rootStrategy))) - StateLazy.StateT - StateLazy.runStateT - {-# INLINE liftRootStrategy #-} - -instance - (Mergeable s, Mergeable a, Mergeable1 m) => - Mergeable (StateStrict.StateT s m a) - where - rootStrategy = - wrapStrategy (liftRootStrategy rootStrategy1) StateStrict.StateT StateStrict.runStateT - {-# INLINE rootStrategy #-} - -instance (Mergeable s, Mergeable1 m) => Mergeable1 (StateStrict.StateT s m) where - liftRootStrategy m = - wrapStrategy - (liftRootStrategy (liftRootStrategy (liftRootStrategy2 m rootStrategy))) - StateStrict.StateT - StateStrict.runStateT - {-# INLINE liftRootStrategy #-} - --- writer -instance - (Mergeable s, Mergeable a, Mergeable1 m) => - Mergeable (WriterLazy.WriterT s m a) - where - rootStrategy = wrapStrategy (liftRootStrategy rootStrategy1) WriterLazy.WriterT WriterLazy.runWriterT - {-# INLINE rootStrategy #-} - -instance (Mergeable s, Mergeable1 m) => Mergeable1 (WriterLazy.WriterT s m) where - liftRootStrategy m = - wrapStrategy - (liftRootStrategy (liftRootStrategy2 m rootStrategy)) - WriterLazy.WriterT - WriterLazy.runWriterT - {-# INLINE liftRootStrategy #-} - -instance - (Mergeable s, Mergeable a, Mergeable1 m) => - Mergeable (WriterStrict.WriterT s m a) - where - rootStrategy = wrapStrategy (liftRootStrategy rootStrategy1) WriterStrict.WriterT WriterStrict.runWriterT - {-# INLINE rootStrategy #-} - -instance (Mergeable s, Mergeable1 m) => Mergeable1 (WriterStrict.WriterT s m) where - liftRootStrategy m = - wrapStrategy - (liftRootStrategy (liftRootStrategy2 m rootStrategy)) - WriterStrict.WriterT - WriterStrict.runWriterT - {-# INLINE liftRootStrategy #-} - --- reader -instance - (Mergeable a, Mergeable1 m) => - Mergeable (ReaderT s m a) - where - rootStrategy = wrapStrategy (liftRootStrategy rootStrategy1) ReaderT runReaderT - {-# INLINE rootStrategy #-} - -instance (Mergeable1 m) => Mergeable1 (ReaderT s m) where - liftRootStrategy m = - wrapStrategy - (liftRootStrategy (liftRootStrategy m)) - ReaderT - runReaderT - {-# INLINE liftRootStrategy #-} - --- Sum -instance - (Mergeable1 l, Mergeable1 r, Mergeable x) => - Mergeable (Sum l r x) - where - rootStrategy = - SortedStrategy - ( \case - InL _ -> False - InR _ -> True - ) - ( \case - False -> wrapStrategy rootStrategy1 InL (\case (InL v) -> v; _ -> error "impossible") - True -> wrapStrategy rootStrategy1 InR (\case (InR v) -> v; _ -> error "impossible") - ) - {-# INLINE rootStrategy #-} - -instance (Mergeable1 l, Mergeable1 r) => Mergeable1 (Sum l r) where - liftRootStrategy m = - SortedStrategy - ( \case - InL _ -> False - InR _ -> True - ) - ( \case - False -> wrapStrategy (liftRootStrategy m) InL (\case (InL v) -> v; _ -> error "impossible") - True -> wrapStrategy (liftRootStrategy m) InR (\case (InR v) -> v; _ -> error "impossible") - ) - {-# INLINE liftRootStrategy #-} - --- Ordering -deriving via - (Default Ordering) - instance - Mergeable Ordering - --- Generic -deriving via - (Default (U1 x)) - instance - Mergeable (U1 x) - -deriving via - (Default (V1 x)) - instance - Mergeable (V1 x) - -deriving via - (Default (K1 i c x)) - instance - (Mergeable c) => Mergeable (K1 i c x) - -deriving via - (Default (M1 i c a x)) - instance - (Mergeable (a x)) => Mergeable (M1 i c a x) - -deriving via - (Default ((a :+: b) x)) - instance - (Mergeable (a x), Mergeable (b x)) => Mergeable ((a :+: b) x) - -deriving via - (Default ((a :*: b) x)) - instance - (Mergeable (a x), Mergeable (b x)) => Mergeable ((a :*: b) x) - --- Identity -instance (Mergeable a) => Mergeable (Identity a) where - rootStrategy = wrapStrategy rootStrategy Identity runIdentity - {-# INLINE rootStrategy #-} - -instance Mergeable1 Identity where - liftRootStrategy m = wrapStrategy m Identity runIdentity - {-# INLINE liftRootStrategy #-} - --- IdentityT -instance (Mergeable1 m, Mergeable a) => Mergeable (IdentityT m a) where - rootStrategy = wrapStrategy rootStrategy1 IdentityT runIdentityT - {-# INLINE rootStrategy #-} - -instance (Mergeable1 m) => Mergeable1 (IdentityT m) where - liftRootStrategy m = wrapStrategy (liftRootStrategy m) IdentityT runIdentityT - {-# INLINE liftRootStrategy #-} - --- ContT -instance (Mergeable1 m, Mergeable r) => Mergeable (ContT r m a) where - rootStrategy = - wrapStrategy - (liftRootStrategy rootStrategy1) - ContT - (\(ContT v) -> v) - {-# INLINE rootStrategy #-} - -instance (Mergeable1 m, Mergeable r) => Mergeable1 (ContT r m) where - liftRootStrategy _ = - wrapStrategy - (liftRootStrategy rootStrategy1) - ContT - (\(ContT v) -> v) - {-# INLINE liftRootStrategy #-} - --- RWS -instance - (Mergeable s, Mergeable w, Mergeable a, Mergeable1 m) => - Mergeable (RWSLazy.RWST r w s m a) - where - rootStrategy = wrapStrategy (liftRootStrategy (liftRootStrategy rootStrategy1)) RWSLazy.RWST (\(RWSLazy.RWST m) -> m) - {-# INLINE rootStrategy #-} - -instance - (Mergeable s, Mergeable w, Mergeable1 m) => - Mergeable1 (RWSLazy.RWST r w s m) - where - liftRootStrategy m = - wrapStrategy - (liftRootStrategy (liftRootStrategy (liftRootStrategy (liftRootStrategy3 m rootStrategy rootStrategy)))) - RWSLazy.RWST - (\(RWSLazy.RWST rws) -> rws) - {-# INLINE liftRootStrategy #-} - -instance - (Mergeable s, Mergeable w, Mergeable a, Mergeable1 m) => - Mergeable (RWSStrict.RWST r w s m a) - where - rootStrategy = wrapStrategy (liftRootStrategy (liftRootStrategy rootStrategy1)) RWSStrict.RWST (\(RWSStrict.RWST m) -> m) - {-# INLINE rootStrategy #-} - -instance - (Mergeable s, Mergeable w, Mergeable1 m) => - Mergeable1 (RWSStrict.RWST r w s m) - where - liftRootStrategy m = - wrapStrategy - (liftRootStrategy (liftRootStrategy (liftRootStrategy (liftRootStrategy3 m rootStrategy rootStrategy)))) - RWSStrict.RWST - (\(RWSStrict.RWST rws) -> rws) - {-# INLINE liftRootStrategy #-} - --- Data.Monoid module -deriving via - (Default (Monoid.Sum a)) - instance - (Mergeable a) => Mergeable (Monoid.Sum a) - -deriving via (Default1 Monoid.Sum) instance Mergeable1 Monoid.Sum - -#define MERGEABLE_SIMPLE(symtype) \ -instance Mergeable symtype where \ - rootStrategy = SimpleStrategy symIte - -#define MERGEABLE_BV(symtype) \ -instance (KnownNat n, 1 <= n) => Mergeable (symtype n) where \ - rootStrategy = SimpleStrategy symIte - -#define MERGEABLE_FUN(op) \ -instance (SupportedPrim ca, SupportedPrim cb, LinkedRep ca sa, LinkedRep cb sb) => Mergeable (sa op sb) where \ - rootStrategy = SimpleStrategy symIte - -#if 1 -MERGEABLE_SIMPLE(SymBool) -MERGEABLE_SIMPLE(SymInteger) -MERGEABLE_BV(SymIntN) -MERGEABLE_BV(SymWordN) -MERGEABLE_FUN(=~>) -MERGEABLE_FUN(-~>) -#endif - -instance Mergeable SomeSymIntN where - rootStrategy = - SortedStrategy @Natural - (\(SomeSymIntN (_ :: SymIntN n)) -> natVal (Proxy @n)) - ( \_ -> - SimpleStrategy - ( \c (SomeSymIntN (l :: SymIntN l)) (SomeSymIntN (r :: SymIntN r)) -> - case unsafeAxiom @l @r of - Refl -> SomeSymIntN $ symIte c l r - ) - ) - -instance Mergeable SomeSymWordN where - rootStrategy = - SortedStrategy @Natural - (\(SomeSymWordN (_ :: SymWordN n)) -> natVal (Proxy @n)) - ( \_ -> - SimpleStrategy - ( \c (SomeSymWordN (l :: SymWordN l)) (SomeSymWordN (r :: SymWordN r)) -> - case unsafeAxiom @l @r of - Refl -> SomeSymWordN $ symIte c l r - ) - ) - --- Exceptions -instance Mergeable ArithException where - rootStrategy = - SortedStrategy - ( \case - Overflow -> 0 :: Int - Underflow -> 1 :: Int - LossOfPrecision -> 2 :: Int - DivideByZero -> 3 :: Int - Denormal -> 4 :: Int - RatioZeroDenominator -> 5 :: Int - ) - (const $ SimpleStrategy $ \_ l _ -> l) - -deriving via (Default BitwidthMismatch) instance (Mergeable BitwidthMismatch) - -deriving via (Default AssertionError) instance Mergeable AssertionError - -deriving via (Default VerificationConditions) instance Mergeable VerificationConditions - -instance (Generic a, Mergeable' (Rep a)) => Mergeable (Default a) where - rootStrategy = unsafeCoerce (derivedRootStrategy :: MergingStrategy a) - {-# NOINLINE rootStrategy #-} - --- | Generic derivation for the 'Mergeable' class. --- --- Usually you can derive the merging strategy with the @DerivingVia@ and --- @DerivingStrategies@ extension. --- --- > data X = ... deriving (Generic) deriving Mergeable via (Default X) -derivedRootStrategy :: (Generic a, Mergeable' (Rep a)) => MergingStrategy a -derivedRootStrategy = wrapStrategy rootStrategy' to from -{-# INLINE derivedRootStrategy #-} - -instance (Generic1 u, Mergeable1' (Rep1 u)) => Mergeable1 (Default1 u) where - liftRootStrategy = unsafeCoerce (derivedLiftMergingStrategy :: MergingStrategy a -> MergingStrategy (u a)) - {-# NOINLINE liftRootStrategy #-} - -class Mergeable1' (u :: Type -> Type) where - liftRootStrategy' :: MergingStrategy a -> MergingStrategy (u a) - -instance Mergeable1' U1 where - liftRootStrategy' _ = SimpleStrategy (\_ t _ -> t) - {-# INLINE liftRootStrategy' #-} - -instance Mergeable1' V1 where - liftRootStrategy' _ = SimpleStrategy (\_ t _ -> t) - {-# INLINE liftRootStrategy' #-} - -instance Mergeable1' Par1 where - liftRootStrategy' m = wrapStrategy m Par1 unPar1 - {-# INLINE liftRootStrategy' #-} - -instance (Mergeable1 f) => Mergeable1' (Rec1 f) where - liftRootStrategy' m = wrapStrategy (liftRootStrategy m) Rec1 unRec1 - {-# INLINE liftRootStrategy' #-} - -instance (Mergeable c) => Mergeable1' (K1 i c) where - liftRootStrategy' _ = wrapStrategy rootStrategy K1 unK1 - {-# INLINE liftRootStrategy' #-} - -instance (Mergeable1' a) => Mergeable1' (M1 i c a) where - liftRootStrategy' m = wrapStrategy (liftRootStrategy' m) M1 unM1 - {-# INLINE liftRootStrategy' #-} - -instance (Mergeable1' a, Mergeable1' b) => Mergeable1' (a :+: b) where - liftRootStrategy' m = - SortedStrategy - ( \case - L1 _ -> False - R1 _ -> True - ) - ( \idx -> - if not idx - then wrapStrategy (liftRootStrategy' m) L1 (\case (L1 v) -> v; _ -> error "impossible") - else wrapStrategy (liftRootStrategy' m) R1 (\case (R1 v) -> v; _ -> error "impossible") - ) - {-# INLINE liftRootStrategy' #-} - -instance (Mergeable1' a, Mergeable1' b) => Mergeable1' (a :*: b) where - liftRootStrategy' m = product2Strategy (:*:) (\(a :*: b) -> (a, b)) (liftRootStrategy' m) (liftRootStrategy' m) - {-# INLINE liftRootStrategy' #-} - --- | Generic derivation for the 'Mergeable' class. -derivedLiftMergingStrategy :: (Generic1 u, Mergeable1' (Rep1 u)) => MergingStrategy a -> MergingStrategy (u a) -derivedLiftMergingStrategy m = wrapStrategy (liftRootStrategy' m) to1 from1 -{-# INLINE derivedLiftMergingStrategy #-} - --- | Auxiliary class for the generic derivation for the 'Mergeable' class. -class Mergeable' f where - rootStrategy' :: MergingStrategy (f a) - -instance Mergeable' U1 where - rootStrategy' = SimpleStrategy (\_ t _ -> t) - {-# INLINE rootStrategy' #-} - -instance Mergeable' V1 where - rootStrategy' = SimpleStrategy (\_ t _ -> t) - {-# INLINE rootStrategy' #-} - -instance (Mergeable c) => Mergeable' (K1 i c) where - rootStrategy' = wrapStrategy rootStrategy K1 unK1 - {-# INLINE rootStrategy' #-} - -instance (Mergeable' a) => Mergeable' (M1 i c a) where - rootStrategy' = wrapStrategy rootStrategy' M1 unM1 - {-# INLINE rootStrategy' #-} - -instance (Mergeable' a, Mergeable' b) => Mergeable' (a :+: b) where - rootStrategy' = - SortedStrategy - ( \case - L1 _ -> False - R1 _ -> True - ) - ( \idx -> - if not idx - then wrapStrategy rootStrategy' L1 (\case (L1 v) -> v; _ -> undefined) - else wrapStrategy rootStrategy' R1 (\case (R1 v) -> v; _ -> undefined) - ) - {-# INLINE rootStrategy' #-} diff --git a/src/Grisette/Core/Data/Class/ModelOps.hs b/src/Grisette/Core/Data/Class/ModelOps.hs deleted file mode 100644 --- a/src/Grisette/Core/Data/Class/ModelOps.hs +++ /dev/null @@ -1,170 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeFamilies #-} - --- | --- Module : Grisette.Core.Data.Class.ModelOps --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Core.Data.Class.ModelOps - ( -- * Model and symbolic set operations - SymbolSetOps (..), - SymbolSetRep (..), - ModelOps (..), - ModelRep (..), - ) -where - -import Data.Kind (Type) - --- $setup --- >>> import Grisette.Core --- >>> import Grisette.IR.SymPrim - --- | The operations on symbolic constant sets --- --- Note that symbolic constants with different types are considered different. --- --- >>> let aBool = "a" :: TypedSymbol Bool --- >>> let bBool = "b" :: TypedSymbol Bool --- >>> let cBool = "c" :: TypedSymbol Bool --- >>> let aInteger = "a" :: TypedSymbol Integer --- >>> emptySet :: SymbolSet --- SymbolSet {} --- >>> containsSymbol aBool (buildSymbolSet aBool :: SymbolSet) --- True --- >>> containsSymbol bBool (buildSymbolSet aBool :: SymbolSet) --- False --- >>> insertSymbol aBool (buildSymbolSet aBool :: SymbolSet) --- SymbolSet {a :: Bool} --- >>> insertSymbol aInteger (buildSymbolSet aBool :: SymbolSet) --- SymbolSet {a :: Bool, a :: Integer} --- >>> let abSet = buildSymbolSet (aBool, bBool) :: SymbolSet --- >>> let acSet = buildSymbolSet (aBool, cBool) :: SymbolSet --- >>> intersectionSet abSet acSet --- SymbolSet {a :: Bool} --- >>> unionSet abSet acSet --- SymbolSet {a :: Bool, b :: Bool, c :: Bool} --- >>> differenceSet abSet acSet --- SymbolSet {b :: Bool} -class - (Monoid symbolSet) => - SymbolSetOps symbolSet (typedSymbol :: Type -> Type) - | symbolSet -> typedSymbol - where - -- | Construct an empty set - emptySet :: symbolSet - - -- | Check if the set is empty - isEmptySet :: symbolSet -> Bool - - -- | Check if the set contains the given symbol - containsSymbol :: forall a. typedSymbol a -> symbolSet -> Bool - - -- | Insert a symbol into the set - insertSymbol :: forall a. typedSymbol a -> symbolSet -> symbolSet - - -- | Set intersection - intersectionSet :: symbolSet -> symbolSet -> symbolSet - - -- | Set union - unionSet :: symbolSet -> symbolSet -> symbolSet - - -- | Set difference - differenceSet :: symbolSet -> symbolSet -> symbolSet - --- | A type class for building a symbolic constant set manually from a symbolic --- constant set representation --- --- >>> buildSymbolSet ("a" :: TypedSymbol Bool, "b" :: TypedSymbol Bool) :: SymbolSet --- SymbolSet {a :: Bool, b :: Bool} -class - (SymbolSetOps symbolSet typedSymbol) => - SymbolSetRep rep symbolSet (typedSymbol :: Type -> Type) - where - -- | Build a symbolic constant set - buildSymbolSet :: rep -> symbolSet - --- | The operations on Models. --- --- Note that symbolic constants with different types are considered different. --- --- >>> let aBool = "a" :: TypedSymbol Bool --- >>> let bBool = "b" :: TypedSymbol Bool --- >>> let cBool = "c" :: TypedSymbol Bool --- >>> let aInteger = "a" :: TypedSymbol Integer --- >>> emptyModel :: Model --- Model {} --- >>> valueOf aBool (buildModel (aBool ::= True) :: Model) --- Just True --- >>> valueOf bBool (buildModel (aBool ::= True) :: Model) --- Nothing --- >>> insertValue bBool False (buildModel (aBool ::= True) :: Model) --- Model {a -> True :: Bool, b -> False :: Bool} --- >>> let abModel = buildModel (aBool ::= True, bBool ::= False) :: Model --- >>> let acSet = buildSymbolSet (aBool, cBool) :: SymbolSet --- >>> exceptFor acSet abModel --- Model {b -> False :: Bool} --- >>> restrictTo acSet abModel --- Model {a -> True :: Bool} --- >>> extendTo acSet abModel --- Model {a -> True :: Bool, b -> False :: Bool, c -> False :: Bool} --- >>> exact acSet abModel --- Model {a -> True :: Bool, c -> False :: Bool} -class - (SymbolSetOps symbolSet typedSymbol) => - ModelOps model symbolSet typedSymbol - | model -> symbolSet typedSymbol - where - -- | Construct an empty model - emptyModel :: model - - -- | Check if the model is empty - isEmptyModel :: model -> Bool - - -- | Check if the model contains the given symbol - modelContains :: typedSymbol a -> model -> Bool - - -- | Extract the assigned value for a given symbolic constant - valueOf :: typedSymbol t -> model -> Maybe t - - -- | Insert an assignment into the model - insertValue :: typedSymbol t -> t -> model -> model - - -- | Returns a model that removed all the assignments for the symbolic - -- constants in the set - exceptFor :: symbolSet -> model -> model - - -- | Returns a model that removed the assignments for the symbolic constants - exceptFor' :: typedSymbol t -> model -> model - - -- | Returns a model that only keeps the assignments for the symbolic - -- constants in the set - restrictTo :: symbolSet -> model -> model - - -- | Returns a model that extends the assignments for the symbolic constants - -- in the set by assigning default values to them - extendTo :: symbolSet -> model -> model - - -- | Returns a model that contains the assignments for exactly the symbolic - -- constants in the set by removing assignments for the symbolic constants that - -- are not in the set and add assignments for the missing symbolic constants - -- by assigning default values to them. - exact :: symbolSet -> model -> model - exact s = restrictTo s . extendTo s - --- | A type class for building a model manually from a model representation -class ModelRep rep model | rep -> model where - -- | Build a model - -- - -- >>> let aBool = "a" :: TypedSymbol Bool - -- >>> let bBool = "b" :: TypedSymbol Bool - -- >>> buildModel (aBool ::= True, bBool ::= False) :: Model - -- Model {a -> True :: Bool, b -> False :: Bool} - buildModel :: rep -> model diff --git a/src/Grisette/Core/Data/Class/SEq.hs b/src/Grisette/Core/Data/Class/SEq.hs deleted file mode 100644 --- a/src/Grisette/Core/Data/Class/SEq.hs +++ /dev/null @@ -1,306 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- Module : Grisette.Core.Data.Class.Bool --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Core.Data.Class.SEq - ( -- * Symbolic equality - SEq (..), - SEq' (..), - ) -where - -import Control.Monad.Except (ExceptT (ExceptT)) -import Control.Monad.Identity - ( Identity (Identity), - IdentityT (IdentityT), - ) -import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) -import qualified Control.Monad.Writer.Lazy as WriterLazy -import qualified Control.Monad.Writer.Strict as WriterStrict -import qualified Data.ByteString as B -import Data.Functor.Sum (Sum) -import Data.Int (Int16, Int32, Int64, Int8) -import qualified Data.Text as T -import Data.Typeable (Proxy (Proxy), type (:~:) (Refl)) -import Data.Word (Word16, Word32, Word64, Word8) -import GHC.TypeLits (sameNat) -import GHC.TypeNats (KnownNat, type (<=)) -import Generics.Deriving - ( Default (Default), - Generic (Rep, from), - K1 (K1), - M1 (M1), - U1, - V1, - type (:*:) ((:*:)), - type (:+:) (L1, R1), - ) -import Grisette.Core.Control.Exception (AssertionError, VerificationConditions) -import Grisette.Core.Data.BV (IntN, SomeIntN, SomeWordN, WordN) -import Grisette.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.&&))) -import Grisette.Core.Data.Class.Solvable (Solvable (con)) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool (pevalEqvTerm) -import Grisette.IR.SymPrim.Data.SymPrim - ( SomeSymIntN (SomeSymIntN), - SomeSymWordN (SomeSymWordN), - SymBool (SymBool), - SymIntN (SymIntN), - SymInteger (SymInteger), - SymWordN (SymWordN), - ) - --- $setup --- >>> import Grisette.Core --- >>> import Grisette.IR.SymPrim --- >>> :set -XDataKinds --- >>> :set -XBinaryLiterals --- >>> :set -XFlexibleContexts --- >>> :set -XFlexibleInstances --- >>> :set -XFunctionalDependencies - --- | Symbolic equality. Note that we can't use Haskell's 'Eq' class since --- symbolic comparison won't necessarily return a concrete 'Bool' value. --- --- >>> let a = 1 :: SymInteger --- >>> let b = 2 :: SymInteger --- >>> a .== b --- false --- >>> a ./= b --- true --- --- >>> let a = "a" :: SymInteger --- >>> let b = "b" :: SymInteger --- >>> a ./= b --- (! (= a b)) --- >>> a ./= b --- (! (= a b)) --- --- __Note:__ This type class can be derived for algebraic data types. --- You may need the @DerivingVia@ and @DerivingStrategies@ extensions. --- --- > data X = ... deriving Generic deriving SEq via (Default X) -class SEq a where - (.==) :: a -> a -> SymBool - a .== b = symNot $ a ./= b - {-# INLINE (.==) #-} - infix 4 .== - - (./=) :: a -> a -> SymBool - a ./= b = symNot $ a .== b - {-# INLINE (./=) #-} - infix 4 ./= - {-# MINIMAL (.==) | (./=) #-} - --- SEq instances -#define CONCRETE_SEQ(type) \ -instance SEq type where \ - l .== r = con $ l == r; \ - {-# INLINE (.==) #-} - -#define CONCRETE_SEQ_BV(type) \ -instance (KnownNat n, 1 <= n) => SEq (type n) where \ - l .== r = con $ l == r; \ - {-# INLINE (.==) #-} - -#if 1 -CONCRETE_SEQ(Bool) -CONCRETE_SEQ(Integer) -CONCRETE_SEQ(Char) -CONCRETE_SEQ(Int) -CONCRETE_SEQ(Int8) -CONCRETE_SEQ(Int16) -CONCRETE_SEQ(Int32) -CONCRETE_SEQ(Int64) -CONCRETE_SEQ(Word) -CONCRETE_SEQ(Word8) -CONCRETE_SEQ(Word16) -CONCRETE_SEQ(Word32) -CONCRETE_SEQ(Word64) -CONCRETE_SEQ(B.ByteString) -CONCRETE_SEQ(T.Text) -CONCRETE_SEQ_BV(WordN) -CONCRETE_SEQ_BV(IntN) -CONCRETE_SEQ(SomeWordN) -CONCRETE_SEQ(SomeIntN) -#endif - --- List -deriving via (Default [a]) instance (SEq a) => SEq [a] - --- Maybe -deriving via (Default (Maybe a)) instance (SEq a) => SEq (Maybe a) - --- Either -deriving via (Default (Either e a)) instance (SEq e, SEq a) => SEq (Either e a) - --- ExceptT -instance (SEq (m (Either e a))) => SEq (ExceptT e m a) where - (ExceptT a) .== (ExceptT b) = a .== b - {-# INLINE (.==) #-} - --- MaybeT -instance (SEq (m (Maybe a))) => SEq (MaybeT m a) where - (MaybeT a) .== (MaybeT b) = a .== b - {-# INLINE (.==) #-} - --- () -instance SEq () where - _ .== _ = con True - {-# INLINE (.==) #-} - --- (,) -deriving via (Default (a, b)) instance (SEq a, SEq b) => SEq (a, b) - --- (,,) -deriving via (Default (a, b, c)) instance (SEq a, SEq b, SEq c) => SEq (a, b, c) - --- (,,,) -deriving via - (Default (a, b, c, d)) - instance - (SEq a, SEq b, SEq c, SEq d) => - SEq (a, b, c, d) - --- (,,,,) -deriving via - (Default (a, b, c, d, e)) - instance - (SEq a, SEq b, SEq c, SEq d, SEq e) => - SEq (a, b, c, d, e) - --- (,,,,,) -deriving via - (Default (a, b, c, d, e, f)) - instance - (SEq a, SEq b, SEq c, SEq d, SEq e, SEq f) => - SEq (a, b, c, d, e, f) - --- (,,,,,,) -deriving via - (Default (a, b, c, d, e, f, g)) - instance - (SEq a, SEq b, SEq c, SEq d, SEq e, SEq f, SEq g) => - SEq (a, b, c, d, e, f, g) - --- (,,,,,,,) -deriving via - (Default (a, b, c, d, e, f, g, h)) - instance - (SEq a, SEq b, SEq c, SEq d, SEq e, SEq f, SEq g, SEq h) => - SEq (a, b, c, d, e, f, g, h) - --- Sum -deriving via - (Default (Sum f g a)) - instance - (SEq (f a), SEq (g a)) => SEq (Sum f g a) - --- Writer -instance (SEq (m (a, s))) => SEq (WriterLazy.WriterT s m a) where - (WriterLazy.WriterT l) .== (WriterLazy.WriterT r) = l .== r - {-# INLINE (.==) #-} - -instance (SEq (m (a, s))) => SEq (WriterStrict.WriterT s m a) where - (WriterStrict.WriterT l) .== (WriterStrict.WriterT r) = l .== r - {-# INLINE (.==) #-} - --- Identity -instance (SEq a) => SEq (Identity a) where - (Identity l) .== (Identity r) = l .== r - {-# INLINE (.==) #-} - --- IdentityT -instance (SEq (m a)) => SEq (IdentityT m a) where - (IdentityT l) .== (IdentityT r) = l .== r - {-# INLINE (.==) #-} - --- Symbolic types -#define SEQ_SIMPLE(symtype) \ -instance SEq symtype where \ - (symtype l) .== (symtype r) = SymBool $ pevalEqvTerm l r - -#define SEQ_BV(symtype) \ -instance (KnownNat n, 1 <= n) => SEq (symtype n) where \ - (symtype l) .== (symtype r) = SymBool $ pevalEqvTerm l r - -#define SEQ_BV_SOME(somety, origty) \ -instance SEq somety where \ - somety (l :: origty l) .== somety (r :: origty r) = \ - (case sameNat (Proxy @l) (Proxy @r) of \ - Just Refl -> l .== r; \ - Nothing -> con False); \ - {-# INLINE (.==) #-}; \ - somety (l :: origty l) ./= somety (r :: origty r) = \ - (case sameNat (Proxy @l) (Proxy @r) of \ - Just Refl -> l ./= r; \ - Nothing -> con True); \ - {-# INLINE (./=) #-} - -#if 1 -SEQ_SIMPLE(SymBool) -SEQ_SIMPLE(SymInteger) -SEQ_BV(SymIntN) -SEQ_BV(SymWordN) -SEQ_BV_SOME(SomeSymIntN, SymIntN) -SEQ_BV_SOME(SomeSymWordN, SymWordN) -#endif - --- Exceptions -deriving via (Default AssertionError) instance SEq AssertionError - -deriving via (Default VerificationConditions) instance SEq VerificationConditions - --- | Auxiliary class for 'SEq' instance derivation -class SEq' f where - -- | Auxiliary function for '(..==) derivation - (..==) :: f a -> f a -> SymBool - - infix 4 ..== - -instance SEq' U1 where - _ ..== _ = con True - {-# INLINE (..==) #-} - -instance SEq' V1 where - _ ..== _ = con True - {-# INLINE (..==) #-} - -instance (SEq c) => SEq' (K1 i c) where - (K1 a) ..== (K1 b) = a .== b - {-# INLINE (..==) #-} - -instance (SEq' a) => SEq' (M1 i c a) where - (M1 a) ..== (M1 b) = a ..== b - {-# INLINE (..==) #-} - -instance (SEq' a, SEq' b) => SEq' (a :+: b) where - (L1 a) ..== (L1 b) = a ..== b - (R1 a) ..== (R1 b) = a ..== b - _ ..== _ = con False - {-# INLINE (..==) #-} - -instance (SEq' a, SEq' b) => SEq' (a :*: b) where - (a1 :*: b1) ..== (a2 :*: b2) = (a1 ..== a2) .&& (b1 ..== b2) - {-# INLINE (..==) #-} - -instance (Generic a, SEq' (Rep a)) => SEq (Default a) where - Default l .== Default r = from l ..== from r - {-# INLINE (.==) #-} diff --git a/src/Grisette/Core/Data/Class/SOrd.hs b/src/Grisette/Core/Data/Class/SOrd.hs deleted file mode 100644 --- a/src/Grisette/Core/Data/Class/SOrd.hs +++ /dev/null @@ -1,504 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- Module : Grisette.Core.Data.Class.SOrd --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Core.Data.Class.SOrd - ( -- * Symbolic total order relation - SOrd (..), - SOrd' (..), - ) -where - -import Control.Monad.Except (ExceptT (ExceptT)) -import Control.Monad.Identity - ( Identity (Identity), - IdentityT (IdentityT), - ) -import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) -import qualified Control.Monad.Writer.Lazy as WriterLazy -import qualified Control.Monad.Writer.Strict as WriterStrict -import qualified Data.ByteString as B -import Data.Functor.Sum (Sum) -import Data.Int (Int16, Int32, Int64, Int8) -import qualified Data.Text as T -import Data.Word (Word16, Word32, Word64, Word8) -import GHC.TypeLits (KnownNat, type (<=)) -import Generics.Deriving - ( Default (Default), - Generic (Rep, from), - K1 (K1), - M1 (M1), - U1, - V1, - type (:*:) ((:*:)), - type (:+:) (L1, R1), - ) -import Grisette.Core.Control.Exception (AssertionError, VerificationConditions) -import Grisette.Core.Control.Monad.UnionM (UnionM, liftToMonadUnion) -import Grisette.Core.Data.BV (IntN, SomeIntN, SomeWordN, WordN) -import Grisette.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.&&), (.||))) -import Grisette.Core.Data.Class.SEq (SEq ((./=), (.==)), SEq' ((..==))) -import Grisette.Core.Data.Class.SimpleMergeable - ( mrgIf, - mrgSingle, - simpleMerge, - ) -import Grisette.Core.Data.Class.Solvable (Solvable (con)) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.Num - ( pevalGeNumTerm, - pevalGtNumTerm, - pevalLeNumTerm, - pevalLtNumTerm, - ) -import Grisette.IR.SymPrim.Data.SymPrim - ( SomeSymIntN, - SomeSymWordN, - SymBool (SymBool), - SymIntN (SymIntN), - SymInteger (SymInteger), - SymWordN (SymWordN), - binSomeSymIntN, - binSomeSymWordN, - ) - --- $setup --- >>> import Grisette.Core --- >>> import Grisette.IR.SymPrim --- >>> :set -XDataKinds --- >>> :set -XBinaryLiterals --- >>> :set -XFlexibleContexts --- >>> :set -XFlexibleInstances --- >>> :set -XFunctionalDependencies - --- | Symbolic total order. Note that we can't use Haskell's 'Ord' class since --- symbolic comparison won't necessarily return a concrete 'Bool' or 'Ordering' --- value. --- --- >>> let a = 1 :: SymInteger --- >>> let b = 2 :: SymInteger --- >>> a .< b --- true --- >>> a .> b --- false --- --- >>> let a = "a" :: SymInteger --- >>> let b = "b" :: SymInteger --- >>> a .< b --- (< a b) --- >>> a .<= b --- (<= a b) --- >>> a .> b --- (< b a) --- >>> a .>= b --- (<= b a) --- --- For `symCompare`, `Ordering` is not a solvable type, and the result would --- be wrapped in a union-like monad. See `Grisette.Core.Control.Monad.UnionMBase` and `UnionLike` for more --- information. --- --- >>> a `symCompare` b :: UnionM Ordering -- UnionM is UnionMBase specialized with SymBool --- {If (< a b) LT (If (= a b) EQ GT)} --- --- __Note:__ This type class can be derived for algebraic data types. --- You may need the @DerivingVia@ and @DerivingStrategies@ extensions. --- --- > data X = ... deriving Generic deriving SOrd via (Default X) -class (SEq a) => SOrd a where - (.<) :: a -> a -> SymBool - infix 4 .< - (.<=) :: a -> a -> SymBool - infix 4 .<= - (.>) :: a -> a -> SymBool - infix 4 .> - (.>=) :: a -> a -> SymBool - infix 4 .>= - x .< y = x .<= y .&& x ./= y - x .> y = y .< x - x .>= y = y .<= x - symCompare :: a -> a -> UnionM Ordering - symCompare l r = - mrgIf - (l .< r) - (mrgSingle LT) - (mrgIf (l .== r) (mrgSingle EQ) (mrgSingle GT)) - {-# MINIMAL (.<=) #-} - -instance (SEq a, Generic a, SOrd' (Rep a)) => SOrd (Default a) where - (Default l) .<= (Default r) = l `derivedSymLe` r - (Default l) .< (Default r) = l `derivedSymLt` r - (Default l) .>= (Default r) = l `derivedSymGe` r - (Default l) .> (Default r) = l `derivedSymGt` r - symCompare (Default l) (Default r) = derivedSymCompare l r - -#define CONCRETE_SORD(type) \ -instance SOrd type where \ - l .<= r = con $ l <= r; \ - l .< r = con $ l < r; \ - l .>= r = con $ l >= r; \ - l .> r = con $ l > r; \ - symCompare l r = mrgSingle $ compare l r - -#define CONCRETE_SORD_BV(type) \ -instance (KnownNat n, 1 <= n) => SOrd (type n) where \ - l .<= r = con $ l <= r; \ - l .< r = con $ l < r; \ - l .>= r = con $ l >= r; \ - l .> r = con $ l > r; \ - symCompare l r = mrgSingle $ compare l r - -#if 1 -CONCRETE_SORD(Bool) -CONCRETE_SORD(Integer) -CONCRETE_SORD(Char) -CONCRETE_SORD(Int) -CONCRETE_SORD(Int8) -CONCRETE_SORD(Int16) -CONCRETE_SORD(Int32) -CONCRETE_SORD(Int64) -CONCRETE_SORD(Word) -CONCRETE_SORD(Word8) -CONCRETE_SORD(Word16) -CONCRETE_SORD(Word32) -CONCRETE_SORD(Word64) -CONCRETE_SORD(SomeWordN) -CONCRETE_SORD(SomeIntN) -CONCRETE_SORD(B.ByteString) -CONCRETE_SORD(T.Text) -CONCRETE_SORD_BV(WordN) -CONCRETE_SORD_BV(IntN) -#endif - -symCompareSingleList :: (SOrd a) => Bool -> Bool -> [a] -> [a] -> SymBool -symCompareSingleList isLess isStrict = go - where - go [] [] = con (not isStrict) - go (x : xs) (y : ys) = (if isLess then x .< y else x .> y) .|| (x .== y .&& go xs ys) - go [] _ = if isLess then con True else con False - go _ [] = if isLess then con False else con True - -symCompareList :: (SOrd a) => [a] -> [a] -> UnionM Ordering -symCompareList [] [] = mrgSingle EQ -symCompareList (x : xs) (y : ys) = do - oxy <- symCompare x y - case oxy of - LT -> mrgSingle LT - EQ -> symCompareList xs ys - GT -> mrgSingle GT -symCompareList [] _ = mrgSingle LT -symCompareList _ [] = mrgSingle GT - -instance (SOrd a) => SOrd [a] where - (.<=) = symCompareSingleList True False - (.<) = symCompareSingleList True True - (.>=) = symCompareSingleList False False - (.>) = symCompareSingleList False True - symCompare = symCompareList - -deriving via (Default (Maybe a)) instance (SOrd a) => SOrd (Maybe a) - -deriving via (Default (Either a b)) instance (SOrd a, SOrd b) => SOrd (Either a b) - -deriving via (Default ()) instance SOrd () - -deriving via (Default (a, b)) instance (SOrd a, SOrd b) => SOrd (a, b) - -deriving via (Default (a, b, c)) instance (SOrd a, SOrd b, SOrd c) => SOrd (a, b, c) - -deriving via - (Default (a, b, c, d)) - instance - (SOrd a, SOrd b, SOrd c, SOrd d) => - SOrd (a, b, c, d) - -deriving via - (Default (a, b, c, d, e)) - instance - (SOrd a, SOrd b, SOrd c, SOrd d, SOrd e) => - SOrd (a, b, c, d, e) - -deriving via - (Default (a, b, c, d, e, f)) - instance - (SOrd a, SOrd b, SOrd c, SOrd d, SOrd e, SOrd f) => - SOrd (a, b, c, d, e, f) - -deriving via - (Default (a, b, c, d, e, f, g)) - instance - (SOrd a, SOrd b, SOrd c, SOrd d, SOrd e, SOrd f, SOrd g) => - SOrd (a, b, c, d, e, f, g) - -deriving via - (Default (a, b, c, d, e, f, g, h)) - instance - ( SOrd a, - SOrd b, - SOrd c, - SOrd d, - SOrd e, - SOrd f, - SOrd g, - SOrd h - ) => - SOrd (a, b, c, d, e, f, g, h) - -deriving via - (Default (Sum f g a)) - instance - (SOrd (f a), SOrd (g a)) => SOrd (Sum f g a) - -instance (SOrd (m (Maybe a))) => SOrd (MaybeT m a) where - (MaybeT l) .<= (MaybeT r) = l .<= r - (MaybeT l) .< (MaybeT r) = l .< r - (MaybeT l) .>= (MaybeT r) = l .>= r - (MaybeT l) .> (MaybeT r) = l .> r - symCompare (MaybeT l) (MaybeT r) = symCompare l r - -instance (SOrd (m (Either e a))) => SOrd (ExceptT e m a) where - (ExceptT l) .<= (ExceptT r) = l .<= r - (ExceptT l) .< (ExceptT r) = l .< r - (ExceptT l) .>= (ExceptT r) = l .>= r - (ExceptT l) .> (ExceptT r) = l .> r - symCompare (ExceptT l) (ExceptT r) = symCompare l r - -instance (SOrd (m (a, s))) => SOrd (WriterLazy.WriterT s m a) where - (WriterLazy.WriterT l) .<= (WriterLazy.WriterT r) = l .<= r - (WriterLazy.WriterT l) .< (WriterLazy.WriterT r) = l .< r - (WriterLazy.WriterT l) .>= (WriterLazy.WriterT r) = l .>= r - (WriterLazy.WriterT l) .> (WriterLazy.WriterT r) = l .> r - symCompare (WriterLazy.WriterT l) (WriterLazy.WriterT r) = symCompare l r - -instance (SOrd (m (a, s))) => SOrd (WriterStrict.WriterT s m a) where - (WriterStrict.WriterT l) .<= (WriterStrict.WriterT r) = l .<= r - (WriterStrict.WriterT l) .< (WriterStrict.WriterT r) = l .< r - (WriterStrict.WriterT l) .>= (WriterStrict.WriterT r) = l .>= r - (WriterStrict.WriterT l) .> (WriterStrict.WriterT r) = l .> r - symCompare (WriterStrict.WriterT l) (WriterStrict.WriterT r) = symCompare l r - -instance (SOrd a) => SOrd (Identity a) where - (Identity l) .<= (Identity r) = l .<= r - (Identity l) .< (Identity r) = l .< r - (Identity l) .>= (Identity r) = l .>= r - (Identity l) .> (Identity r) = l .> r - (Identity l) `symCompare` (Identity r) = l `symCompare` r - -instance (SOrd (m a)) => SOrd (IdentityT m a) where - (IdentityT l) .<= (IdentityT r) = l .<= r - (IdentityT l) .< (IdentityT r) = l .< r - (IdentityT l) .>= (IdentityT r) = l .>= r - (IdentityT l) .> (IdentityT r) = l .> r - (IdentityT l) `symCompare` (IdentityT r) = l `symCompare` r - --- SOrd -#define SORD_SIMPLE(symtype) \ -instance SOrd symtype where \ - (symtype a) .<= (symtype b) = SymBool $ pevalLeNumTerm a b; \ - (symtype a) .< (symtype b) = SymBool $ pevalLtNumTerm a b; \ - (symtype a) .>= (symtype b) = SymBool $ pevalGeNumTerm a b; \ - (symtype a) .> (symtype b) = SymBool $ pevalGtNumTerm a b; \ - a `symCompare` b = mrgIf \ - (a .< b) \ - (mrgSingle LT) \ - (mrgIf (a .== b) (mrgSingle EQ) (mrgSingle GT)) - -#define SORD_BV(symtype) \ -instance (KnownNat n, 1 <= n) => SOrd (symtype n) where \ - (symtype a) .<= (symtype b) = SymBool $ pevalLeNumTerm a b; \ - (symtype a) .< (symtype b) = SymBool $ pevalLtNumTerm a b; \ - (symtype a) .>= (symtype b) = SymBool $ pevalGeNumTerm a b; \ - (symtype a) .> (symtype b) = SymBool $ pevalGtNumTerm a b; \ - a `symCompare` b = mrgIf \ - (a .< b) \ - (mrgSingle LT) \ - (mrgIf (a .== b) (mrgSingle EQ) (mrgSingle GT)) - -#define SORD_BV_SOME(somety, bf) \ -instance SOrd somety where \ - (.<=) = bf (.<=) ".<="; \ - {-# INLINE (.<=) #-}; \ - (.<) = bf (.<) ".<"; \ - {-# INLINE (.<) #-}; \ - (.>=) = bf (.>=) ".>="; \ - {-# INLINE (.>=) #-}; \ - (.>) = bf (.>) ".>"; \ - {-# INLINE (.>) #-}; \ - symCompare = bf symCompare "symCompare"; \ - {-# INLINE symCompare #-} - -instance SOrd SymBool where - l .<= r = symNot l .|| r - l .< r = symNot l .&& r - l .>= r = l .|| symNot r - l .> r = l .&& symNot r - symCompare l r = - mrgIf - (symNot l .&& r) - (mrgSingle LT) - (mrgIf (l .== r) (mrgSingle EQ) (mrgSingle GT)) - -#if 1 -SORD_SIMPLE(SymInteger) -SORD_BV(SymIntN) -SORD_BV(SymWordN) -SORD_BV_SOME(SomeSymIntN, binSomeSymIntN) -SORD_BV_SOME(SomeSymWordN, binSomeSymWordN) -#endif - --- Exception -instance SOrd AssertionError where - _ .<= _ = con True - _ .< _ = con False - _ .>= _ = con True - _ .> _ = con False - _ `symCompare` _ = mrgSingle EQ - -instance SOrd VerificationConditions where - l .>= r = con $ l >= r - l .> r = con $ l > r - l .<= r = con $ l <= r - l .< r = con $ l < r - l `symCompare` r = mrgSingle $ l `compare` r - --- UnionM -instance (SOrd a) => SOrd (UnionM a) where - x .<= y = simpleMerge $ do - x1 <- x - y1 <- y - mrgSingle $ x1 .<= y1 - x .< y = simpleMerge $ do - x1 <- x - y1 <- y - mrgSingle $ x1 .< y1 - x .>= y = simpleMerge $ do - x1 <- x - y1 <- y - mrgSingle $ x1 .>= y1 - x .> y = simpleMerge $ do - x1 <- x - y1 <- y - mrgSingle $ x1 .> y1 - x `symCompare` y = liftToMonadUnion $ do - x1 <- x - y1 <- y - x1 `symCompare` y1 - --- | Auxiliary class for 'SOrd' instance derivation -class (SEq' f) => SOrd' f where - -- | Auxiliary function for '(..<) derivation - (..<) :: f a -> f a -> SymBool - - infix 4 ..< - - -- | Auxiliary function for '(..<=) derivation - (..<=) :: f a -> f a -> SymBool - - infix 4 ..<= - - -- | Auxiliary function for '(..>) derivation - (..>) :: f a -> f a -> SymBool - - infix 4 ..> - - -- | Auxiliary function for '(..>=) derivation - (..>=) :: f a -> f a -> SymBool - - infix 4 ..>= - - -- | Auxiliary function for 'symCompare' derivation - symCompare' :: f a -> f a -> UnionM Ordering - -instance SOrd' U1 where - _ ..< _ = con False - _ ..<= _ = con True - _ ..> _ = con False - _ ..>= _ = con True - symCompare' _ _ = mrgSingle EQ - -instance SOrd' V1 where - _ ..< _ = con False - _ ..<= _ = con True - _ ..> _ = con False - _ ..>= _ = con True - symCompare' _ _ = mrgSingle EQ - -instance (SOrd c) => SOrd' (K1 i c) where - (K1 a) ..< (K1 b) = a .< b - (K1 a) ..<= (K1 b) = a .<= b - (K1 a) ..> (K1 b) = a .> b - (K1 a) ..>= (K1 b) = a .>= b - symCompare' (K1 a) (K1 b) = symCompare a b - -instance (SOrd' a) => SOrd' (M1 i c a) where - (M1 a) ..< (M1 b) = a ..< b - (M1 a) ..<= (M1 b) = a ..<= b - (M1 a) ..> (M1 b) = a ..> b - (M1 a) ..>= (M1 b) = a ..>= b - symCompare' (M1 a) (M1 b) = symCompare' a b - -instance (SOrd' a, SOrd' b) => SOrd' (a :+: b) where - (L1 _) ..< (R1 _) = con True - (L1 a) ..< (L1 b) = a ..< b - (R1 _) ..< (L1 _) = con False - (R1 a) ..< (R1 b) = a ..< b - (L1 _) ..<= (R1 _) = con True - (L1 a) ..<= (L1 b) = a ..<= b - (R1 _) ..<= (L1 _) = con False - (R1 a) ..<= (R1 b) = a ..<= b - - (L1 _) ..> (R1 _) = con False - (L1 a) ..> (L1 b) = a ..> b - (R1 _) ..> (L1 _) = con True - (R1 a) ..> (R1 b) = a ..> b - (L1 _) ..>= (R1 _) = con False - (L1 a) ..>= (L1 b) = a ..>= b - (R1 _) ..>= (L1 _) = con True - (R1 a) ..>= (R1 b) = a ..>= b - - symCompare' (L1 a) (L1 b) = symCompare' a b - symCompare' (L1 _) (R1 _) = mrgSingle LT - symCompare' (R1 a) (R1 b) = symCompare' a b - symCompare' (R1 _) (L1 _) = mrgSingle GT - -instance (SOrd' a, SOrd' b) => SOrd' (a :*: b) where - (a1 :*: b1) ..< (a2 :*: b2) = (a1 ..< a2) .|| ((a1 ..== a2) .&& (b1 ..< b2)) - (a1 :*: b1) ..<= (a2 :*: b2) = (a1 ..< a2) .|| ((a1 ..== a2) .&& (b1 ..<= b2)) - (a1 :*: b1) ..> (a2 :*: b2) = (a1 ..> a2) .|| ((a1 ..== a2) .&& (b1 ..> b2)) - (a1 :*: b1) ..>= (a2 :*: b2) = (a1 ..> a2) .|| ((a1 ..== a2) .&& (b1 ..>= b2)) - symCompare' (a1 :*: b1) (a2 :*: b2) = do - l <- symCompare' a1 a2 - case l of - EQ -> symCompare' b1 b2 - _ -> mrgSingle l - -derivedSymLt :: (Generic a, SOrd' (Rep a)) => a -> a -> SymBool -derivedSymLt x y = from x ..< from y - -derivedSymLe :: (Generic a, SOrd' (Rep a)) => a -> a -> SymBool -derivedSymLe x y = from x ..<= from y - -derivedSymGt :: (Generic a, SOrd' (Rep a)) => a -> a -> SymBool -derivedSymGt x y = from x ..> from y - -derivedSymGe :: (Generic a, SOrd' (Rep a)) => a -> a -> SymBool -derivedSymGe x y = from x ..>= from y - -derivedSymCompare :: (Generic a, SOrd' (Rep a)) => a -> a -> UnionM Ordering -derivedSymCompare x y = symCompare' (from x) (from y) diff --git a/src/Grisette/Core/Data/Class/SafeDivision.hs b/src/Grisette/Core/Data/Class/SafeDivision.hs deleted file mode 100644 --- a/src/Grisette/Core/Data/Class/SafeDivision.hs +++ /dev/null @@ -1,379 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- Module : Grisette.Core.Data.Class.SafeDivision --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Core.Data.Class.SafeDivision - ( ArithException (..), - SafeDivision (..), - ) -where - -import Control.Exception (ArithException (DivideByZero, Overflow, Underflow)) -import Control.Monad.Except (MonadError (throwError)) -import Data.Int (Int16, Int32, Int64, Int8) -import Data.Typeable (Proxy (Proxy), type (:~:) (Refl)) -import Data.Word (Word16, Word32, Word64, Word8) -import GHC.TypeNats (KnownNat, sameNat, type (<=)) -import Grisette.Core.Control.Monad.Union (MonadUnion) -import Grisette.Core.Data.BV - ( BitwidthMismatch (BitwidthMismatch), - IntN, - SomeIntN (SomeIntN), - SomeWordN (SomeWordN), - WordN, - ) -import Grisette.Core.Data.Class.LogicalOp (LogicalOp ((.&&), (.||))) -import Grisette.Core.Data.Class.Mergeable (Mergeable) -import Grisette.Core.Data.Class.SEq (SEq ((.==))) -import Grisette.Core.Data.Class.SOrd - ( SOrd ((.<), (.<=), (.>), (.>=)), - ) -import Grisette.Core.Data.Class.SimpleMergeable - ( merge, - mrgIf, - mrgSingle, - ) -import Grisette.Core.Data.Class.Solvable (Solvable (con)) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.Integral - ( pevalDivBoundedIntegralTerm, - pevalDivIntegralTerm, - pevalModBoundedIntegralTerm, - pevalModIntegralTerm, - pevalQuotBoundedIntegralTerm, - pevalQuotIntegralTerm, - pevalRemBoundedIntegralTerm, - pevalRemIntegralTerm, - ) -import Grisette.IR.SymPrim.Data.SymPrim - ( SymIntN (SymIntN), - SymInteger (SymInteger), - SymWordN (SymWordN), - ) - --- $setup --- >>> import Grisette.Core --- >>> import Grisette.IR.SymPrim --- >>> import Control.Monad.Except - --- | Safe division with monadic error handling in multi-path --- execution. These procedures throw an exception when the --- divisor is zero. The result should be able to handle errors with --- `MonadError`. -class (SOrd a, Num a, Mergeable a, Mergeable e) => SafeDivision e a | a -> e where - -- | Safe signed 'div' with monadic error handling in multi-path execution. - -- - -- >>> safeDiv (ssym "a") (ssym "b") :: ExceptT ArithException UnionM SymInteger - -- ExceptT {If (= b 0) (Left divide by zero) (Right (div a b))} - safeDiv :: (MonadError e uf, MonadUnion uf) => a -> a -> uf a - safeDiv l r = do - (d, _) <- safeDivMod l r - mrgSingle d - - -- | Safe signed 'mod' with monadic error handling in multi-path execution. - -- - -- >>> safeMod (ssym "a") (ssym "b") :: ExceptT ArithException UnionM SymInteger - -- ExceptT {If (= b 0) (Left divide by zero) (Right (mod a b))} - safeMod :: (MonadError e uf, MonadUnion uf) => a -> a -> uf a - safeMod l r = do - (_, m) <- safeDivMod l r - mrgSingle m - - -- | Safe signed 'divMod' with monadic error handling in multi-path execution. - -- - -- >>> safeDivMod (ssym "a") (ssym "b") :: ExceptT ArithException UnionM (SymInteger, SymInteger) - -- ExceptT {If (= b 0) (Left divide by zero) (Right ((div a b),(mod a b)))} - safeDivMod :: (MonadError e uf, MonadUnion uf) => a -> a -> uf (a, a) - safeDivMod l r = do - d <- safeDiv l r - m <- safeMod l r - mrgSingle (d, m) - - -- | Safe signed 'quot' with monadic error handling in multi-path execution. - safeQuot :: (MonadError e uf, MonadUnion uf) => a -> a -> uf a - safeQuot l r = do - (d, m) <- safeDivMod l r - mrgIf - ((l .>= 0 .&& r .> 0) .|| (l .<= 0 .&& r .< 0) .|| m .== 0) - (mrgSingle d) - (mrgSingle $ d + 1) - - -- | Safe signed 'rem' with monadic error handling in multi-path execution. - safeRem :: (MonadError e uf, MonadUnion uf) => a -> a -> uf a - safeRem l r = do - (_, m) <- safeDivMod l r - mrgIf - ((l .>= 0 .&& r .> 0) .|| (l .<= 0 .&& r .< 0) .|| m .== 0) - (mrgSingle m) - (mrgSingle $ m - r) - - -- | Safe signed 'quotRem' with monadic error handling in multi-path execution. - safeQuotRem :: (MonadError e uf, MonadUnion uf) => a -> a -> uf (a, a) - safeQuotRem l r = do - (d, m) <- safeDivMod l r - mrgIf - ((l .>= 0 .&& r .> 0) .|| (l .<= 0 .&& r .< 0) .|| m .== 0) - (mrgSingle (d, m)) - (mrgSingle (d + 1, m - r)) - - -- | Safe signed 'div' with monadic error handling in multi-path execution. - -- The error is transformed. - -- - -- >>> safeDiv' (const ()) (ssym "a") (ssym "b") :: ExceptT () UnionM SymInteger - -- ExceptT {If (= b 0) (Left ()) (Right (div a b))} - safeDiv' :: (MonadError e' uf, MonadUnion uf, Mergeable e') => (e -> e') -> a -> a -> uf a - safeDiv' t l r = do - (d, _) <- safeDivMod' t l r - mrgSingle d - - -- | Safe signed 'mod' with monadic error handling in multi-path execution. - -- The error is transformed. - -- - -- >>> safeMod' (const ()) (ssym "a") (ssym "b") :: ExceptT () UnionM SymInteger - -- ExceptT {If (= b 0) (Left ()) (Right (mod a b))} - safeMod' :: (MonadError e' uf, MonadUnion uf, Mergeable e') => (e -> e') -> a -> a -> uf a - safeMod' t l r = do - (_, m) <- safeDivMod' t l r - mrgSingle m - - -- | Safe signed 'divMod' with monadic error handling in multi-path execution. - -- The error is transformed. - -- - -- >>> safeDivMod' (const ()) (ssym "a") (ssym "b") :: ExceptT () UnionM (SymInteger, SymInteger) - -- ExceptT {If (= b 0) (Left ()) (Right ((div a b),(mod a b)))} - safeDivMod' :: (MonadError e' uf, MonadUnion uf, Mergeable e') => (e -> e') -> a -> a -> uf (a, a) - safeDivMod' t l r = do - d <- safeDiv' t l r - m <- safeMod' t l r - mrgSingle (d, m) - - -- | Safe signed 'quot' with monadic error handling in multi-path execution. - -- The error is transformed. - safeQuot' :: (MonadError e' uf, MonadUnion uf, Mergeable e') => (e -> e') -> a -> a -> uf a - safeQuot' t l r = do - (d, m) <- safeDivMod' t l r - mrgIf - ((l .>= 0 .&& r .> 0) .|| (l .<= 0 .&& r .< 0) .|| m .== 0) - (mrgSingle d) - (mrgSingle $ d + 1) - - -- | Safe signed 'rem' with monadic error handling in multi-path execution. - -- The error is transformed. - safeRem' :: (MonadError e' uf, MonadUnion uf, Mergeable e') => (e -> e') -> a -> a -> uf a - safeRem' t l r = do - (_, m) <- safeDivMod' t l r - mrgIf - ((l .>= 0 .&& r .> 0) .|| (l .<= 0 .&& r .< 0) .|| m .== 0) - (mrgSingle m) - (mrgSingle $ m - r) - - -- | Safe signed 'quotRem' with monadic error handling in multi-path execution. - -- The error is transformed. - safeQuotRem' :: (MonadError e' uf, MonadUnion uf, Mergeable e') => (e -> e') -> a -> a -> uf (a, a) - safeQuotRem' t l r = do - (d, m) <- safeDivMod' t l r - mrgIf - ((l .>= 0 .&& r .> 0) .|| (l .<= 0 .&& r .< 0) .|| m .== 0) - (mrgSingle (d, m)) - (mrgSingle (d + 1, m - r)) - - {-# MINIMAL (safeDivMod | (safeDiv, safeMod)), (safeDivMod' | (safeDiv', safeMod')) #-} - -#define QUOTE() ' -#define QID(a) a -#define QRIGHT(a) QID(a)' - -#define QRIGHTT(a) QID(a)' t' -#define QRIGHTU(a) QID(a)' _' - -#define SAFE_DIVISION_CONCRETE_FUNC(name, op) \ -name _ r | r == 0 = merge $ throwError DivideByZero; \ -name l r = mrgSingle $ l `op` r; \ -QRIGHTT(name) _ r | r == 0 = let _ = t' in merge $ throwError (t' DivideByZero); \ -QRIGHTU(name) l r = mrgSingle $ l `op` r - -#define SAFE_DIVISION_CONCRETE(type) \ -instance SafeDivision ArithException type where \ - SAFE_DIVISION_CONCRETE_FUNC(safeDiv, div); \ - SAFE_DIVISION_CONCRETE_FUNC(safeMod, mod); \ - SAFE_DIVISION_CONCRETE_FUNC(safeDivMod, divMod); \ - SAFE_DIVISION_CONCRETE_FUNC(safeQuot, quot); \ - SAFE_DIVISION_CONCRETE_FUNC(safeRem, rem); \ - SAFE_DIVISION_CONCRETE_FUNC(safeQuotRem, quotRem) - -#define SAFE_DIVISION_CONCRETE_BV(type) \ -instance (KnownNat n, 1 <= n) => SafeDivision ArithException (type n) where \ - SAFE_DIVISION_CONCRETE_FUNC(safeDiv, div); \ - SAFE_DIVISION_CONCRETE_FUNC(safeMod, mod); \ - SAFE_DIVISION_CONCRETE_FUNC(safeDivMod, divMod); \ - SAFE_DIVISION_CONCRETE_FUNC(safeQuot, quot); \ - SAFE_DIVISION_CONCRETE_FUNC(safeRem, rem); \ - SAFE_DIVISION_CONCRETE_FUNC(safeQuotRem, quotRem) - -#if 1 -SAFE_DIVISION_CONCRETE(Integer) -SAFE_DIVISION_CONCRETE(Int8) -SAFE_DIVISION_CONCRETE(Int16) -SAFE_DIVISION_CONCRETE(Int32) -SAFE_DIVISION_CONCRETE(Int64) -SAFE_DIVISION_CONCRETE(Int) -SAFE_DIVISION_CONCRETE(Word8) -SAFE_DIVISION_CONCRETE(Word16) -SAFE_DIVISION_CONCRETE(Word32) -SAFE_DIVISION_CONCRETE(Word64) -SAFE_DIVISION_CONCRETE(Word) -#endif - -#define SAFE_DIVISION_CONCRETE_FUNC_SOME(stype, type, name, op) \ - name (stype (l :: type l)) (stype (r :: type r)) = \ - (case sameNat (Proxy @l) (Proxy @r) of \ - Just Refl -> \ - if r == 0 \ - then merge $ throwError $ Right DivideByZero \ - else mrgSingle $ stype $ l `op` r; \ - Nothing -> merge $ throwError $ Left BitwidthMismatch); \ - QRIGHT(name) t (stype (l :: type l)) (stype (r :: type r)) = \ - (case sameNat (Proxy @l) (Proxy @r) of \ - Just Refl -> \ - if r == 0 \ - then merge $ throwError $ t (Right DivideByZero) \ - else mrgSingle $ stype $ l `op` r; \ - Nothing -> merge $ throwError $ t (Left BitwidthMismatch)) - -#define SAFE_DIVISION_CONCRETE_FUNC_SOME_DIVMOD(stype, type, name, op) \ - name (stype (l :: type l)) (stype (r :: type r)) = \ - (case sameNat (Proxy @l) (Proxy @r) of \ - Just Refl -> \ - if r == 0 \ - then merge $ throwError $ Right DivideByZero \ - else (case l `op` r of (d, m) -> mrgSingle (stype d, stype m)); \ - Nothing -> merge $ throwError $ Left BitwidthMismatch); \ - QRIGHT(name) t (stype (l :: type l)) (stype (r :: type r)) = \ - (case sameNat (Proxy @l) (Proxy @r) of \ - Just Refl -> \ - if r == 0 \ - then merge $ throwError $ t (Right DivideByZero) \ - else (case l `op` r of (d, m) -> mrgSingle (stype d, stype m)); \ - Nothing -> merge $ throwError $ t (Left BitwidthMismatch)) - -#if 1 -SAFE_DIVISION_CONCRETE_BV(IntN) -SAFE_DIVISION_CONCRETE_BV(WordN) -instance SafeDivision (Either BitwidthMismatch ArithException) SomeIntN where - SAFE_DIVISION_CONCRETE_FUNC_SOME(SomeIntN, IntN, safeDiv, div) - SAFE_DIVISION_CONCRETE_FUNC_SOME(SomeIntN, IntN, safeMod, mod) - SAFE_DIVISION_CONCRETE_FUNC_SOME_DIVMOD(SomeIntN, IntN, safeDivMod, divMod) - SAFE_DIVISION_CONCRETE_FUNC_SOME(SomeIntN, IntN, safeQuot, quot) - SAFE_DIVISION_CONCRETE_FUNC_SOME(SomeIntN, IntN, safeRem, rem) - SAFE_DIVISION_CONCRETE_FUNC_SOME_DIVMOD(SomeIntN, IntN, safeQuotRem, quotRem) - -instance SafeDivision (Either BitwidthMismatch ArithException) SomeWordN where - SAFE_DIVISION_CONCRETE_FUNC_SOME(SomeWordN, WordN, safeDiv, div) - SAFE_DIVISION_CONCRETE_FUNC_SOME(SomeWordN, WordN, safeMod, mod) - SAFE_DIVISION_CONCRETE_FUNC_SOME_DIVMOD(SomeWordN, WordN, safeDivMod, divMod) - SAFE_DIVISION_CONCRETE_FUNC_SOME(SomeWordN, WordN, safeQuot, quot) - SAFE_DIVISION_CONCRETE_FUNC_SOME(SomeWordN, WordN, safeRem, rem) - SAFE_DIVISION_CONCRETE_FUNC_SOME_DIVMOD(SomeWordN, WordN, safeQuotRem, quotRem) -#endif - -#define SAFE_DIVISION_SYMBOLIC_FUNC(name, type, op) \ -name (type l) rs@(type r) = \ - mrgIf \ - (rs .== con 0) \ - (throwError DivideByZero) \ - (mrgSingle $ type $ op l r); \ -QRIGHT(name) t (type l) rs@(type r) = \ - mrgIf \ - (rs .== con 0) \ - (throwError (t DivideByZero)) \ - (mrgSingle $ type $ op l r) - -#define SAFE_DIVISION_SYMBOLIC_FUNC2(name, type, op1, op2) \ -name (type l) rs@(type r) = \ - mrgIf \ - (rs .== con 0) \ - (throwError DivideByZero) \ - (mrgSingle (type $ op1 l r, type $ op2 l r)); \ -QRIGHT(name) t (type l) rs@(type r) = \ - mrgIf \ - (rs .== con 0) \ - (throwError (t DivideByZero)) \ - (mrgSingle (type $ op1 l r, type $ op2 l r)) - -#if 1 -instance SafeDivision ArithException SymInteger where - SAFE_DIVISION_SYMBOLIC_FUNC(safeDiv, SymInteger, pevalDivIntegralTerm) - SAFE_DIVISION_SYMBOLIC_FUNC(safeMod, SymInteger, pevalModIntegralTerm) - SAFE_DIVISION_SYMBOLIC_FUNC(safeQuot, SymInteger, pevalQuotIntegralTerm) - SAFE_DIVISION_SYMBOLIC_FUNC(safeRem, SymInteger, pevalRemIntegralTerm) - SAFE_DIVISION_SYMBOLIC_FUNC2(safeDivMod, SymInteger, pevalDivIntegralTerm, pevalModIntegralTerm) - SAFE_DIVISION_SYMBOLIC_FUNC2(safeQuotRem, SymInteger, pevalQuotIntegralTerm, pevalRemIntegralTerm) -#endif - -#define SAFE_DIVISION_SYMBOLIC_FUNC_BOUNDED_SIGNED(name, type, op) \ -name ls@(type l) rs@(type r) = \ - mrgIf \ - (rs .== con 0) \ - (throwError DivideByZero) \ - (mrgIf (rs .== con (-1) .&& ls .== con minBound) \ - (throwError Overflow) \ - (mrgSingle $ type $ op l r)); \ -QRIGHT(name) t ls@(type l) rs@(type r) = \ - mrgIf \ - (rs .== con 0) \ - (throwError (t DivideByZero)) \ - (mrgIf (rs .== con (-1) .&& ls .== con minBound) \ - (throwError (t Overflow)) \ - (mrgSingle $ type $ op l r)) - -#define SAFE_DIVISION_SYMBOLIC_FUNC2_BOUNDED_SIGNED(name, type, op1, op2) \ -name ls@(type l) rs@(type r) = \ - mrgIf \ - (rs .== con 0) \ - (throwError DivideByZero) \ - (mrgIf (rs .== con (-1) .&& ls .== con minBound) \ - (throwError Overflow) \ - (mrgSingle (type $ op1 l r, type $ op2 l r))); \ -QRIGHT(name) t ls@(type l) rs@(type r) = \ - mrgIf \ - (rs .== con 0) \ - (throwError (t DivideByZero)) \ - (mrgIf (rs .== con (-1) .&& ls .== con minBound) \ - (throwError (t Overflow)) \ - (mrgSingle (type $ op1 l r, type $ op2 l r))) - -#if 1 -instance (KnownNat n, 1 <= n) => SafeDivision ArithException (SymIntN n) where - SAFE_DIVISION_SYMBOLIC_FUNC_BOUNDED_SIGNED(safeDiv, SymIntN, pevalDivBoundedIntegralTerm) - SAFE_DIVISION_SYMBOLIC_FUNC(safeMod, SymIntN, pevalModBoundedIntegralTerm) - SAFE_DIVISION_SYMBOLIC_FUNC_BOUNDED_SIGNED(safeQuot, SymIntN, pevalQuotBoundedIntegralTerm) - SAFE_DIVISION_SYMBOLIC_FUNC(safeRem, SymIntN, pevalRemBoundedIntegralTerm) - SAFE_DIVISION_SYMBOLIC_FUNC2_BOUNDED_SIGNED(safeDivMod, SymIntN, pevalDivBoundedIntegralTerm, pevalModBoundedIntegralTerm) - SAFE_DIVISION_SYMBOLIC_FUNC2_BOUNDED_SIGNED(safeQuotRem, SymIntN, pevalQuotBoundedIntegralTerm, pevalRemBoundedIntegralTerm) -#endif - -#if 1 -instance (KnownNat n, 1 <= n) => SafeDivision ArithException (SymWordN n) where - SAFE_DIVISION_SYMBOLIC_FUNC(safeDiv, SymWordN, pevalDivIntegralTerm) - SAFE_DIVISION_SYMBOLIC_FUNC(safeMod, SymWordN, pevalModIntegralTerm) - SAFE_DIVISION_SYMBOLIC_FUNC(safeQuot, SymWordN, pevalQuotIntegralTerm) - SAFE_DIVISION_SYMBOLIC_FUNC(safeRem, SymWordN, pevalRemIntegralTerm) - SAFE_DIVISION_SYMBOLIC_FUNC2(safeDivMod, SymWordN, pevalDivIntegralTerm, pevalModIntegralTerm) - SAFE_DIVISION_SYMBOLIC_FUNC2(safeQuotRem, SymWordN, pevalQuotIntegralTerm, pevalRemIntegralTerm) -#endif diff --git a/src/Grisette/Core/Data/Class/SafeLinearArith.hs b/src/Grisette/Core/Data/Class/SafeLinearArith.hs deleted file mode 100644 --- a/src/Grisette/Core/Data/Class/SafeLinearArith.hs +++ /dev/null @@ -1,307 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- Module : Grisette.Core.Data.Class.SafeLinearArith --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Core.Data.Class.SafeLinearArith - ( ArithException (..), - SafeLinearArith (..), - ) -where - -import Control.Exception (ArithException (DivideByZero, Overflow, Underflow)) -import Control.Monad.Except (MonadError (throwError)) -import Data.Int (Int16, Int32, Int64, Int8) -import Data.Typeable (Proxy (Proxy), type (:~:) (Refl)) -import Data.Word (Word16, Word32, Word64, Word8) -import GHC.TypeNats (KnownNat, sameNat, type (<=)) -import Grisette.Core.Control.Monad.Union (MonadUnion) -import Grisette.Core.Data.BV - ( BitwidthMismatch (BitwidthMismatch), - IntN, - SomeIntN (SomeIntN), - SomeWordN (SomeWordN), - WordN, - ) -import Grisette.Core.Data.Class.LogicalOp - ( LogicalOp ((.&&), (.||)), - ) -import Grisette.Core.Data.Class.Mergeable (Mergeable) -import Grisette.Core.Data.Class.SEq (SEq ((./=), (.==))) -import Grisette.Core.Data.Class.SOrd (SOrd ((.<), (.>), (.>=))) -import Grisette.Core.Data.Class.SimpleMergeable - ( merge, - mrgIf, - mrgSingle, - ) -import Grisette.Core.Data.Class.Solvable (Solvable (con)) -import Grisette.IR.SymPrim.Data.SymPrim - ( SymIntN, - SymInteger, - SymWordN, - ) - --- $setup --- >>> import Grisette.Core --- >>> import Grisette.IR.SymPrim --- >>> import Control.Monad.Except - --- | Safe division with monadic error handling in multi-path --- execution. These procedures throw an exception when overflow or underflow happens. --- The result should be able to handle errors with `MonadError`. -class (SOrd a, Num a, Mergeable a, Mergeable e) => SafeLinearArith e a | a -> e where - -- | Safe '+' with monadic error handling in multi-path execution. - -- Overflows or underflows are treated as errors. - -- - -- >>> safeAdd (ssym "a") (ssym "b") :: ExceptT ArithException UnionM SymInteger - -- ExceptT {Right (+ a b)} - -- >>> safeAdd (ssym "a") (ssym "b") :: ExceptT ArithException UnionM (SymIntN 4) - -- ExceptT {If (ite (< 0x0 a) (&& (< 0x0 b) (< (+ a b) 0x0)) (&& (< a 0x0) (&& (< b 0x0) (<= 0x0 (+ a b))))) (If (< 0x0 a) (Left arithmetic overflow) (Left arithmetic underflow)) (Right (+ a b))} - safeAdd :: (MonadError e uf, MonadUnion uf) => a -> a -> uf a - - -- | Safe 'negate' with monadic error handling in multi-path execution. - -- Overflows or underflows are treated as errors. - -- - -- >>> safeNeg (ssym "a") :: ExceptT ArithException UnionM SymInteger - -- ExceptT {Right (- a)} - -- >>> safeNeg (ssym "a") :: ExceptT ArithException UnionM (SymIntN 4) - -- ExceptT {If (= a 0x8) (Left arithmetic overflow) (Right (- a))} - safeNeg :: (MonadError e uf, MonadUnion uf) => a -> uf a - - -- | Safe '-' with monadic error handling in multi-path execution. - -- Overflows or underflows are treated as errors. - -- - -- >>> safeMinus (ssym "a") (ssym "b") :: ExceptT ArithException UnionM SymInteger - -- ExceptT {Right (+ a (- b))} - -- >>> safeMinus (ssym "a") (ssym "b") :: ExceptT ArithException UnionM (SymIntN 4) - -- ExceptT {If (ite (<= 0x0 a) (&& (< b 0x0) (< (+ a (- b)) 0x0)) (&& (< a 0x0) (&& (< 0x0 b) (< 0x0 (+ a (- b)))))) (If (<= 0x0 a) (Left arithmetic overflow) (Left arithmetic underflow)) (Right (+ a (- b)))} - safeMinus :: (MonadError e uf, MonadUnion uf) => a -> a -> uf a - - -- | Safe '+' with monadic error handling in multi-path execution. - -- Overflows or underflows are treated as errors. - -- The error is transformed. - safeAdd' :: (MonadError e' uf, MonadUnion uf, Mergeable e') => (e -> e') -> a -> a -> uf a - - -- | Safe 'negate' with monadic error handling in multi-path execution. - -- Overflows or underflows are treated as errors. - -- The error is transformed. - safeNeg' :: (MonadError e' uf, MonadUnion uf, Mergeable e') => (e -> e') -> a -> uf a - - -- | Safe '-' with monadic error handling in multi-path execution. - -- Overflows or underflows are treated as errors. - -- The error is transformed. - safeMinus' :: (MonadError e' uf, MonadUnion uf, Mergeable e') => (e -> e') -> a -> a -> uf a - -instance SafeLinearArith ArithException Integer where - safeAdd l r = mrgSingle (l + r) - safeNeg l = mrgSingle (-l) - safeMinus l r = mrgSingle (l - r) - safeAdd' _ l r = mrgSingle (l + r) - safeNeg' _ l = mrgSingle (-l) - safeMinus' _ l r = mrgSingle (l - r) - -#define SAFE_LINARITH_SIGNED_CONCRETE_BODY \ - safeAdd l r = let res = l + r in \ - mrgIf (con $ l > 0 && r > 0 && res < 0) \ - (throwError Overflow) \ - (mrgIf (con $ l < 0 && r < 0 && res >= 0) \ - (throwError Underflow) \ - (return res));\ - safeAdd' t' l r = let res = l + r in \ - mrgIf (con $ l > 0 && r > 0 && res < 0) \ - (throwError (t' Overflow)) \ - (mrgIf (con $ l < 0 && r < 0 && res >= 0) \ - (throwError (t' Underflow)) \ - (return res)); \ - safeMinus l r = let res = l - r in \ - mrgIf (con $ l >= 0 && r < 0 && res < 0) \ - (throwError Overflow) \ - (mrgIf (con $ l < 0 && r > 0 && res > 0) \ - (throwError Underflow) \ - (return res));\ - safeMinus' t' l r = let res = l - r in \ - mrgIf (con $ l >= 0 && r < 0 && res < 0) \ - (throwError (t' Overflow)) \ - (mrgIf (con $ l < 0 && r > 0 && res > 0) \ - (throwError (t' Underflow)) \ - (return res)); \ - safeNeg v = mrgIf (con $ v == minBound) (throwError Overflow) (return $ -v);\ - safeNeg' t' v = mrgIf (con $ v == minBound) (throwError (t' Overflow)) (return $ -v) - -#define SAFE_LINARITH_SIGNED_CONCRETE(type) \ -instance SafeLinearArith ArithException type where \ - SAFE_LINARITH_SIGNED_CONCRETE_BODY - -#define SAFE_LINARITH_SIGNED_BV_CONCRETE(type) \ -instance (KnownNat n, 1 <= n) => SafeLinearArith ArithException (type n) where \ - SAFE_LINARITH_SIGNED_CONCRETE_BODY - -#define SAFE_LINARITH_UNSIGNED_CONCRETE_BODY \ - safeAdd l r = let res = l + r in \ - mrgIf (con $ l > res || r > res) \ - (throwError Overflow) \ - (return res);\ - safeAdd' t' l r = let res = l + r in \ - mrgIf (con $ l > res || r > res) \ - (throwError (t' Overflow)) \ - (return res); \ - safeMinus l r = \ - mrgIf (con $ r > l) \ - (throwError Underflow) \ - (return $ l - r);\ - safeMinus' t' l r = \ - mrgIf (con $ r > l) \ - (throwError $ t' Underflow) \ - (return $ l - r);\ - safeNeg v = mrgIf (con $ v /= 0) (throwError Underflow) (return $ -v);\ - safeNeg' t' v = mrgIf (con $ v /= 0) (throwError (t' Underflow)) (return $ -v) - -#define SAFE_LINARITH_UNSIGNED_CONCRETE(type) \ -instance SafeLinearArith ArithException type where \ - SAFE_LINARITH_UNSIGNED_CONCRETE_BODY - -#define SAFE_LINARITH_UNSIGNED_BV_CONCRETE(type) \ -instance (KnownNat n, 1 <= n) => SafeLinearArith ArithException (type n) where \ - SAFE_LINARITH_UNSIGNED_CONCRETE_BODY - -#define SAFE_LINARITH_SOME_CONCRETE(type, ctype) \ -instance SafeLinearArith (Either BitwidthMismatch ArithException) type where \ - safeAdd (type (l :: ctype l)) (type (r :: ctype r)) = merge (\ - case sameNat (Proxy @l) (Proxy @r) of \ - Just Refl -> type <$> safeAdd' Right l r; \ - _ -> throwError $ Left BitwidthMismatch); \ - safeAdd' t (type (l :: ctype l)) (type (r :: ctype r)) = merge (\ - case sameNat (Proxy @l) (Proxy @r) of \ - Just Refl -> type <$> safeAdd' (t . Right) l r; \ - _ -> let t' = t; _ = t' in throwError $ t' $ Left BitwidthMismatch); \ - safeMinus (type (l :: ctype l)) (type (r :: ctype r)) = merge (\ - case sameNat (Proxy @l) (Proxy @r) of \ - Just Refl -> type <$> safeMinus' Right l r; \ - _ -> throwError $ Left BitwidthMismatch); \ - safeMinus' t (type (l :: ctype l)) (type (r :: ctype r)) = merge (\ - case sameNat (Proxy @l) (Proxy @r) of \ - Just Refl -> type <$> safeMinus' (t . Right) l r; \ - _ -> let t' = t; _ = t' in throwError $ t' $ Left BitwidthMismatch); \ - safeNeg (type l) = merge $ type <$> safeNeg' Right l; \ - safeNeg' t (type l) = merge $ type <$> safeNeg' (t . Right) l - -#if 1 -SAFE_LINARITH_SIGNED_CONCRETE(Int8) -SAFE_LINARITH_SIGNED_CONCRETE(Int16) -SAFE_LINARITH_SIGNED_CONCRETE(Int32) -SAFE_LINARITH_SIGNED_CONCRETE(Int64) -SAFE_LINARITH_SIGNED_CONCRETE(Int) -SAFE_LINARITH_SIGNED_BV_CONCRETE(IntN) -SAFE_LINARITH_SOME_CONCRETE(SomeIntN, IntN) -SAFE_LINARITH_UNSIGNED_CONCRETE(Word8) -SAFE_LINARITH_UNSIGNED_CONCRETE(Word16) -SAFE_LINARITH_UNSIGNED_CONCRETE(Word32) -SAFE_LINARITH_UNSIGNED_CONCRETE(Word64) -SAFE_LINARITH_UNSIGNED_CONCRETE(Word) -SAFE_LINARITH_UNSIGNED_BV_CONCRETE(WordN) -SAFE_LINARITH_SOME_CONCRETE(SomeWordN, WordN) -#endif - -instance SafeLinearArith ArithException SymInteger where - safeAdd ls rs = mrgSingle $ ls + rs - safeAdd' _ ls rs = mrgSingle $ ls + rs - safeNeg v = mrgSingle $ -v - safeNeg' _ v = mrgSingle $ -v - safeMinus ls rs = mrgSingle $ ls - rs - safeMinus' _ ls rs = mrgSingle $ ls - rs - -instance (KnownNat n, 1 <= n) => SafeLinearArith ArithException (SymIntN n) where - safeAdd ls rs = - mrgIf - (ls .> 0) - (mrgIf (rs .> 0 .&& res .< 0) (throwError Overflow) (return res)) - ( mrgIf - (ls .< 0 .&& rs .< 0 .&& res .>= 0) - (throwError Underflow) - (mrgSingle res) - ) - where - res = ls + rs - safeAdd' f ls rs = - mrgIf - (ls .> 0) - (mrgIf (rs .> 0 .&& res .< 0) (throwError $ f Overflow) (return res)) - ( mrgIf - (ls .< 0 .&& rs .< 0 .&& res .>= 0) - (throwError $ f Underflow) - (mrgSingle res) - ) - where - res = ls + rs - safeNeg v = mrgIf (v .== con minBound) (throwError Overflow) (mrgSingle $ -v) - safeNeg' f v = mrgIf (v .== con minBound) (throwError $ f Overflow) (mrgSingle $ -v) - safeMinus ls rs = - mrgIf - (ls .>= 0) - (mrgIf (rs .< 0 .&& res .< 0) (throwError Overflow) (return res)) - ( mrgIf - (ls .< 0 .&& rs .> 0 .&& res .> 0) - (throwError Underflow) - (mrgSingle res) - ) - where - res = ls - rs - safeMinus' f ls rs = - mrgIf - (ls .>= 0) - (mrgIf (rs .< 0 .&& res .< 0) (throwError $ f Overflow) (return res)) - ( mrgIf - (ls .< 0 .&& rs .> 0 .&& res .> 0) - (throwError $ f Underflow) - (mrgSingle res) - ) - where - res = ls - rs - -instance (KnownNat n, 1 <= n) => SafeLinearArith ArithException (SymWordN n) where - safeAdd ls rs = - mrgIf - (ls .> res .|| rs .> res) - (throwError Overflow) - (mrgSingle res) - where - res = ls + rs - safeAdd' f ls rs = - mrgIf - (ls .> res .|| rs .> res) - (throwError $ f Overflow) - (mrgSingle res) - where - res = ls + rs - safeNeg v = mrgIf (v ./= 0) (throwError Underflow) (mrgSingle v) - safeNeg' f v = mrgIf (v ./= 0) (throwError $ f Underflow) (mrgSingle v) - safeMinus ls rs = - mrgIf - (rs .> ls) - (throwError Underflow) - (mrgSingle res) - where - res = ls - rs - safeMinus' f ls rs = - mrgIf - (rs .> ls) - (throwError $ f Underflow) - (mrgSingle res) - where - res = ls - rs diff --git a/src/Grisette/Core/Data/Class/SafeSymRotate.hs b/src/Grisette/Core/Data/Class/SafeSymRotate.hs deleted file mode 100644 --- a/src/Grisette/Core/Data/Class/SafeSymRotate.hs +++ /dev/null @@ -1,110 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -module Grisette.Core.Data.Class.SafeSymRotate (SafeSymRotate (..)) where - -import Control.Exception (ArithException (Overflow)) -import Control.Monad.Error.Class (MonadError) -import Data.Bits (Bits (rotateL, rotateR), FiniteBits (finiteBitSize)) -import Data.Int (Int16, Int32, Int64, Int8) -import Data.Word (Word16, Word32, Word64, Word8) -import GHC.TypeLits (KnownNat, type (<=)) -import Grisette.Core.Control.Monad.Union (MonadUnion) -import Grisette.Core.Data.BV (IntN, WordN) -import Grisette.Core.Data.Class.Mergeable (Mergeable) -import Grisette.Core.Data.Class.SOrd (SOrd ((.<))) -import Grisette.Core.Data.Class.SimpleMergeable (UnionLike, mrgIf) -import Grisette.Core.Data.Class.SymRotate (SymRotate) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bits - ( pevalRotateLeftTerm, - pevalRotateRightTerm, - ) -import Grisette.IR.SymPrim.Data.SymPrim - ( SymIntN (SymIntN), - SymWordN (SymWordN), - ) -import Grisette.Lib.Control.Monad (mrgReturn) -import Grisette.Lib.Control.Monad.Except (mrgThrowError) - -class (SymRotate a) => SafeSymRotate e a | a -> e where - safeSymRotateL :: (MonadError e m, UnionLike m) => a -> a -> m a - safeSymRotateL = safeSymRotateL' id - safeSymRotateR :: (MonadError e m, UnionLike m) => a -> a -> m a - safeSymRotateR = safeSymRotateR' id - safeSymRotateL' :: - (MonadError e' m, UnionLike m) => (e -> e') -> a -> a -> m a - safeSymRotateR' :: - (MonadError e' m, UnionLike m) => (e -> e') -> a -> a -> m a - {-# MINIMAL safeSymRotateL', safeSymRotateR' #-} - --- | This function handles the case when the shift amount is out the range of --- `Int` correctly. -safeSymRotateLConcreteNum :: - (MonadError e m, MonadUnion m, Integral a, FiniteBits a, Mergeable a) => - e -> - a -> - a -> - m a -safeSymRotateLConcreteNum e _ s | s < 0 = mrgThrowError e -safeSymRotateLConcreteNum _ a s = - mrgReturn $ rotateL a (fromIntegral $ s `rem` fromIntegral (finiteBitSize s)) - --- | This function handles the case when the shift amount is out the range of --- `Int` correctly. -safeSymRotateRConcreteNum :: - (MonadError e m, MonadUnion m, Integral a, FiniteBits a, Mergeable a) => - e -> - a -> - a -> - m a -safeSymRotateRConcreteNum e _ s | s < 0 = mrgThrowError e -safeSymRotateRConcreteNum _ a s = - mrgReturn $ rotateR a (fromIntegral $ s `rem` fromIntegral (finiteBitSize s)) - -#define SAFE_SYM_ROTATE_CONCRETE(T) \ - instance SafeSymRotate ArithException T where \ - safeSymRotateL' f = safeSymRotateLConcreteNum (f Overflow); \ - safeSymRotateR' f = safeSymRotateRConcreteNum (f Overflow) \ - -#if 1 -SAFE_SYM_ROTATE_CONCRETE(Word8) -SAFE_SYM_ROTATE_CONCRETE(Word16) -SAFE_SYM_ROTATE_CONCRETE(Word32) -SAFE_SYM_ROTATE_CONCRETE(Word64) -SAFE_SYM_ROTATE_CONCRETE(Word) -SAFE_SYM_ROTATE_CONCRETE(Int8) -SAFE_SYM_ROTATE_CONCRETE(Int16) -SAFE_SYM_ROTATE_CONCRETE(Int32) -SAFE_SYM_ROTATE_CONCRETE(Int64) -SAFE_SYM_ROTATE_CONCRETE(Int) -#endif - -instance (KnownNat n, 1 <= n) => SafeSymRotate ArithException (WordN n) where - safeSymRotateL' f = safeSymRotateLConcreteNum (f Overflow) - safeSymRotateR' f = safeSymRotateRConcreteNum (f Overflow) - -instance (KnownNat n, 1 <= n) => SafeSymRotate ArithException (IntN n) where - safeSymRotateL' f = safeSymRotateLConcreteNum (f Overflow) - safeSymRotateR' f = safeSymRotateRConcreteNum (f Overflow) - -instance (KnownNat n, 1 <= n) => SafeSymRotate ArithException (SymWordN n) where - safeSymRotateL' _ (SymWordN ta) (SymWordN tr) = - mrgReturn $ SymWordN $ pevalRotateLeftTerm ta tr - safeSymRotateR' _ (SymWordN ta) (SymWordN tr) = - mrgReturn $ SymWordN $ pevalRotateRightTerm ta tr - -instance (KnownNat n, 1 <= n) => SafeSymRotate ArithException (SymIntN n) where - safeSymRotateL' f (SymIntN ta) r@(SymIntN tr) = - mrgIf - (r .< 0) - (mrgThrowError $ f Overflow) - (mrgReturn $ SymIntN $ pevalRotateLeftTerm ta tr) - safeSymRotateR' f (SymIntN ta) r@(SymIntN tr) = - mrgIf - (r .< 0) - (mrgThrowError $ f Overflow) - (mrgReturn $ SymIntN $ pevalRotateRightTerm ta tr) diff --git a/src/Grisette/Core/Data/Class/SafeSymShift.hs b/src/Grisette/Core/Data/Class/SafeSymShift.hs deleted file mode 100644 --- a/src/Grisette/Core/Data/Class/SafeSymShift.hs +++ /dev/null @@ -1,190 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -module Grisette.Core.Data.Class.SafeSymShift - ( SafeSymShift (..), - ) -where - -import Control.Exception (ArithException (Overflow)) -import Control.Monad.Error.Class (MonadError) -import Data.Bits (Bits (shiftL, shiftR), FiniteBits (finiteBitSize)) -import Data.Int (Int16, Int32, Int64, Int8) -import Data.Word (Word16, Word32, Word64, Word8) -import GHC.TypeLits (KnownNat, type (<=)) -import Grisette.Core.Control.Monad.Union (MonadUnion) -import Grisette.Core.Data.BV (IntN, WordN) -import Grisette.Core.Data.Class.LogicalOp - ( LogicalOp ((.&&), (.||)), - ) -import Grisette.Core.Data.Class.Mergeable (Mergeable) -import Grisette.Core.Data.Class.SOrd - ( SOrd ((.<), (.>=)), - ) -import Grisette.Core.Data.Class.SimpleMergeable - ( UnionLike, - mrgIf, - ) -import Grisette.Core.Data.Class.SymShift (SymShift) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bits - ( pevalShiftLeftTerm, - pevalShiftRightTerm, - ) -import Grisette.IR.SymPrim.Data.SymPrim (SymIntN (SymIntN), SymWordN (SymWordN)) -import Grisette.Lib.Control.Monad (mrgReturn) -import Grisette.Lib.Control.Monad.Except (mrgThrowError) - --- | Safe version for `shiftL` or `shiftR`. --- --- The `safeSymShiftL` and `safeSymShiftR` and their primed versions are defined --- for all non-negative shift amounts. --- --- * Shifting by negative shift amounts is an error. --- * The result is defined to be 0 when shifting left by more than or equal to --- the bit size of the number. --- * The result is defined to be 0 when shifting right by more than or equal to --- the bit size of the number and the number is unsigned or signed non-negative. --- * The result is defined to be -1 when shifting right by more than or equal to --- the bit size of the number and the number is signed negative. --- --- The `safeSymStrictShiftL` and `safeSymStrictShiftR` and their primed versions --- are defined for all non-negative shift amounts that is less than the bit --- size. Shifting by more than or equal to the bit size is an error, otherwise --- they are the same as the non-strict versions. -class (SymShift a) => SafeSymShift e a | a -> e where - safeSymShiftL :: (MonadError e m, UnionLike m) => a -> a -> m a - safeSymShiftL = safeSymShiftL' id - safeSymShiftR :: (MonadError e m, UnionLike m) => a -> a -> m a - safeSymShiftR = safeSymShiftR' id - safeSymShiftL' :: - (MonadError e' m, UnionLike m) => (e -> e') -> a -> a -> m a - safeSymShiftR' :: - (MonadError e' m, UnionLike m) => (e -> e') -> a -> a -> m a - safeSymStrictShiftL :: (MonadError e m, UnionLike m) => a -> a -> m a - safeSymStrictShiftL = safeSymStrictShiftL' id - safeSymStrictShiftR :: (MonadError e m, UnionLike m) => a -> a -> m a - safeSymStrictShiftR = safeSymStrictShiftR' id - safeSymStrictShiftL' :: - (MonadError e' m, UnionLike m) => (e -> e') -> a -> a -> m a - safeSymStrictShiftR' :: - (MonadError e' m, UnionLike m) => (e -> e') -> a -> a -> m a - {-# MINIMAL - safeSymShiftL', - safeSymShiftR', - safeSymStrictShiftL', - safeSymStrictShiftR' - #-} - --- | This function handles the case when the shift amount is out the range of --- `Int` correctly. -safeSymShiftLConcreteNum :: - (MonadError e m, MonadUnion m, Integral a, FiniteBits a, Mergeable a) => - e -> - Bool -> - a -> - a -> - m a -safeSymShiftLConcreteNum e _ _ s | s < 0 = mrgThrowError e -safeSymShiftLConcreteNum e allowLargeShiftAmount a s - | (fromIntegral s :: Integer) >= fromIntegral (finiteBitSize a) = - if allowLargeShiftAmount then mrgReturn 0 else mrgThrowError e -safeSymShiftLConcreteNum _ _ a s = mrgReturn $ shiftL a (fromIntegral s) - --- | This function handles the case when the shift amount is out the range of --- `Int` correctly. -safeSymShiftRConcreteNum :: - (MonadError e m, MonadUnion m, Integral a, FiniteBits a, Mergeable a) => - e -> - Bool -> - a -> - a -> - m a -safeSymShiftRConcreteNum e _ _ s | s < 0 = mrgThrowError e -safeSymShiftRConcreteNum e allowLargeShiftAmount a s - | (fromIntegral s :: Integer) >= fromIntegral (finiteBitSize a) = - if allowLargeShiftAmount then mrgReturn 0 else mrgThrowError e -safeSymShiftRConcreteNum _ _ a s = mrgReturn $ shiftR a (fromIntegral s) - -#define SAFE_SYM_SHIFT_CONCRETE(T) \ - instance SafeSymShift ArithException T where \ - safeSymShiftL' f = safeSymShiftLConcreteNum (f Overflow) True; \ - safeSymShiftR' f = safeSymShiftRConcreteNum (f Overflow) True; \ - safeSymStrictShiftL' f = safeSymShiftLConcreteNum (f Overflow) False; \ - safeSymStrictShiftR' f = safeSymShiftRConcreteNum (f Overflow) False - -#if 1 -SAFE_SYM_SHIFT_CONCRETE(Word8) -SAFE_SYM_SHIFT_CONCRETE(Word16) -SAFE_SYM_SHIFT_CONCRETE(Word32) -SAFE_SYM_SHIFT_CONCRETE(Word64) -SAFE_SYM_SHIFT_CONCRETE(Word) -SAFE_SYM_SHIFT_CONCRETE(Int8) -SAFE_SYM_SHIFT_CONCRETE(Int16) -SAFE_SYM_SHIFT_CONCRETE(Int32) -SAFE_SYM_SHIFT_CONCRETE(Int64) -SAFE_SYM_SHIFT_CONCRETE(Int) -#endif - -instance (KnownNat n, 1 <= n) => SafeSymShift ArithException (WordN n) where - safeSymShiftL' f = safeSymShiftLConcreteNum (f Overflow) True - safeSymShiftR' f = safeSymShiftRConcreteNum (f Overflow) True - safeSymStrictShiftL' f = safeSymShiftLConcreteNum (f Overflow) False - safeSymStrictShiftR' f = safeSymShiftRConcreteNum (f Overflow) False - -instance (KnownNat n, 1 <= n) => SafeSymShift ArithException (IntN n) where - safeSymShiftL' f = safeSymShiftLConcreteNum (f Overflow) True - safeSymShiftR' f = safeSymShiftRConcreteNum (f Overflow) True - safeSymStrictShiftL' f = safeSymShiftLConcreteNum (f Overflow) False - safeSymStrictShiftR' f = safeSymShiftRConcreteNum (f Overflow) False - -instance (KnownNat n, 1 <= n) => SafeSymShift ArithException (SymWordN n) where - safeSymShiftL' _ (SymWordN a) (SymWordN s) = - return $ SymWordN $ pevalShiftLeftTerm a s - safeSymShiftR' _ (SymWordN a) (SymWordN s) = - return $ SymWordN $ pevalShiftRightTerm a s - safeSymStrictShiftL' f a@(SymWordN ta) s@(SymWordN ts) = - mrgIf - (s .>= fromIntegral (finiteBitSize a)) - (mrgThrowError $ f Overflow) - (return $ SymWordN $ pevalShiftLeftTerm ta ts) - safeSymStrictShiftR' f a@(SymWordN ta) s@(SymWordN ts) = - mrgIf - (s .>= fromIntegral (finiteBitSize a)) - (mrgThrowError $ f Overflow) - (return $ SymWordN $ pevalShiftRightTerm ta ts) - -instance (KnownNat n, 1 <= n) => SafeSymShift ArithException (SymIntN n) where - safeSymShiftL' f (SymIntN a) ss@(SymIntN s) = - mrgIf - (ss .< 0) - (mrgThrowError $ f Overflow) - (return $ SymIntN $ pevalShiftLeftTerm a s) - safeSymShiftR' f (SymIntN a) ss@(SymIntN s) = - mrgIf - (ss .< 0) - (mrgThrowError $ f Overflow) - (return $ SymIntN $ pevalShiftRightTerm a s) - safeSymStrictShiftL' f a@(SymIntN ta) s@(SymIntN ts) = - mrgIf - (s .< 0 .|| (bs .>= 0 .&& s .>= bs)) - (mrgThrowError $ f Overflow) - (return $ SymIntN $ pevalShiftLeftTerm ta ts) - where - bs = fromIntegral (finiteBitSize a) - safeSymStrictShiftR' f a@(SymIntN ta) s@(SymIntN ts) = - mrgIf - (s .< 0 .|| (bs .>= 0 .&& s .>= bs)) - (mrgThrowError $ f Overflow) - (return $ SymIntN $ pevalShiftRightTerm ta ts) - where - bs = fromIntegral (finiteBitSize a) diff --git a/src/Grisette/Core/Data/Class/SignConversion.hs b/src/Grisette/Core/Data/Class/SignConversion.hs deleted file mode 100644 --- a/src/Grisette/Core/Data/Class/SignConversion.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE FunctionalDependencies #-} - -module Grisette.Core.Data.Class.SignConversion - ( SignConversion (..), - ) -where - -import Data.Int (Int16, Int32, Int64, Int8) -import Data.Word (Word16, Word32, Word64, Word8) - --- | Convert values between signed and unsigned. -class SignConversion ubv sbv | ubv -> sbv, sbv -> ubv where - -- | Convert unsigned value to the corresponding signed value. - toSigned :: ubv -> sbv - - -- | Convert signed value to the corresponding unsigned value. - toUnsigned :: sbv -> ubv - -instance SignConversion Word8 Int8 where - toSigned = fromIntegral - toUnsigned = fromIntegral - -instance SignConversion Word16 Int16 where - toSigned = fromIntegral - toUnsigned = fromIntegral - -instance SignConversion Word32 Int32 where - toSigned = fromIntegral - toUnsigned = fromIntegral - -instance SignConversion Word64 Int64 where - toSigned = fromIntegral - toUnsigned = fromIntegral - -instance SignConversion Word Int where - toSigned = fromIntegral - toUnsigned = fromIntegral diff --git a/src/Grisette/Core/Data/Class/SimpleMergeable.hs b/src/Grisette/Core/Data/Class/SimpleMergeable.hs deleted file mode 100644 --- a/src/Grisette/Core/Data/Class/SimpleMergeable.hs +++ /dev/null @@ -1,849 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} - --- | --- Module : Grisette.Core.Data.Class.SimpleMergeable --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Core.Data.Class.SimpleMergeable - ( -- * Simple mergeable types - SimpleMergeable (..), - SimpleMergeable1 (..), - mrgIte1, - SimpleMergeable2 (..), - mrgIte2, - - -- * UnionLike operations - UnionLike (..), - mrgIf, - merge, - mrgSingle, - UnionPrjOp (..), - pattern Single, - pattern If, - simpleMerge, - onUnion, - onUnion2, - onUnion3, - onUnion4, - (.#), - ) -where - -import Control.Monad.Except (ExceptT (ExceptT)) -import Control.Monad.Identity - ( Identity (Identity), - IdentityT (IdentityT), - ) -import qualified Control.Monad.RWS.Lazy as RWSLazy -import qualified Control.Monad.RWS.Strict as RWSStrict -import Control.Monad.Reader (ReaderT (ReaderT)) -import qualified Control.Monad.State.Lazy as StateLazy -import qualified Control.Monad.State.Strict as StateStrict -import Control.Monad.Trans.Cont (ContT (ContT)) -import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) -import qualified Control.Monad.Writer.Lazy as WriterLazy -import qualified Control.Monad.Writer.Strict as WriterStrict -import Data.Bifunctor (Bifunctor (first)) -import Data.Kind (Type) -import GHC.Generics - ( Generic (Rep, from, to), - K1 (K1), - M1 (M1), - U1, - V1, - type (:*:) ((:*:)), - ) -import GHC.TypeNats (KnownNat, type (<=)) -import Generics.Deriving (Default (Default)) -import Grisette.Core.Control.Exception (AssertionError) -import Grisette.Core.Data.Class.Function (Function (Arg, Ret, (#))) -import Grisette.Core.Data.Class.ITEOp (ITEOp (symIte)) -import Grisette.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.&&))) -import Grisette.Core.Data.Class.Mergeable - ( Mergeable (rootStrategy), - Mergeable', - Mergeable1 (liftRootStrategy), - Mergeable2 (liftRootStrategy2), - Mergeable3 (liftRootStrategy3), - MergingStrategy (SimpleStrategy), - ) -import Grisette.Core.Data.Class.Solvable (Solvable (con)) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term - ( LinkedRep, - SupportedPrim, - ) -import Grisette.IR.SymPrim.Data.SymPrim - ( SymBool, - SymIntN, - SymInteger, - SymWordN, - type (-~>), - type (=~>), - ) - --- $setup --- >>> import Grisette.Core --- >>> import Grisette.IR.SymPrim --- >>> import Control.Monad.Identity - --- | Auxiliary class for the generic derivation for the 'SimpleMergeable' class. -class SimpleMergeable' f where - mrgIte' :: SymBool -> f a -> f a -> f a - -instance (SimpleMergeable' U1) where - mrgIte' _ t _ = t - {-# INLINE mrgIte' #-} - -instance (SimpleMergeable' V1) where - mrgIte' _ t _ = t - {-# INLINE mrgIte' #-} - -instance (SimpleMergeable c) => (SimpleMergeable' (K1 i c)) where - mrgIte' cond (K1 a) (K1 b) = K1 $ mrgIte cond a b - {-# INLINE mrgIte' #-} - -instance (SimpleMergeable' a) => (SimpleMergeable' (M1 i c a)) where - mrgIte' cond (M1 a) (M1 b) = M1 $ mrgIte' cond a b - {-# INLINE mrgIte' #-} - -instance (SimpleMergeable' a, SimpleMergeable' b) => (SimpleMergeable' (a :*: b)) where - mrgIte' cond (a1 :*: a2) (b1 :*: b2) = mrgIte' cond a1 b1 :*: mrgIte' cond a2 b2 - {-# INLINE mrgIte' #-} - --- | This class indicates that a type has a simple root merge strategy. --- --- __Note:__ This type class can be derived for algebraic data types. --- You may need the @DerivingVia@ and @DerivingStrategies@ extensions. --- --- > data X = ... --- > deriving Generic --- > deriving (Mergeable, SimpleMergeable) via (Default X) -class (Mergeable a) => SimpleMergeable a where - -- | Performs if-then-else with the simple root merge strategy. - -- - -- >>> mrgIte "a" "b" "c" :: SymInteger - -- (ite a b c) - mrgIte :: SymBool -> a -> a -> a - -instance (Generic a, Mergeable' (Rep a), SimpleMergeable' (Rep a)) => SimpleMergeable (Default a) where - mrgIte cond (Default a) (Default b) = Default $ to $ mrgIte' cond (from a) (from b) - {-# INLINE mrgIte #-} - --- | Lifting of the 'SimpleMergeable' class to unary type constructors. -class SimpleMergeable1 u where - -- | Lift 'mrgIte' through the type constructor. - -- - -- >>> liftMrgIte mrgIte "a" (Identity "b") (Identity "c") :: Identity SymInteger - -- Identity (ite a b c) - liftMrgIte :: (SymBool -> a -> a -> a) -> SymBool -> u a -> u a -> u a - --- | Lift the standard 'mrgIte' function through the type constructor. --- --- >>> mrgIte1 "a" (Identity "b") (Identity "c") :: Identity SymInteger --- Identity (ite a b c) -mrgIte1 :: (SimpleMergeable1 u, SimpleMergeable a) => SymBool -> u a -> u a -> u a -mrgIte1 = liftMrgIte mrgIte -{-# INLINE mrgIte1 #-} - --- | Lifting of the 'SimpleMergeable' class to binary type constructors. -class (Mergeable2 u) => SimpleMergeable2 u where - -- | Lift 'mrgIte' through the type constructor. - -- - -- >>> liftMrgIte2 mrgIte mrgIte "a" ("b", "c") ("d", "e") :: (SymInteger, SymBool) - -- ((ite a b d),(ite a c e)) - liftMrgIte2 :: (SymBool -> a -> a -> a) -> (SymBool -> b -> b -> b) -> SymBool -> u a b -> u a b -> u a b - --- | Lift the standard 'mrgIte' function through the type constructor. --- --- >>> mrgIte2 "a" ("b", "c") ("d", "e") :: (SymInteger, SymBool) --- ((ite a b d),(ite a c e)) -mrgIte2 :: (SimpleMergeable2 u, SimpleMergeable a, SimpleMergeable b) => SymBool -> u a b -> u a b -> u a b -mrgIte2 = liftMrgIte2 mrgIte mrgIte -{-# INLINE mrgIte2 #-} - --- | Special case of the 'Mergeable1' and 'SimpleMergeable1' class for type --- constructors that are 'SimpleMergeable' when applied to any 'Mergeable' --- types. --- --- This type class is used to generalize the 'mrgIf' function to other --- containers, for example, monad transformer transformed Unions. -class (SimpleMergeable1 u, Mergeable1 u) => UnionLike u where - -- | Wrap a single value in the union. - -- - -- Note that this function cannot propagate the 'Mergeable' knowledge. - -- - -- >>> single "a" :: UnionM SymInteger - -- - -- >>> mrgSingle "a" :: UnionM SymInteger - -- {a} - single :: a -> u a - - -- | If-then-else on two union values. - -- - -- Note that this function cannot capture the 'Mergeable' knowledge. However, - -- it may use the merging strategy from the branches to merge the results. - -- - -- >>> unionIf "a" (single "b") (single "c") :: UnionM SymInteger - -- - -- >>> unionIf "a" (mrgSingle "b") (single "c") :: UnionM SymInteger - -- {(ite a b c)} - unionIf :: SymBool -> u a -> u a -> u a - - -- | Merge the contents with some merge strategy. - -- - -- >>> mergeWithStrategy rootStrategy $ unionIf "a" (single "b") (single "c") :: UnionM SymInteger - -- {(ite a b c)} - -- - -- __Note:__ Be careful to call this directly in your code. - -- The supplied merge strategy should be consistent with the type's root merge strategy, - -- or some internal invariants would be broken and the program can crash. - -- - -- This function is to be called when the 'Mergeable' constraint can not be resolved, - -- e.g., the merge strategy for the contained type is given with 'Mergeable1'. - -- In other cases, 'merge' is usually a better alternative. - mergeWithStrategy :: MergingStrategy a -> u a -> u a - - -- | Symbolic @if@ control flow with the result merged with some merge strategy. - -- - -- >>> mrgIfWithStrategy rootStrategy "a" (mrgSingle "b") (single "c") :: UnionM SymInteger - -- {(ite a b c)} - -- - -- __Note:__ Be careful to call this directly in your code. - -- The supplied merge strategy should be consistent with the type's root merge strategy, - -- or some internal invariants would be broken and the program can crash. - -- - -- This function is to be called when the 'Mergeable' constraint can not be resolved, - -- e.g., the merge strategy for the contained type is given with 'Mergeable1'. - -- In other cases, 'mrgIf' is usually a better alternative. - mrgIfWithStrategy :: MergingStrategy a -> SymBool -> u a -> u a -> u a - mrgIfWithStrategy s cond l r = mergeWithStrategy s $ unionIf cond l r - {-# INLINE mrgIfWithStrategy #-} - - -- | Wrap a single value in the union and capture the 'Mergeable' knowledge. - -- - -- >>> mrgSingleWithStrategy rootStrategy "a" :: UnionM SymInteger - -- {a} - -- - -- __Note:__ Be careful to call this directly in your code. - -- The supplied merge strategy should be consistent with the type's root merge strategy, - -- or some internal invariants would be broken and the program can crash. - -- - -- This function is to be called when the 'Mergeable' constraint can not be resolved, - -- e.g., the merge strategy for the contained type is given with 'Mergeable1'. - -- In other cases, 'mrgSingle' is usually a better alternative. - mrgSingleWithStrategy :: MergingStrategy a -> a -> u a - mrgSingleWithStrategy s = mergeWithStrategy s . single - {-# INLINE mrgSingleWithStrategy #-} - --- | Symbolic @if@ control flow with the result merged with the type's root merge strategy. --- --- Equivalent to @'mrgIfWithStrategy' 'rootStrategy'@. --- --- >>> mrgIf "a" (single "b") (single "c") :: UnionM SymInteger --- {(ite a b c)} -mrgIf :: (UnionLike u, Mergeable a) => SymBool -> u a -> u a -> u a -mrgIf = mrgIfWithStrategy rootStrategy -{-# INLINE mrgIf #-} - --- | Merge the contents with the type's root merge strategy. --- --- Equivalent to @'mergeWithStrategy' 'rootStrategy'@. --- --- >>> merge $ unionIf "a" (single "b") (single "c") :: UnionM SymInteger --- {(ite a b c)} -merge :: (UnionLike u, Mergeable a) => u a -> u a -merge = mergeWithStrategy rootStrategy -{-# INLINE merge #-} - --- | Wrap a single value in the type and propagate the type's root merge strategy. --- --- Equivalent to @'mrgSingleWithStrategy' 'rootStrategy'@. --- --- >>> mrgSingle "a" :: UnionM SymInteger --- {a} -mrgSingle :: (UnionLike u, Mergeable a) => a -> u a -mrgSingle = mrgSingleWithStrategy rootStrategy -{-# INLINE mrgSingle #-} - -instance SimpleMergeable () where - mrgIte _ t _ = t - {-# INLINE mrgIte #-} - -instance (SimpleMergeable a, SimpleMergeable b) => SimpleMergeable (a, b) where - mrgIte cond (a1, b1) (a2, b2) = (mrgIte cond a1 a2, mrgIte cond b1 b2) - {-# INLINE mrgIte #-} - -instance (SimpleMergeable a) => SimpleMergeable1 ((,) a) where - liftMrgIte mb cond (a1, b1) (a2, b2) = (mrgIte cond a1 a2, mb cond b1 b2) - {-# INLINE liftMrgIte #-} - -instance SimpleMergeable2 (,) where - liftMrgIte2 ma mb cond (a1, b1) (a2, b2) = (ma cond a1 a2, mb cond b1 b2) - {-# INLINE liftMrgIte2 #-} - -instance - (SimpleMergeable a, SimpleMergeable b, SimpleMergeable c) => - SimpleMergeable (a, b, c) - where - mrgIte cond (a1, b1, c1) (a2, b2, c2) = (mrgIte cond a1 a2, mrgIte cond b1 b2, mrgIte cond c1 c2) - {-# INLINE mrgIte #-} - -instance - ( SimpleMergeable a, - SimpleMergeable b, - SimpleMergeable c, - SimpleMergeable d - ) => - SimpleMergeable (a, b, c, d) - where - mrgIte cond (a1, b1, c1, d1) (a2, b2, c2, d2) = - (mrgIte cond a1 a2, mrgIte cond b1 b2, mrgIte cond c1 c2, mrgIte cond d1 d2) - {-# INLINE mrgIte #-} - -instance - ( SimpleMergeable a, - SimpleMergeable b, - SimpleMergeable c, - SimpleMergeable d, - SimpleMergeable e - ) => - SimpleMergeable (a, b, c, d, e) - where - mrgIte cond (a1, b1, c1, d1, e1) (a2, b2, c2, d2, e2) = - (mrgIte cond a1 a2, mrgIte cond b1 b2, mrgIte cond c1 c2, mrgIte cond d1 d2, mrgIte cond e1 e2) - {-# INLINE mrgIte #-} - -instance - ( SimpleMergeable a, - SimpleMergeable b, - SimpleMergeable c, - SimpleMergeable d, - SimpleMergeable e, - SimpleMergeable f - ) => - SimpleMergeable (a, b, c, d, e, f) - where - mrgIte cond (a1, b1, c1, d1, e1, f1) (a2, b2, c2, d2, e2, f2) = - (mrgIte cond a1 a2, mrgIte cond b1 b2, mrgIte cond c1 c2, mrgIte cond d1 d2, mrgIte cond e1 e2, mrgIte cond f1 f2) - {-# INLINE mrgIte #-} - -instance - ( SimpleMergeable a, - SimpleMergeable b, - SimpleMergeable c, - SimpleMergeable d, - SimpleMergeable e, - SimpleMergeable f, - SimpleMergeable g - ) => - SimpleMergeable (a, b, c, d, e, f, g) - where - mrgIte cond (a1, b1, c1, d1, e1, f1, g1) (a2, b2, c2, d2, e2, f2, g2) = - ( mrgIte cond a1 a2, - mrgIte cond b1 b2, - mrgIte cond c1 c2, - mrgIte cond d1 d2, - mrgIte cond e1 e2, - mrgIte cond f1 f2, - mrgIte cond g1 g2 - ) - {-# INLINE mrgIte #-} - -instance - ( SimpleMergeable a, - SimpleMergeable b, - SimpleMergeable c, - SimpleMergeable d, - SimpleMergeable e, - SimpleMergeable f, - SimpleMergeable g, - SimpleMergeable h - ) => - SimpleMergeable (a, b, c, d, e, f, g, h) - where - mrgIte cond (a1, b1, c1, d1, e1, f1, g1, h1) (a2, b2, c2, d2, e2, f2, g2, h2) = - ( mrgIte cond a1 a2, - mrgIte cond b1 b2, - mrgIte cond c1 c2, - mrgIte cond d1 d2, - mrgIte cond e1 e2, - mrgIte cond f1 f2, - mrgIte cond g1 g2, - mrgIte cond h1 h2 - ) - {-# INLINE mrgIte #-} - -instance (SimpleMergeable b) => SimpleMergeable (a -> b) where - mrgIte = mrgIte1 - {-# INLINE mrgIte #-} - -instance SimpleMergeable1 ((->) a) where - liftMrgIte ms cond t f v = ms cond (t v) (f v) - {-# INLINE liftMrgIte #-} - -instance (UnionLike m, Mergeable a) => SimpleMergeable (MaybeT m a) where - mrgIte = mrgIf - {-# INLINE mrgIte #-} - -instance (UnionLike m) => SimpleMergeable1 (MaybeT m) where - liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) - {-# INLINE liftMrgIte #-} - -instance (UnionLike m) => UnionLike (MaybeT m) where - mergeWithStrategy s (MaybeT v) = MaybeT $ mergeWithStrategy (liftRootStrategy s) v - {-# INLINE mergeWithStrategy #-} - mrgIfWithStrategy s cond (MaybeT t) (MaybeT f) = MaybeT $ mrgIfWithStrategy (liftRootStrategy s) cond t f - {-# INLINE mrgIfWithStrategy #-} - single = MaybeT . single . return - {-# INLINE single #-} - unionIf cond (MaybeT l) (MaybeT r) = MaybeT $ unionIf cond l r - {-# INLINE unionIf #-} - -instance - (UnionLike m, Mergeable e, Mergeable a) => - SimpleMergeable (ExceptT e m a) - where - mrgIte = mrgIf - {-# INLINE mrgIte #-} - -instance - (UnionLike m, Mergeable e) => - SimpleMergeable1 (ExceptT e m) - where - liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) - {-# INLINE liftMrgIte #-} - -instance - (UnionLike m, Mergeable e) => - UnionLike (ExceptT e m) - where - mergeWithStrategy s (ExceptT v) = ExceptT $ mergeWithStrategy (liftRootStrategy s) v - {-# INLINE mergeWithStrategy #-} - mrgIfWithStrategy s cond (ExceptT t) (ExceptT f) = ExceptT $ mrgIfWithStrategy (liftRootStrategy s) cond t f - {-# INLINE mrgIfWithStrategy #-} - single = ExceptT . single . return - {-# INLINE single #-} - unionIf cond (ExceptT l) (ExceptT r) = ExceptT $ unionIf cond l r - {-# INLINE unionIf #-} - -instance - (Mergeable s, Mergeable a, UnionLike m) => - SimpleMergeable (StateLazy.StateT s m a) - where - mrgIte = mrgIf - {-# INLINE mrgIte #-} - -instance - (Mergeable s, UnionLike m) => - SimpleMergeable1 (StateLazy.StateT s m) - where - liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) - {-# INLINE liftMrgIte #-} - -instance - (Mergeable s, UnionLike m) => - UnionLike (StateLazy.StateT s m) - where - mergeWithStrategy ms (StateLazy.StateT f) = - StateLazy.StateT $ \v -> mergeWithStrategy (liftRootStrategy2 ms rootStrategy) $ f v - {-# INLINE mergeWithStrategy #-} - mrgIfWithStrategy s cond (StateLazy.StateT t) (StateLazy.StateT f) = - StateLazy.StateT $ \v -> mrgIfWithStrategy (liftRootStrategy2 s rootStrategy) cond (t v) (f v) - {-# INLINE mrgIfWithStrategy #-} - single x = StateLazy.StateT $ \s -> single (x, s) - {-# INLINE single #-} - unionIf cond (StateLazy.StateT l) (StateLazy.StateT r) = - StateLazy.StateT $ \s -> unionIf cond (l s) (r s) - {-# INLINE unionIf #-} - -instance - (Mergeable s, Mergeable a, UnionLike m) => - SimpleMergeable (StateStrict.StateT s m a) - where - mrgIte = mrgIf - {-# INLINE mrgIte #-} - -instance - (Mergeable s, UnionLike m) => - SimpleMergeable1 (StateStrict.StateT s m) - where - liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) - {-# INLINE liftMrgIte #-} - -instance - (Mergeable s, UnionLike m) => - UnionLike (StateStrict.StateT s m) - where - mergeWithStrategy ms (StateStrict.StateT f) = - StateStrict.StateT $ \v -> mergeWithStrategy (liftRootStrategy2 ms rootStrategy) $ f v - {-# INLINE mergeWithStrategy #-} - mrgIfWithStrategy s cond (StateStrict.StateT t) (StateStrict.StateT f) = - StateStrict.StateT $ \v -> mrgIfWithStrategy (liftRootStrategy2 s rootStrategy) cond (t v) (f v) - {-# INLINE mrgIfWithStrategy #-} - single x = StateStrict.StateT $ \s -> single (x, s) - {-# INLINE single #-} - unionIf cond (StateStrict.StateT l) (StateStrict.StateT r) = - StateStrict.StateT $ \s -> unionIf cond (l s) (r s) - {-# INLINE unionIf #-} - -instance - (Mergeable s, Mergeable a, UnionLike m, Monoid s) => - SimpleMergeable (WriterLazy.WriterT s m a) - where - mrgIte = mrgIf - {-# INLINE mrgIte #-} - -instance - (Mergeable s, UnionLike m, Monoid s) => - SimpleMergeable1 (WriterLazy.WriterT s m) - where - liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) - {-# INLINE liftMrgIte #-} - -instance - (Mergeable s, UnionLike m, Monoid s) => - UnionLike (WriterLazy.WriterT s m) - where - mergeWithStrategy ms (WriterLazy.WriterT f) = WriterLazy.WriterT $ mergeWithStrategy (liftRootStrategy2 ms rootStrategy) f - {-# INLINE mergeWithStrategy #-} - mrgIfWithStrategy s cond (WriterLazy.WriterT t) (WriterLazy.WriterT f) = - WriterLazy.WriterT $ mrgIfWithStrategy (liftRootStrategy2 s rootStrategy) cond t f - {-# INLINE mrgIfWithStrategy #-} - single x = WriterLazy.WriterT $ single (x, mempty) - {-# INLINE single #-} - unionIf cond (WriterLazy.WriterT l) (WriterLazy.WriterT r) = - WriterLazy.WriterT $ unionIf cond l r - {-# INLINE unionIf #-} - -instance - (Mergeable s, Mergeable a, UnionLike m, Monoid s) => - SimpleMergeable (WriterStrict.WriterT s m a) - where - mrgIte = mrgIf - {-# INLINE mrgIte #-} - -instance - (Mergeable s, UnionLike m, Monoid s) => - SimpleMergeable1 (WriterStrict.WriterT s m) - where - liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) - {-# INLINE liftMrgIte #-} - -instance - (Mergeable s, UnionLike m, Monoid s) => - UnionLike (WriterStrict.WriterT s m) - where - mergeWithStrategy ms (WriterStrict.WriterT f) = WriterStrict.WriterT $ mergeWithStrategy (liftRootStrategy2 ms rootStrategy) f - {-# INLINE mergeWithStrategy #-} - mrgIfWithStrategy s cond (WriterStrict.WriterT t) (WriterStrict.WriterT f) = - WriterStrict.WriterT $ mrgIfWithStrategy (liftRootStrategy2 s rootStrategy) cond t f - {-# INLINE mrgIfWithStrategy #-} - single x = WriterStrict.WriterT $ single (x, mempty) - {-# INLINE single #-} - unionIf cond (WriterStrict.WriterT l) (WriterStrict.WriterT r) = - WriterStrict.WriterT $ unionIf cond l r - {-# INLINE unionIf #-} - -instance - (Mergeable a, UnionLike m) => - SimpleMergeable (ReaderT s m a) - where - mrgIte = mrgIf - {-# INLINE mrgIte #-} - -instance - (UnionLike m) => - SimpleMergeable1 (ReaderT s m) - where - liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) - {-# INLINE liftMrgIte #-} - -instance - (UnionLike m) => - UnionLike (ReaderT s m) - where - mergeWithStrategy ms (ReaderT f) = ReaderT $ \v -> mergeWithStrategy ms $ f v - {-# INLINE mergeWithStrategy #-} - mrgIfWithStrategy s cond (ReaderT t) (ReaderT f) = - ReaderT $ \v -> mrgIfWithStrategy s cond (t v) (f v) - {-# INLINE mrgIfWithStrategy #-} - single x = ReaderT $ \_ -> single x - {-# INLINE single #-} - unionIf cond (ReaderT l) (ReaderT r) = ReaderT $ \s -> unionIf cond (l s) (r s) - {-# INLINE unionIf #-} - -instance (SimpleMergeable a) => SimpleMergeable (Identity a) where - mrgIte cond (Identity l) (Identity r) = Identity $ mrgIte cond l r - {-# INLINE mrgIte #-} - -instance SimpleMergeable1 Identity where - liftMrgIte mite cond (Identity l) (Identity r) = Identity $ mite cond l r - {-# INLINE liftMrgIte #-} - -instance (UnionLike m, Mergeable a) => SimpleMergeable (IdentityT m a) where - mrgIte = mrgIf - {-# INLINE mrgIte #-} - -instance (UnionLike m) => SimpleMergeable1 (IdentityT m) where - liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) - {-# INLINE liftMrgIte #-} - -instance (UnionLike m) => UnionLike (IdentityT m) where - mergeWithStrategy ms (IdentityT f) = - IdentityT $ mergeWithStrategy ms f - {-# INLINE mergeWithStrategy #-} - mrgIfWithStrategy s cond (IdentityT l) (IdentityT r) = IdentityT $ mrgIfWithStrategy s cond l r - {-# INLINE mrgIfWithStrategy #-} - single x = IdentityT $ single x - {-# INLINE single #-} - unionIf cond (IdentityT l) (IdentityT r) = IdentityT $ unionIf cond l r - {-# INLINE unionIf #-} - -instance (UnionLike m, Mergeable r) => SimpleMergeable (ContT r m a) where - mrgIte cond (ContT l) (ContT r) = ContT $ \c -> mrgIf cond (l c) (r c) - {-# INLINE mrgIte #-} - -instance (UnionLike m, Mergeable r) => SimpleMergeable1 (ContT r m) where - liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) - {-# INLINE liftMrgIte #-} - -instance (UnionLike m, Mergeable r) => UnionLike (ContT r m) where - mergeWithStrategy _ (ContT f) = ContT $ \c -> merge (f c) - {-# INLINE mergeWithStrategy #-} - mrgIfWithStrategy _ cond (ContT l) (ContT r) = ContT $ \c -> mrgIf cond (l c) (r c) - {-# INLINE mrgIfWithStrategy #-} - single x = ContT $ \c -> c x - {-# INLINE single #-} - unionIf cond (ContT l) (ContT r) = ContT $ \c -> unionIf cond (l c) (r c) - {-# INLINE unionIf #-} - -instance - (Mergeable s, Mergeable w, Monoid w, Mergeable a, UnionLike m) => - SimpleMergeable (RWSLazy.RWST r w s m a) - where - mrgIte = mrgIf - {-# INLINE mrgIte #-} - -instance - (Mergeable s, Mergeable w, Monoid w, UnionLike m) => - SimpleMergeable1 (RWSLazy.RWST r w s m) - where - liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) - {-# INLINE liftMrgIte #-} - -instance - (Mergeable s, Mergeable w, Monoid w, UnionLike m) => - UnionLike (RWSLazy.RWST r w s m) - where - mergeWithStrategy ms (RWSLazy.RWST f) = - RWSLazy.RWST $ \r s -> mergeWithStrategy (liftRootStrategy3 ms rootStrategy rootStrategy) $ f r s - {-# INLINE mergeWithStrategy #-} - mrgIfWithStrategy ms cond (RWSLazy.RWST t) (RWSLazy.RWST f) = - RWSLazy.RWST $ \r s -> mrgIfWithStrategy (liftRootStrategy3 ms rootStrategy rootStrategy) cond (t r s) (f r s) - {-# INLINE mrgIfWithStrategy #-} - single x = RWSLazy.RWST $ \_ s -> single (x, s, mempty) - {-# INLINE single #-} - unionIf cond (RWSLazy.RWST t) (RWSLazy.RWST f) = - RWSLazy.RWST $ \r s -> unionIf cond (t r s) (f r s) - {-# INLINE unionIf #-} - -instance - (Mergeable s, Mergeable w, Monoid w, Mergeable a, UnionLike m) => - SimpleMergeable (RWSStrict.RWST r w s m a) - where - mrgIte = mrgIf - {-# INLINE mrgIte #-} - -instance - (Mergeable s, Mergeable w, Monoid w, UnionLike m) => - SimpleMergeable1 (RWSStrict.RWST r w s m) - where - liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) - {-# INLINE liftMrgIte #-} - -instance - (Mergeable s, Mergeable w, Monoid w, UnionLike m) => - UnionLike (RWSStrict.RWST r w s m) - where - mergeWithStrategy ms (RWSStrict.RWST f) = - RWSStrict.RWST $ \r s -> mergeWithStrategy (liftRootStrategy3 ms rootStrategy rootStrategy) $ f r s - {-# INLINE mergeWithStrategy #-} - mrgIfWithStrategy ms cond (RWSStrict.RWST t) (RWSStrict.RWST f) = - RWSStrict.RWST $ \r s -> mrgIfWithStrategy (liftRootStrategy3 ms rootStrategy rootStrategy) cond (t r s) (f r s) - {-# INLINE mrgIfWithStrategy #-} - single x = RWSStrict.RWST $ \_ s -> single (x, s, mempty) - {-# INLINE single #-} - unionIf cond (RWSStrict.RWST t) (RWSStrict.RWST f) = - RWSStrict.RWST $ \r s -> unionIf cond (t r s) (f r s) - {-# INLINE unionIf #-} - --- | Union containers that can be projected back into single value or --- if-guarded values. -class (UnionLike u) => UnionPrjOp (u :: Type -> Type) where - -- | Pattern match to extract single values. - -- - -- >>> singleView (single 1 :: UnionM Integer) - -- Just 1 - -- >>> singleView (unionIf "a" (single 1) (single 2) :: UnionM Integer) - -- Nothing - singleView :: u a -> Maybe a - - -- | Pattern match to extract if values. - -- - -- >>> ifView (single 1 :: UnionM Integer) - -- Nothing - -- >>> ifView (unionIf "a" (single 1) (single 2) :: UnionM Integer) - -- Just (a,<1>,<2>) - -- >>> ifView (mrgIf "a" (single 1) (single 2) :: UnionM Integer) - -- Just (a,{1},{2}) - ifView :: u a -> Maybe (SymBool, u a, u a) - - -- | The leftmost value in the union. - -- - -- >>> leftMost (unionIf "a" (single 1) (single 2) :: UnionM Integer) - -- 1 - leftMost :: u a -> a - - -- | Convert the union to a guarded list. - -- - -- >>> toGuardedList (mrgIf "a" (single 1) (mrgIf "b" (single 2) (single 3)) :: UnionM Integer) - -- [(a,1),((&& b (! a)),2),((! (|| b a)),3)] - toGuardedList :: u a -> [(SymBool, a)] - toGuardedList u = - case (singleView u, ifView u) of - (Just x, _) -> [(con True, x)] - (_, Just (c, l, r)) -> - fmap (first (.&& c)) (toGuardedList l) - ++ fmap (first (.&& symNot c)) (toGuardedList r) - _ -> error "Should not happen" - --- | Pattern match to extract single values with 'singleView'. --- --- >>> case (single 1 :: UnionM Integer) of Single v -> v --- 1 -pattern Single :: (UnionPrjOp u, Mergeable a) => a -> u a -pattern Single x <- - (singleView -> Just x) - where - Single x = mrgSingle x - --- | Pattern match to extract guard values with 'ifView' --- >>> case (unionIf "a" (single 1) (single 2) :: UnionM Integer) of If c t f -> (c,t,f) --- (a,<1>,<2>) -pattern If :: (UnionPrjOp u, Mergeable a) => SymBool -> u a -> u a -> u a -pattern If c t f <- - (ifView -> Just (c, t, f)) - where - If c t f = unionIf c t f - --- | Merge the simply mergeable values in a union, and extract the merged value. --- --- In the following example, 'unionIf' will not merge the results, and --- 'simpleMerge' will merge it and extract the single merged value. --- --- >>> unionIf (ssym "a") (return $ ssym "b") (return $ ssym "c") :: UnionM SymBool --- --- >>> simpleMerge $ (unionIf (ssym "a") (return $ ssym "b") (return $ ssym "c") :: UnionM SymBool) --- (ite a b c) -simpleMerge :: forall u a. (SimpleMergeable a, UnionLike u, UnionPrjOp u) => u a -> a -simpleMerge u = case merge u of - Single x -> x - _ -> error "Should not happen" -{-# INLINE simpleMerge #-} - --- | Lift a function to work on union values. --- --- >>> sumU = onUnion sum --- >>> sumU (unionIf "cond" (return ["a"]) (return ["b","c"]) :: UnionM [SymInteger]) --- (ite cond a (+ b c)) -onUnion :: - forall u a r. - (SimpleMergeable r, UnionLike u, UnionPrjOp u, Monad u) => - (a -> r) -> - (u a -> r) -onUnion f = simpleMerge . fmap f - --- | Lift a function to work on union values. -onUnion2 :: - forall u a b r. - (SimpleMergeable r, UnionLike u, UnionPrjOp u, Monad u) => - (a -> b -> r) -> - (u a -> u b -> r) -onUnion2 f ua ub = simpleMerge $ f <$> ua <*> ub - --- | Lift a function to work on union values. -onUnion3 :: - forall u a b c r. - (SimpleMergeable r, UnionLike u, UnionPrjOp u, Monad u) => - (a -> b -> c -> r) -> - (u a -> u b -> u c -> r) -onUnion3 f ua ub uc = simpleMerge $ f <$> ua <*> ub <*> uc - --- | Lift a function to work on union values. -onUnion4 :: - forall u a b c d r. - (SimpleMergeable r, UnionLike u, UnionPrjOp u, Monad u) => - (a -> b -> c -> d -> r) -> - (u a -> u b -> u c -> u d -> r) -onUnion4 f ua ub uc ud = simpleMerge $ f <$> ua <*> ub <*> uc <*> ud - --- | Helper for applying functions on 'UnionPrjOp' and 'SimpleMergeable'. --- --- >>> let f :: Integer -> UnionM Integer = \x -> mrgIf (ssym "a") (mrgSingle $ x + 1) (mrgSingle $ x + 2) --- >>> f .# (mrgIf (ssym "b" :: SymBool) (mrgSingle 0) (mrgSingle 2) :: UnionM Integer) --- {If (&& b a) 1 (If b 2 (If a 3 4))} -(.#) :: - (Function f, SimpleMergeable (Ret f), UnionPrjOp u, Functor u) => - f -> - u (Arg f) -> - Ret f -(.#) f u = simpleMerge $ fmap (f #) u -{-# INLINE (.#) #-} - -infixl 9 .# - -#define SIMPLE_MERGEABLE_SIMPLE(symtype) \ -instance SimpleMergeable symtype where \ - mrgIte = symIte; \ - {-# INLINE mrgIte #-} - -#define SIMPLE_MERGEABLE_BV(symtype) \ -instance (KnownNat n, 1 <= n) => SimpleMergeable (symtype n) where \ - mrgIte = symIte; \ - {-# INLINE mrgIte #-} - -#define SIMPLE_MERGEABLE_FUN(op) \ -instance (SupportedPrim ca, SupportedPrim cb, LinkedRep ca sa, LinkedRep cb sb) => SimpleMergeable (sa op sb) where \ - mrgIte = symIte; \ - {-# INLINE mrgIte #-} - -#if 1 -SIMPLE_MERGEABLE_SIMPLE(SymBool) -SIMPLE_MERGEABLE_SIMPLE(SymInteger) -SIMPLE_MERGEABLE_BV(SymIntN) -SIMPLE_MERGEABLE_BV(SymWordN) -SIMPLE_MERGEABLE_FUN(=~>) -SIMPLE_MERGEABLE_FUN(-~>) -#endif - --- Exception -deriving via (Default AssertionError) instance SimpleMergeable AssertionError diff --git a/src/Grisette/Core/Data/Class/Solvable.hs b/src/Grisette/Core/Data/Class/Solvable.hs deleted file mode 100644 --- a/src/Grisette/Core/Data/Class/Solvable.hs +++ /dev/null @@ -1,107 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} - --- | --- Module : Grisette.Core.Data.Class.Solvable --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Core.Data.Class.Solvable - ( -- * Solvable type interface - Solvable (..), - pattern Con, - ) -where - -import Control.DeepSeq (NFData) -import Data.Hashable (Hashable) -import Data.String (IsString) -import qualified Data.Text as T -import Data.Typeable (Typeable) -import Language.Haskell.TH.Syntax (Lift) - --- $setup --- >>> import Grisette.Core --- >>> import Grisette.IR.SymPrim --- >>> :set -XOverloadedStrings - --- | The class defines the creation and pattern matching of solvable type --- values. -class (IsString t) => Solvable c t | t -> c where - -- | Wrap a concrete value in a symbolic value. - -- - -- >>> con True :: SymBool - -- true - con :: c -> t - - -- | Extract the concrete value from a symbolic value. - -- - -- >>> conView (con True :: SymBool) - -- Just True - -- - -- >>> conView (ssym "a" :: SymBool) - -- Nothing - conView :: t -> Maybe c - - -- | Generate simply-named symbolic constants. - -- - -- Two symbolic constants with the same name are the same symbolic constant, - -- and will always be assigned with the same value by the solver. - -- - -- >>> ssym "a" :: SymBool - -- a - -- >>> (ssym "a" :: SymBool) == ssym "a" - -- True - -- >>> (ssym "a" :: SymBool) == ssym "b" - -- False - -- >>> (ssym "a" :: SymBool) .&& ssym "a" - -- a - ssym :: T.Text -> t - - -- | Generate indexed symbolic constants. - -- - -- Two symbolic constants with the same name but different indices are - -- not the same symbolic constants. - -- - -- >>> isym "a" 1 :: SymBool - -- a@1 - isym :: T.Text -> Int -> t - - -- | Generate simply-named symbolic constants with some extra information for - -- disambiguation. - -- - -- Two symbolic constants with the same name but different extra information - -- (including info with different types) are considered to be different. - -- - -- >>> sinfosym "a" "someInfo" :: SymInteger - -- a:"someInfo" - sinfosym :: (Typeable a, Ord a, Lift a, NFData a, Show a, Hashable a) => T.Text -> a -> t - - -- | Generate indexed symbolic constants with some extra information for - -- disambiguation. - -- - -- Two symbolic constants with the same name and index but different extra - -- information (including info with different types) are considered to be - -- different. - -- - -- >>> iinfosym "a" 1 "someInfo" :: SymInteger - -- a@1:"someInfo" - iinfosym :: (Typeable a, Ord a, Lift a, NFData a, Show a, Hashable a) => T.Text -> Int -> a -> t - --- | Extract the concrete value from a solvable value with 'conView'. --- --- >>> case con True :: SymBool of Con v -> v --- True -pattern Con :: (Solvable c t) => c -> t -pattern Con c <- - (conView -> Just c) - where - Con c = con c diff --git a/src/Grisette/Core/Data/Class/Solver.hs b/src/Grisette/Core/Data/Class/Solver.hs deleted file mode 100644 --- a/src/Grisette/Core/Data/Class/Solver.hs +++ /dev/null @@ -1,288 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- Module : Grisette.Core.Data.Class.Solver --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Core.Data.Class.Solver - ( -- * Note for the examples - - -- - - -- | The examples assumes that the [z3](https://github.com/Z3Prover/z3) - -- solver is available in @PATH@. - - -- * Solver interfaces - SolvingFailure (..), - MonadicSolver (..), - SolverCommand (..), - ConfigurableSolver (..), - Solver (..), - withSolver, - solve, - solveMulti, - - -- * Union with exceptions - UnionWithExcept (..), - solveExcept, - solveMultiExcept, - ) -where - -import Control.DeepSeq (NFData) -import Control.Exception (SomeException, bracket) -import Control.Monad.Except (ExceptT, runExceptT) -import qualified Data.HashSet as S -import Data.Hashable (Hashable) -import Data.Maybe (fromJust) -import GHC.Generics (Generic) -import Grisette.Core.Data.Class.ExtractSymbolics - ( ExtractSymbolics (extractSymbolics), - ) -import Grisette.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.||))) -import Grisette.Core.Data.Class.SimpleMergeable - ( UnionPrjOp, - simpleMerge, - ) -import Grisette.Core.Data.Class.Solvable (Solvable (con)) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term - ( SomeTypedSymbol (SomeTypedSymbol), - ) -import Grisette.IR.SymPrim.Data.Prim.Model - ( Model, - SymbolSet (unSymbolSet), - equation, - ) -import Grisette.IR.SymPrim.Data.SymPrim (SymBool (SymBool)) -import Language.Haskell.TH.Syntax (Lift) - -data SolveInternal = SolveInternal - deriving (Eq, Show, Ord, Generic, Hashable, Lift, NFData) - --- $setup --- >>> import Grisette.Core --- >>> import Grisette.IR.SymPrim --- >>> import Grisette.Backend.SBV --- >>> :set -XOverloadedStrings - --- | The current failures that can be returned by the solver. -data SolvingFailure - = -- | Unsatisfiable: No model is available. - Unsat - | -- | Unknown: The solver cannot determine whether the formula is - -- satisfiable. - Unk - | -- | The solver has reached the maximum number of models to return. - ResultNumLimitReached - | -- | The solver has encountered an error. - SolvingError SomeException - | -- | The solver has been terminated. - Terminated - deriving (Show) - --- | A monadic solver interface. --- --- This interface abstract the monadic interface of a solver. All the operations --- performed in the monad are using a single solver instance. The solver --- instance is management by the monad's @run@ function. -class MonadicSolver m where - monadicSolverPush :: Int -> m () - monadicSolverPop :: Int -> m () - monadicSolverSolve :: SymBool -> m (Either SolvingFailure Model) - --- | The commands that can be sent to a solver. -data SolverCommand - = SolverSolve SymBool - | SolverPush Int - | SolverPop Int - | SolverTerminate - --- | A class that abstracts the solver interface. -class Solver handle where - -- | Run a solver command. - solverRunCommand :: - (handle -> IO (Either SolvingFailure a)) -> - handle -> - SolverCommand -> - IO (Either SolvingFailure a) - - -- | Solve a formula. - solverSolve :: handle -> SymBool -> IO (Either SolvingFailure Model) - - -- | Push @n@ levels. - solverPush :: handle -> Int -> IO (Either SolvingFailure ()) - solverPush handle n = - solverRunCommand (const $ return $ Right ()) handle $ SolverPush n - - -- | Pop @n@ levels. - solverPop :: handle -> Int -> IO (Either SolvingFailure ()) - solverPop handle n = - solverRunCommand (const $ return $ Right ()) handle $ SolverPop n - - -- | Terminate the solver, wait until the last command is finished. - solverTerminate :: handle -> IO () - - -- | Force terminate the solver, do not wait for the last command to finish. - solverForceTerminate :: handle -> IO () - --- | A class that abstracts the creation of a solver instance based on a --- configuration. --- --- The solver instance will need to be terminated by the user, with the solver --- interface. -class - (Solver handle) => - ConfigurableSolver config handle - | config -> handle - where - newSolver :: config -> IO handle - --- | Start a solver, run a computation with the solver, and terminate the --- solver after the computation finishes. -withSolver :: - (ConfigurableSolver config handle) => - config -> - (handle -> IO a) -> - IO a -withSolver config = bracket (newSolver config) solverTerminate - --- | Solve a single formula. Find an assignment to it to make it true. --- --- >>> solve (precise z3) ("a" .&& ("b" :: SymInteger) .== 1) --- Right (Model {a -> True :: Bool, b -> 1 :: Integer}) --- >>> solve (precise z3) ("a" .&& symNot "a") --- Left Unsat -solve :: - (ConfigurableSolver config handle) => - -- | solver configuration - config -> - -- | formula to solve, the solver will try to make it true - SymBool -> - IO (Either SolvingFailure Model) -solve config formula = withSolver config (`solverSolve` formula) - --- | Solve a single formula while returning multiple models to make it true. --- The maximum number of desired models are given. --- --- > >>> solveMulti (precise z3) 4 ("a" .|| "b") --- > [Model {a -> True :: Bool, b -> False :: Bool},Model {a -> False :: Bool, b -> True :: Bool},Model {a -> True :: Bool, b -> True :: Bool}] -solveMulti :: - (ConfigurableSolver config handle) => - -- | solver configuration - config -> - -- | maximum number of models to return - Int -> - -- | formula to solve, the solver will try to make it true - SymBool -> - IO ([Model], SolvingFailure) -solveMulti config numOfModelRequested formula = - withSolver config $ \solver -> do - firstModel <- solverSolve solver formula - case firstModel of - Left err -> return ([], err) - Right model -> do - (models, err) <- go solver model numOfModelRequested - return (model : models, err) - where - allSymbols = extractSymbolics formula :: SymbolSet - go solver prevModel n - | n <= 1 = return ([], ResultNumLimitReached) - | otherwise = do - let newFormula = - S.foldl' - ( \acc (SomeTypedSymbol _ v) -> - acc - .|| (symNot (SymBool $ fromJust $ equation v prevModel)) - ) - (con False) - (unSymbolSet allSymbols) - res <- solverSolve solver newFormula - case res of - Left err -> return ([], err) - Right model -> do - (models, err) <- go solver model (n - 1) - return (model : models, err) - --- | A class that abstracts the union-like structures that contains exceptions. -class UnionWithExcept t u e v | t -> u e v where - -- | Extract a union of exceptions and values from the structure. - extractUnionExcept :: t -> u (Either e v) - -instance UnionWithExcept (ExceptT e u v) u e v where - extractUnionExcept = runExceptT - --- | --- Solver procedure for programs with error handling. --- --- >>> :set -XLambdaCase --- >>> import Control.Monad.Except --- >>> let x = "x" :: SymInteger --- >>> :{ --- res :: ExceptT AssertionError UnionM () --- res = do --- symAssert $ x .> 0 -- constrain that x is positive --- symAssert $ x .< 2 -- constrain that x is less than 2 --- :} --- --- >>> :{ --- translate (Left _) = con False -- errors are not desirable --- translate _ = con True -- non-errors are desirable --- :} --- --- >>> solveExcept (precise z3) translate res --- Right (Model {x -> 1 :: Integer}) -solveExcept :: - ( UnionWithExcept t u e v, - UnionPrjOp u, - Functor u, - ConfigurableSolver config handle - ) => - -- | solver configuration - config -> - -- | mapping the results to symbolic boolean formulas, the solver would try to - -- find a model to make the formula true - (Either e v -> SymBool) -> - -- | the program to be solved, should be a union of exception and values - t -> - IO (Either SolvingFailure Model) -solveExcept config f v = solve config (simpleMerge $ f <$> extractUnionExcept v) - --- | --- Solver procedure for programs with error handling. Would return multiple --- models if possible. -solveMultiExcept :: - ( UnionWithExcept t u e v, - UnionPrjOp u, - Functor u, - ConfigurableSolver config handle - ) => - -- | solver configuration - config -> - -- | maximum number of models to return - Int -> - -- | mapping the results to symbolic boolean formulas, the solver would try to - -- find a model to make the formula true - (Either e v -> SymBool) -> - -- | the program to be solved, should be a union of exception and values - t -> - IO ([Model], SolvingFailure) -solveMultiExcept config n f v = - solveMulti config n (simpleMerge $ f <$> extractUnionExcept v) diff --git a/src/Grisette/Core/Data/Class/SubstituteSym.hs b/src/Grisette/Core/Data/Class/SubstituteSym.hs deleted file mode 100644 --- a/src/Grisette/Core/Data/Class/SubstituteSym.hs +++ /dev/null @@ -1,318 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- Module : Grisette.Core.Data.Class.SubstituteSym --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Core.Data.Class.SubstituteSym - ( -- * Substituting symbolic constants - SubstituteSym (..), - SubstituteSym' (..), - ) -where - -import Control.Monad.Except (ExceptT (ExceptT)) -import Control.Monad.Identity - ( Identity (Identity), - IdentityT (IdentityT), - ) -import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) -import qualified Control.Monad.Writer.Lazy as WriterLazy -import qualified Control.Monad.Writer.Strict as WriterStrict -import qualified Data.ByteString as B -import Data.Functor.Sum (Sum) -import Data.Int (Int16, Int32, Int64, Int8) -import qualified Data.Text as T -import Data.Word (Word16, Word32, Word64, Word8) -import GHC.TypeNats (KnownNat, type (<=)) -import Generics.Deriving - ( Default (Default, unDefault), - Generic (Rep, from, to), - K1 (K1), - M1 (M1), - U1, - type (:*:) ((:*:)), - type (:+:) (L1, R1), - ) -import Generics.Deriving.Instances () -import Grisette.Core.Data.BV (IntN, SomeIntN, SomeWordN, WordN) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term - ( LinkedRep (underlyingTerm), - SupportedPrim, - TypedSymbol, - ) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermSubstitution (substTerm) -import Grisette.IR.SymPrim.Data.SymPrim - ( SomeSymIntN (SomeSymIntN), - SomeSymWordN (SomeSymWordN), - SymBool (SymBool), - SymIntN (SymIntN), - SymInteger (SymInteger), - SymWordN (SymWordN), - type (-~>) (SymGeneralFun), - type (=~>) (SymTabularFun), - ) - --- $setup --- >>> import Grisette.Core --- >>> import Grisette.IR.SymPrim - --- | Substitution of symbolic constants. --- --- >>> a = "a" :: TypedSymbol Bool --- >>> v = "x" .&& "y" :: SymBool --- >>> substituteSym a v (["a" .&& "b", "a"] :: [SymBool]) --- [(&& (&& x y) b),(&& x y)] --- --- __Note 1:__ This type class can be derived for algebraic data types. --- You may need the @DerivingVia@ and @DerivingStrategies@ extensions. --- --- > data X = ... deriving Generic deriving SubstituteSym via (Default X) -class SubstituteSym a where - -- Substitute a symbolic constant to some symbolic value - -- - -- >>> substituteSym "a" ("c" .&& "d" :: Sym Bool) ["a" .&& "b" :: Sym Bool, "a"] - -- [(&& (&& c d) b),(&& c d)] - substituteSym :: (LinkedRep cb sb) => TypedSymbol cb -> sb -> a -> a - -#define CONCRETE_SUBSTITUTESYM(type) \ -instance SubstituteSym type where \ - substituteSym _ _ = id - -#define CONCRETE_SUBSTITUTESYM_BV(type) \ -instance (KnownNat n, 1 <= n) => SubstituteSym (type n) where \ - substituteSym _ _ = id - -#if 1 -CONCRETE_SUBSTITUTESYM(Bool) -CONCRETE_SUBSTITUTESYM(Integer) -CONCRETE_SUBSTITUTESYM(Char) -CONCRETE_SUBSTITUTESYM(Int) -CONCRETE_SUBSTITUTESYM(Int8) -CONCRETE_SUBSTITUTESYM(Int16) -CONCRETE_SUBSTITUTESYM(Int32) -CONCRETE_SUBSTITUTESYM(Int64) -CONCRETE_SUBSTITUTESYM(Word) -CONCRETE_SUBSTITUTESYM(Word8) -CONCRETE_SUBSTITUTESYM(Word16) -CONCRETE_SUBSTITUTESYM(Word32) -CONCRETE_SUBSTITUTESYM(Word64) -CONCRETE_SUBSTITUTESYM(SomeWordN) -CONCRETE_SUBSTITUTESYM(SomeIntN) -CONCRETE_SUBSTITUTESYM(B.ByteString) -CONCRETE_SUBSTITUTESYM(T.Text) -CONCRETE_SUBSTITUTESYM_BV(WordN) -CONCRETE_SUBSTITUTESYM_BV(IntN) -#endif - -instance SubstituteSym () where - substituteSym _ _ = id - --- Either -deriving via - (Default (Either a b)) - instance - ( SubstituteSym a, - SubstituteSym b - ) => - SubstituteSym (Either a b) - --- Maybe -deriving via (Default (Maybe a)) instance (SubstituteSym a) => SubstituteSym (Maybe a) - --- List -deriving via (Default [a]) instance (SubstituteSym a) => SubstituteSym [a] - --- (,) -deriving via - (Default (a, b)) - instance - (SubstituteSym a, SubstituteSym b) => - SubstituteSym (a, b) - --- (,,) -deriving via - (Default (a, b, c)) - instance - ( SubstituteSym a, - SubstituteSym b, - SubstituteSym c - ) => - SubstituteSym (a, b, c) - --- (,,,) -deriving via - (Default (a, b, c, d)) - instance - ( SubstituteSym a, - SubstituteSym b, - SubstituteSym c, - SubstituteSym d - ) => - SubstituteSym (a, b, c, d) - --- (,,,,) -deriving via - (Default (a, b, c, d, e)) - instance - ( SubstituteSym a, - SubstituteSym b, - SubstituteSym c, - SubstituteSym d, - SubstituteSym e - ) => - SubstituteSym (a, b, c, d, e) - --- (,,,,,) -deriving via - (Default (a, b, c, d, e, f)) - instance - ( SubstituteSym a, - SubstituteSym b, - SubstituteSym c, - SubstituteSym d, - SubstituteSym e, - SubstituteSym f - ) => - SubstituteSym (a, b, c, d, e, f) - --- (,,,,,,) -deriving via - (Default (a, b, c, d, e, f, g)) - instance - ( SubstituteSym a, - SubstituteSym b, - SubstituteSym c, - SubstituteSym d, - SubstituteSym e, - SubstituteSym f, - SubstituteSym g - ) => - SubstituteSym (a, b, c, d, e, f, g) - --- (,,,,,,,) -deriving via - (Default (a, b, c, d, e, f, g, h)) - instance - ( SubstituteSym a, - SubstituteSym b, - SubstituteSym c, - SubstituteSym d, - SubstituteSym e, - SubstituteSym f, - SubstituteSym g, - SubstituteSym h - ) => - SubstituteSym ((,,,,,,,) a b c d e f g h) - --- MaybeT -instance - (SubstituteSym (m (Maybe a))) => - SubstituteSym (MaybeT m a) - where - substituteSym sym val (MaybeT v) = MaybeT $ substituteSym sym val v - --- ExceptT -instance - (SubstituteSym (m (Either e a))) => - SubstituteSym (ExceptT e m a) - where - substituteSym sym val (ExceptT v) = ExceptT $ substituteSym sym val v - --- Sum -deriving via - (Default (Sum f g a)) - instance - (SubstituteSym (f a), SubstituteSym (g a)) => - SubstituteSym (Sum f g a) - --- WriterT -instance - (SubstituteSym (m (a, s))) => - SubstituteSym (WriterLazy.WriterT s m a) - where - substituteSym sym val (WriterLazy.WriterT v) = WriterLazy.WriterT $ substituteSym sym val v - -instance - (SubstituteSym (m (a, s))) => - SubstituteSym (WriterStrict.WriterT s m a) - where - substituteSym sym val (WriterStrict.WriterT v) = WriterStrict.WriterT $ substituteSym sym val v - --- Identity -instance (SubstituteSym a) => SubstituteSym (Identity a) where - substituteSym sym val (Identity a) = Identity $ substituteSym sym val a - --- IdentityT -instance (SubstituteSym (m a)) => SubstituteSym (IdentityT m a) where - substituteSym sym val (IdentityT a) = IdentityT $ substituteSym sym val a - -#define SUBSTITUTE_SYM_SIMPLE(symtype) \ -instance SubstituteSym symtype where \ - substituteSym sym v (symtype t) = symtype $ substTerm sym (underlyingTerm v) t - -#define SUBSTITUTE_SYM_BV(symtype) \ -instance (KnownNat n, 1 <= n) => SubstituteSym (symtype n) where \ - substituteSym sym v (symtype t) = symtype $ substTerm sym (underlyingTerm v) t - -#define SUBSTITUTE_SYM_FUN(op, cons) \ -instance (SupportedPrim ca, SupportedPrim cb, LinkedRep ca sa, LinkedRep cb sb) => SubstituteSym (sa op sb) where \ - substituteSym sym v (cons t) = cons $ substTerm sym (underlyingTerm v) t - -#define SUBSTITUTE_SYM_BV_SOME(somety, origty) \ -instance SubstituteSym somety where \ - substituteSym sym v (somety (origty t)) = somety $ origty $ substTerm sym (underlyingTerm v) t - -#if 1 -SUBSTITUTE_SYM_SIMPLE(SymBool) -SUBSTITUTE_SYM_SIMPLE(SymInteger) -SUBSTITUTE_SYM_BV(SymIntN) -SUBSTITUTE_SYM_BV(SymWordN) -SUBSTITUTE_SYM_FUN(=~>, SymTabularFun) -SUBSTITUTE_SYM_FUN(-~>, SymGeneralFun) -SUBSTITUTE_SYM_BV_SOME(SomeSymIntN, SymIntN) -SUBSTITUTE_SYM_BV_SOME(SomeSymWordN, SymWordN) -#endif - --- | Auxiliary class for 'SubstituteSym' instance derivation -class SubstituteSym' a where - -- | Auxiliary function for 'substituteSym' derivation - substituteSym' :: (LinkedRep cb sb) => TypedSymbol cb -> sb -> a c -> a c - -instance - ( Generic a, - SubstituteSym' (Rep a) - ) => - SubstituteSym (Default a) - where - substituteSym sym val = Default . to . substituteSym' sym val . from . unDefault - -instance SubstituteSym' U1 where - substituteSym' _ _ = id - -instance (SubstituteSym c) => SubstituteSym' (K1 i c) where - substituteSym' sym val (K1 v) = K1 $ substituteSym sym val v - -instance (SubstituteSym' a) => SubstituteSym' (M1 i c a) where - substituteSym' sym val (M1 v) = M1 $ substituteSym' sym val v - -instance (SubstituteSym' a, SubstituteSym' b) => SubstituteSym' (a :+: b) where - substituteSym' sym val (L1 l) = L1 $ substituteSym' sym val l - substituteSym' sym val (R1 r) = R1 $ substituteSym' sym val r - -instance (SubstituteSym' a, SubstituteSym' b) => SubstituteSym' (a :*: b) where - substituteSym' sym val (a :*: b) = substituteSym' sym val a :*: substituteSym' sym val b diff --git a/src/Grisette/Core/Data/Class/SymRotate.hs b/src/Grisette/Core/Data/Class/SymRotate.hs deleted file mode 100644 --- a/src/Grisette/Core/Data/Class/SymRotate.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE UndecidableInstances #-} - -module Grisette.Core.Data.Class.SymRotate - ( SymRotate (..), - DefaultFiniteBitsSymRotate (..), - ) -where - -import Data.Bits (Bits (isSigned, rotate), FiniteBits (finiteBitSize)) -import Data.Int (Int16, Int32, Int64, Int8) -import Data.Word (Word16, Word32, Word64, Word8) - -class (Bits a) => SymRotate a where - symRotate :: a -> a -> a - -instance SymRotate Int where - symRotate = rotate - -newtype DefaultFiniteBitsSymRotate a = DefaultFiniteBitsSymRotate - { unDefaultFiniteBitsSymRotate :: a - } - deriving newtype (Eq, Bits) - -instance - (Integral a, FiniteBits a) => - SymRotate (DefaultFiniteBitsSymRotate a) - where - symRotate (DefaultFiniteBitsSymRotate a) (DefaultFiniteBitsSymRotate s) - | isSigned a = DefaultFiniteBitsSymRotate $ symRotateSigned a s - | otherwise = DefaultFiniteBitsSymRotate $ symRotateUnsigned a s - where - symRotateUnsigned :: a -> a -> a - symRotateUnsigned a s = - rotate a (fromIntegral (s `mod` fromIntegral (finiteBitSize a))) - symRotateSigned :: a -> a -> a - symRotateSigned a s - | finiteBitSize s == 1 = a - | finiteBitSize s == 2 = rotate a (fromIntegral s) - | otherwise = - rotate a (fromIntegral (s `mod` fromIntegral (finiteBitSize a))) - -deriving via (DefaultFiniteBitsSymRotate Int8) instance SymRotate Int8 - -deriving via (DefaultFiniteBitsSymRotate Int16) instance SymRotate Int16 - -deriving via (DefaultFiniteBitsSymRotate Int32) instance SymRotate Int32 - -deriving via (DefaultFiniteBitsSymRotate Int64) instance SymRotate Int64 - -deriving via (DefaultFiniteBitsSymRotate Word8) instance SymRotate Word8 - -deriving via (DefaultFiniteBitsSymRotate Word16) instance SymRotate Word16 - -deriving via (DefaultFiniteBitsSymRotate Word32) instance SymRotate Word32 - -deriving via (DefaultFiniteBitsSymRotate Word64) instance SymRotate Word64 - -deriving via (DefaultFiniteBitsSymRotate Word) instance SymRotate Word diff --git a/src/Grisette/Core/Data/Class/SymShift.hs b/src/Grisette/Core/Data/Class/SymShift.hs deleted file mode 100644 --- a/src/Grisette/Core/Data/Class/SymShift.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE UndecidableInstances #-} - -module Grisette.Core.Data.Class.SymShift - ( SymShift (..), - DefaultFiniteBitsSymShift (..), - ) -where - -import Data.Bits (Bits (isSigned, shift), FiniteBits (finiteBitSize)) -import Data.Int (Int16, Int32, Int64, Int8) -import Data.Word (Word16, Word32, Word64, Word8) - -class (Bits a) => SymShift a where - symShift :: a -> a -> a - -instance SymShift Int where - symShift a s - | s >= finiteBitSize s = 0 - | s <= -finiteBitSize s = if a >= 0 then 0 else -1 - | otherwise = shift a s - -newtype DefaultFiniteBitsSymShift a = DefaultFiniteBitsSymShift - { unDefaultFiniteBitsSymShift :: a - } - deriving newtype (Eq, Bits) - -instance - (Integral a, FiniteBits a) => - SymShift (DefaultFiniteBitsSymShift a) - where - symShift (DefaultFiniteBitsSymShift a) (DefaultFiniteBitsSymShift s) - | isSigned a = DefaultFiniteBitsSymShift $ symShiftSigned a s - | otherwise = DefaultFiniteBitsSymShift $ symShiftUnsigned a s - where - symShiftUnsigned :: (Integral a, FiniteBits a) => a -> a -> a - symShiftUnsigned a s | s >= fromIntegral (finiteBitSize a) = 0 - symShiftUnsigned a s = shift a (fromIntegral s) - - symShiftSigned :: (Integral a, FiniteBits a) => a -> a -> a - symShiftSigned a s | finiteBitSize s == 1 = a - symShiftSigned a s - | finiteBitSize s == 2 = - if s == -2 - then if a < 0 then -1 else 0 - else shift a (fromIntegral s) - symShiftSigned a s | s >= fromIntegral (finiteBitSize a) = 0 - symShiftSigned a s - | s <= fromIntegral (-finiteBitSize a) = - if a < 0 then -1 else 0 - symShiftSigned a s = shift a (fromIntegral s) - -deriving via (DefaultFiniteBitsSymShift Int8) instance SymShift Int8 - -deriving via (DefaultFiniteBitsSymShift Int16) instance SymShift Int16 - -deriving via (DefaultFiniteBitsSymShift Int32) instance SymShift Int32 - -deriving via (DefaultFiniteBitsSymShift Int64) instance SymShift Int64 - -deriving via (DefaultFiniteBitsSymShift Word8) instance SymShift Word8 - -deriving via (DefaultFiniteBitsSymShift Word16) instance SymShift Word16 - -deriving via (DefaultFiniteBitsSymShift Word32) instance SymShift Word32 - -deriving via (DefaultFiniteBitsSymShift Word64) instance SymShift Word64 - -deriving via (DefaultFiniteBitsSymShift Word) instance SymShift Word diff --git a/src/Grisette/Core/Data/Class/ToCon.hs b/src/Grisette/Core/Data/Class/ToCon.hs deleted file mode 100644 --- a/src/Grisette/Core/Data/Class/ToCon.hs +++ /dev/null @@ -1,343 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- Module : Grisette.Core.Data.Class.ToCon --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Core.Data.Class.ToCon - ( -- * Converting to concrete values - ToCon (..), - ) -where - -import Control.Monad.Except (ExceptT (ExceptT)) -import Control.Monad.Identity - ( Identity (Identity, runIdentity), - IdentityT (IdentityT), - ) -import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) -import qualified Control.Monad.Writer.Lazy as WriterLazy -import qualified Control.Monad.Writer.Strict as WriterStrict -import qualified Data.ByteString as B -import Data.Functor.Sum (Sum) -import Data.Int (Int16, Int32, Int64, Int8) -import qualified Data.Text as T -import Data.Word (Word16, Word32, Word64, Word8) -import GHC.Generics - ( Generic (Rep, from, to), - K1 (K1), - M1 (M1), - U1, - type (:*:) ((:*:)), - type (:+:) (L1, R1), - ) -import GHC.TypeNats (KnownNat, type (<=)) -import Generics.Deriving (Default (Default)) -import Generics.Deriving.Instances () -import Grisette.Core.Control.Exception (AssertionError, VerificationConditions) -import Grisette.Core.Data.BV - ( IntN (IntN), - SomeIntN (SomeIntN), - SomeWordN (SomeWordN), - WordN (WordN), - ) -import Grisette.Core.Data.Class.Solvable (Solvable (conView), pattern Con) -import Grisette.IR.SymPrim.Data.IntBitwidth (intBitwidthQ) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term - ( LinkedRep, - SupportedPrim, - type (-->), - ) -import Grisette.IR.SymPrim.Data.SymPrim - ( SomeSymIntN (SomeSymIntN), - SomeSymWordN (SomeSymWordN), - SymBool, - SymIntN, - SymInteger, - SymWordN, - type (-~>), - type (=~>), - ) -import Grisette.IR.SymPrim.Data.TabularFun (type (=->)) - --- $setup --- >>> import Grisette.Core --- >>> import Grisette.IR.SymPrim - --- | Convert a symbolic value to concrete value if possible. -class ToCon a b where - -- | Convert a symbolic value to concrete value if possible. - -- If the symbolic value cannot be converted to concrete, the result will be 'Nothing'. - -- - -- >>> toCon (ssym "a" :: SymInteger) :: Maybe Integer - -- Nothing - -- - -- >>> toCon (con 1 :: SymInteger) :: Maybe Integer - -- Just 1 - -- - -- 'toCon' works on complex types too. - -- - -- >>> toCon ([con 1, con 2] :: [SymInteger]) :: Maybe [Integer] - -- Just [1,2] - -- - -- >>> toCon ([con 1, ssym "a"] :: [SymInteger]) :: Maybe [Integer] - -- Nothing - toCon :: a -> Maybe b - -#define CONCRETE_TOCON(type) \ -instance ToCon type type where \ - toCon = Just - -#define CONCRETE_TOCON_BV(type) \ -instance (KnownNat n, 1 <= n) => ToCon (type n) (type n) where \ - toCon = Just - -#if 1 -CONCRETE_TOCON(Bool) -CONCRETE_TOCON(Integer) -CONCRETE_TOCON(Char) -CONCRETE_TOCON(Int) -CONCRETE_TOCON(Int8) -CONCRETE_TOCON(Int16) -CONCRETE_TOCON(Int32) -CONCRETE_TOCON(Int64) -CONCRETE_TOCON(Word) -CONCRETE_TOCON(Word8) -CONCRETE_TOCON(Word16) -CONCRETE_TOCON(Word32) -CONCRETE_TOCON(Word64) -CONCRETE_TOCON(SomeWordN) -CONCRETE_TOCON(SomeIntN) -CONCRETE_TOCON(B.ByteString) -CONCRETE_TOCON(T.Text) -CONCRETE_TOCON_BV(WordN) -CONCRETE_TOCON_BV(IntN) -#endif - --- Unit -instance ToCon () () where - toCon = Just - --- Either -deriving via (Default (Either e2 a2)) instance (ToCon e1 e2, ToCon a1 a2) => ToCon (Either e1 a1) (Either e2 a2) - --- Maybe -deriving via (Default (Maybe a2)) instance (ToCon a1 a2) => ToCon (Maybe a1) (Maybe a2) - --- List -deriving via (Default [b]) instance (ToCon a b) => ToCon [a] [b] - --- (,) -deriving via (Default (a2, b2)) instance (ToCon a1 a2, ToCon b1 b2) => ToCon (a1, b1) (a2, b2) - --- (,,) -deriving via (Default (a2, b2, c2)) instance (ToCon a1 a2, ToCon b1 b2, ToCon c1 c2) => ToCon (a1, b1, c1) (a2, b2, c2) - --- (,,,) -deriving via - (Default (a2, b2, c2, d2)) - instance - (ToCon a1 a2, ToCon b1 b2, ToCon c1 c2, ToCon d1 d2) => ToCon (a1, b1, c1, d1) (a2, b2, c2, d2) - --- (,,,,) -deriving via - (Default (a2, b2, c2, d2, e2)) - instance - (ToCon a1 a2, ToCon b1 b2, ToCon c1 c2, ToCon d1 d2, ToCon e1 e2) => - ToCon (a1, b1, c1, d1, e1) (a2, b2, c2, d2, e2) - --- (,,,,,) -deriving via - (Default (a2, b2, c2, d2, e2, f2)) - instance - (ToCon a1 a2, ToCon b1 b2, ToCon c1 c2, ToCon d1 d2, ToCon e1 e2, ToCon f1 f2) => - ToCon (a1, b1, c1, d1, e1, f1) (a2, b2, c2, d2, e2, f2) - --- (,,,,,,) -deriving via - (Default (a2, b2, c2, d2, e2, f2, g2)) - instance - (ToCon a1 a2, ToCon b1 b2, ToCon c1 c2, ToCon d1 d2, ToCon e1 e2, ToCon f1 f2, ToCon g1 g2) => - ToCon (a1, b1, c1, d1, e1, f1, g1) (a2, b2, c2, d2, e2, f2, g2) - --- (,,,,,,,) -deriving via - (Default (a2, b2, c2, d2, e2, f2, g2, h2)) - instance - (ToCon a1 a2, ToCon b1 b2, ToCon c1 c2, ToCon d1 d2, ToCon e1 e2, ToCon f1 f2, ToCon g1 g2, ToCon h1 h2) => - ToCon (a1, b1, c1, d1, e1, f1, g1, h1) (a2, b2, c2, d2, e2, f2, g2, h2) - --- MaybeT -instance - (ToCon (m1 (Maybe a)) (m2 (Maybe b))) => - ToCon (MaybeT m1 a) (MaybeT m2 b) - where - toCon (MaybeT v) = MaybeT <$> toCon v - --- ExceptT -instance - (ToCon (m1 (Either e1 a)) (m2 (Either e2 b))) => - ToCon (ExceptT e1 m1 a) (ExceptT e2 m2 b) - where - toCon (ExceptT v) = ExceptT <$> toCon v - -instance - (ToCon (m1 (Either e1 a)) (Either e2 b)) => - ToCon (ExceptT e1 m1 a) (Either e2 b) - where - toCon (ExceptT v) = toCon v - --- Sum -deriving via - (Default (Sum f1 g1 a1)) - instance - (ToCon (f a) (f1 a1), ToCon (g a) (g1 a1)) => ToCon (Sum f g a) (Sum f1 g1 a1) - --- WriterT -instance - (ToCon (m1 (a, s1)) (m2 (b, s2))) => - ToCon (WriterLazy.WriterT s1 m1 a) (WriterLazy.WriterT s2 m2 b) - where - toCon (WriterLazy.WriterT v) = WriterLazy.WriterT <$> toCon v - -instance - (ToCon (m1 (a, s1)) (m2 (b, s2))) => - ToCon (WriterStrict.WriterT s1 m1 a) (WriterStrict.WriterT s2 m2 b) - where - toCon (WriterStrict.WriterT v) = WriterStrict.WriterT <$> toCon v - --- Identity -instance (ToCon a b) => ToCon (Identity a) (Identity b) where - toCon (Identity a) = Identity <$> toCon a - -instance ToCon (Identity v) v where - toCon = Just . runIdentity - -instance ToCon v (Identity v) where - toCon = Just . Identity - --- IdentityT -instance (ToCon (m a) (m1 b)) => ToCon (IdentityT m a) (IdentityT m1 b) where - toCon (IdentityT a) = IdentityT <$> toCon a - -#define TO_CON_SYMID_SIMPLE(symtype) \ -instance ToCon symtype symtype where \ - toCon = Just - -#define TO_CON_SYMID_BV(symtype) \ -instance (KnownNat n, 1 <= n) => ToCon (symtype n) (symtype n) where \ - toCon = Just - -#define TO_CON_SYMID_FUN(op) \ -instance (SupportedPrim a, SupportedPrim b) => ToCon (a op b) (a op b) where \ - toCon = Just - -#if 1 -TO_CON_SYMID_SIMPLE(SymBool) -TO_CON_SYMID_SIMPLE(SymInteger) -TO_CON_SYMID_BV(SymIntN) -TO_CON_SYMID_BV(SymWordN) -TO_CON_SYMID_FUN(=~>) -TO_CON_SYMID_FUN(-~>) -TO_CON_SYMID_SIMPLE(SomeSymIntN) -TO_CON_SYMID_SIMPLE(SomeSymWordN) - -#endif - -#define TO_CON_FROMSYM_SIMPLE(contype, symtype) \ -instance ToCon symtype contype where \ - toCon = conView - -#define TO_CON_FROMSYM_BV(contype, symtype) \ -instance (KnownNat n, 1 <= n) => ToCon (symtype n) (contype n) where \ - toCon = conView - -#define TO_CON_FROMSYM_FUN(conop, symop) \ -instance (SupportedPrim ca, SupportedPrim cb, LinkedRep ca sa, LinkedRep cb sb) => ToCon (symop sa sb) (conop ca cb) where \ - toCon = conView - -#define TO_CON_FROMSYM_BV_SOME(contype, symtype) \ -instance ToCon symtype contype where \ - toCon (symtype v) = contype <$> conView v - -#if 1 -TO_CON_FROMSYM_SIMPLE(Bool, SymBool) -TO_CON_FROMSYM_SIMPLE(Integer, SymInteger) -TO_CON_FROMSYM_BV(IntN, SymIntN) -TO_CON_FROMSYM_BV(WordN, SymWordN) -TO_CON_FROMSYM_FUN((=->), (=~>)) -TO_CON_FROMSYM_FUN((-->), (-~>)) -TO_CON_FROMSYM_BV_SOME(SomeIntN, SomeSymIntN) -TO_CON_FROMSYM_BV_SOME(SomeWordN, SomeSymWordN) -#endif - -#define TOCON_MACHINE_INTEGER(sbvw, bvw, n, int) \ -instance ToCon (sbvw n) int where \ - toCon (Con (bvw v :: bvw n)) = Just $ fromIntegral v; \ - toCon _ = Nothing - -#if 1 -TOCON_MACHINE_INTEGER(SymIntN, IntN, 8, Int8) -TOCON_MACHINE_INTEGER(SymIntN, IntN, 16, Int16) -TOCON_MACHINE_INTEGER(SymIntN, IntN, 32, Int32) -TOCON_MACHINE_INTEGER(SymIntN, IntN, 64, Int64) -TOCON_MACHINE_INTEGER(SymWordN, WordN, 8, Word8) -TOCON_MACHINE_INTEGER(SymWordN, WordN, 16, Word16) -TOCON_MACHINE_INTEGER(SymWordN, WordN, 32, Word32) -TOCON_MACHINE_INTEGER(SymWordN, WordN, 64, Word64) -TOCON_MACHINE_INTEGER(SymIntN, IntN, $intBitwidthQ, Int) -TOCON_MACHINE_INTEGER(SymWordN, WordN, $intBitwidthQ, Word) -#endif - -deriving via - (Default AssertionError) - instance - ToCon AssertionError AssertionError - -deriving via - (Default VerificationConditions) - instance - ToCon VerificationConditions VerificationConditions - --- Derivation of ToCon for generic types -instance (Generic a, Generic b, ToCon' (Rep a) (Rep b)) => ToCon a (Default b) where - toCon v = fmap (Default . to) $ toCon' $ from v - -class ToCon' a b where - toCon' :: a c -> Maybe (b c) - -instance ToCon' U1 U1 where - toCon' = Just - -instance (ToCon a b) => ToCon' (K1 i a) (K1 i b) where - toCon' (K1 a) = K1 <$> toCon a - -instance (ToCon' a b) => ToCon' (M1 i c1 a) (M1 i c2 b) where - toCon' (M1 a) = M1 <$> toCon' a - -instance (ToCon' a1 a2, ToCon' b1 b2) => ToCon' (a1 :+: b1) (a2 :+: b2) where - toCon' (L1 a) = L1 <$> toCon' a - toCon' (R1 a) = R1 <$> toCon' a - -instance (ToCon' a1 a2, ToCon' b1 b2) => ToCon' (a1 :*: b1) (a2 :*: b2) where - toCon' (a :*: b) = do - ac <- toCon' a - bc <- toCon' b - return $ ac :*: bc diff --git a/src/Grisette/Core/Data/Class/ToSym.hs b/src/Grisette/Core/Data/Class/ToSym.hs deleted file mode 100644 --- a/src/Grisette/Core/Data/Class/ToSym.hs +++ /dev/null @@ -1,349 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- Module : Grisette.Core.Data.Class.ToSym --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Core.Data.Class.ToSym - ( -- * Converting to symbolic values - ToSym (..), - ) -where - -import Control.Monad.Identity - ( Identity (Identity), - IdentityT (IdentityT), - ) -import Control.Monad.Reader (ReaderT (ReaderT)) -import qualified Control.Monad.State.Lazy as StateLazy -import qualified Control.Monad.State.Strict as StateStrict -import Control.Monad.Trans.Except (ExceptT (ExceptT)) -import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) -import qualified Control.Monad.Writer.Lazy as WriterLazy -import qualified Control.Monad.Writer.Strict as WriterStrict -import qualified Data.ByteString as B -import Data.Functor.Sum (Sum) -import Data.Int (Int16, Int32, Int64, Int8) -import qualified Data.Text as T -import Data.Word (Word16, Word32, Word64, Word8) -import GHC.TypeNats (KnownNat, type (<=)) -import Generics.Deriving - ( Default (Default), - Generic (Rep, from, to), - K1 (K1), - M1 (M1), - U1, - type (:*:) ((:*:)), - type (:+:) (L1, R1), - ) -import Grisette.Core.Control.Exception (AssertionError, VerificationConditions) -import Grisette.Core.Data.BV - ( IntN, - SomeIntN (SomeIntN), - SomeWordN (SomeWordN), - WordN, - ) -import Grisette.Core.Data.Class.Solvable (Solvable (con)) -import Grisette.IR.SymPrim.Data.IntBitwidth (intBitwidthQ) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term - ( LinkedRep, - SupportedPrim, - type (-->), - ) -import Grisette.IR.SymPrim.Data.SymPrim - ( SomeSymIntN (SomeSymIntN), - SomeSymWordN (SomeSymWordN), - SymBool, - SymIntN, - SymInteger, - SymWordN, - type (-~>), - type (=~>), - ) -import Grisette.IR.SymPrim.Data.TabularFun (type (=->)) - --- $setup --- >>> import Grisette.IR.SymPrim - --- | Convert a concrete value to symbolic value. -class ToSym a b where - -- | Convert a concrete value to symbolic value. - -- - -- >>> toSym False :: SymBool - -- false - -- - -- >>> toSym [False, True] :: [SymBool] - -- [false,true] - toSym :: a -> b - -#define CONCRETE_TOSYM(type) \ -instance ToSym type type where \ - toSym = id - -#define CONCRETE_TOSYM_BV(type) \ -instance (KnownNat n, 1 <= n) => ToSym (type n) (type n) where \ - toSym = id - -#if 1 -CONCRETE_TOSYM(Bool) -CONCRETE_TOSYM(Integer) -CONCRETE_TOSYM(Char) -CONCRETE_TOSYM(Int) -CONCRETE_TOSYM(Int8) -CONCRETE_TOSYM(Int16) -CONCRETE_TOSYM(Int32) -CONCRETE_TOSYM(Int64) -CONCRETE_TOSYM(Word) -CONCRETE_TOSYM(Word8) -CONCRETE_TOSYM(Word16) -CONCRETE_TOSYM(Word32) -CONCRETE_TOSYM(Word64) -CONCRETE_TOSYM(SomeIntN) -CONCRETE_TOSYM(SomeWordN) -CONCRETE_TOSYM(B.ByteString) -CONCRETE_TOSYM(T.Text) -CONCRETE_TOSYM_BV(IntN) -CONCRETE_TOSYM_BV(WordN) -#endif - --- Unit -instance ToSym () () where - toSym = id - --- Either -deriving via (Default (Either e2 a2)) instance (ToSym e1 e2, ToSym a1 a2) => ToSym (Either e1 a1) (Either e2 a2) - --- Maybe -deriving via (Default (Maybe b)) instance (ToSym a b) => ToSym (Maybe a) (Maybe b) - --- List -deriving via (Default [b]) instance (ToSym a b) => ToSym [a] [b] - --- (,) -deriving via (Default (b1, b2)) instance (ToSym a1 b1, ToSym a2 b2) => ToSym (a1, a2) (b1, b2) - --- (,,) -deriving via (Default (b1, b2, b3)) instance (ToSym a1 b1, ToSym a2 b2, ToSym a3 b3) => ToSym (a1, a2, a3) (b1, b2, b3) - --- (,,,) -deriving via - (Default (a2, b2, c2, d2)) - instance - (ToSym a1 a2, ToSym b1 b2, ToSym c1 c2, ToSym d1 d2) => ToSym (a1, b1, c1, d1) (a2, b2, c2, d2) - --- (,,,,) -deriving via - (Default (a2, b2, c2, d2, e2)) - instance - (ToSym a1 a2, ToSym b1 b2, ToSym c1 c2, ToSym d1 d2, ToSym e1 e2) => - ToSym (a1, b1, c1, d1, e1) (a2, b2, c2, d2, e2) - --- (,,,,,) -deriving via - (Default (a2, b2, c2, d2, e2, f2)) - instance - (ToSym a1 a2, ToSym b1 b2, ToSym c1 c2, ToSym d1 d2, ToSym e1 e2, ToSym f1 f2) => - ToSym (a1, b1, c1, d1, e1, f1) (a2, b2, c2, d2, e2, f2) - --- (,,,,,,) -deriving via - (Default (a2, b2, c2, d2, e2, f2, g2)) - instance - (ToSym a1 a2, ToSym b1 b2, ToSym c1 c2, ToSym d1 d2, ToSym e1 e2, ToSym f1 f2, ToSym g1 g2) => - ToSym (a1, b1, c1, d1, e1, f1, g1) (a2, b2, c2, d2, e2, f2, g2) - --- (,,,,,,,) -deriving via - (Default (a2, b2, c2, d2, e2, f2, g2, h2)) - instance - (ToSym a1 a2, ToSym b1 b2, ToSym c1 c2, ToSym d1 d2, ToSym e1 e2, ToSym f1 f2, ToSym g1 g2, ToSym h1 h2) => - ToSym (a1, b1, c1, d1, e1, f1, g1, h1) (a2, b2, c2, d2, e2, f2, g2, h2) - --- function -instance (ToSym a b) => ToSym (v -> a) (v -> b) where - toSym f = toSym . f - --- MaybeT -instance - (ToSym (m1 (Maybe a)) (m2 (Maybe b))) => - ToSym (MaybeT m1 a) (MaybeT m2 b) - where - toSym (MaybeT v) = MaybeT $ toSym v - --- ExceptT -instance - (ToSym (m1 (Either e1 a)) (m2 (Either e2 b))) => - ToSym (ExceptT e1 m1 a) (ExceptT e2 m2 b) - where - toSym (ExceptT v) = ExceptT $ toSym v - --- StateT -instance (ToSym (s1 -> m1 (a1, s1)) (s2 -> m2 (a2, s2))) => ToSym (StateLazy.StateT s1 m1 a1) (StateLazy.StateT s2 m2 a2) where - toSym (StateLazy.StateT f1) = StateLazy.StateT $ toSym f1 - -instance (ToSym (s1 -> m1 (a1, s1)) (s2 -> m2 (a2, s2))) => ToSym (StateStrict.StateT s1 m1 a1) (StateStrict.StateT s2 m2 a2) where - toSym (StateStrict.StateT f1) = StateStrict.StateT $ toSym f1 - --- WriterT -instance (ToSym (m1 (a1, s1)) (m2 (a2, s2))) => ToSym (WriterLazy.WriterT s1 m1 a1) (WriterLazy.WriterT s2 m2 a2) where - toSym (WriterLazy.WriterT f1) = WriterLazy.WriterT $ toSym f1 - -instance (ToSym (m1 (a1, s1)) (m2 (a2, s2))) => ToSym (WriterStrict.WriterT s1 m1 a1) (WriterStrict.WriterT s2 m2 a2) where - toSym (WriterStrict.WriterT f1) = WriterStrict.WriterT $ toSym f1 - --- ReaderT -instance (ToSym (s1 -> m1 a1) (s2 -> m2 a2)) => ToSym (ReaderT s1 m1 a1) (ReaderT s2 m2 a2) where - toSym (ReaderT f1) = ReaderT $ toSym f1 - --- Sum -deriving via - (Default (Sum f1 g1 a1)) - instance - (ToSym (f a) (f1 a1), ToSym (g a) (g1 a1)) => ToSym (Sum f g a) (Sum f1 g1 a1) - --- Identity -instance (ToSym a b) => ToSym (Identity a) (Identity b) where - toSym (Identity a) = Identity $ toSym a - --- IdentityT -instance (ToSym (m a) (m1 b)) => ToSym (IdentityT m a) (IdentityT m1 b) where - toSym (IdentityT v) = IdentityT $ toSym v - -#define TO_SYM_SYMID_SIMPLE(symtype) \ -instance ToSym symtype symtype where \ - toSym = id - -#define TO_SYM_SYMID_BV(symtype) \ -instance (KnownNat n, 1 <= n) => ToSym (symtype n) (symtype n) where \ - toSym = id - -#define TO_SYM_SYMID_FUN(op) \ -instance (SupportedPrim a, SupportedPrim b) => ToSym (a op b) (a op b) where \ - toSym = id - -#if 1 -TO_SYM_SYMID_SIMPLE(SymBool) -TO_SYM_SYMID_SIMPLE(SymInteger) -TO_SYM_SYMID_BV(SymIntN) -TO_SYM_SYMID_BV(SymWordN) -TO_SYM_SYMID_FUN(=~>) -TO_SYM_SYMID_FUN(-~>) -TO_SYM_SYMID_SIMPLE(SomeSymIntN) -TO_SYM_SYMID_SIMPLE(SomeSymWordN) -#endif - -#define TO_SYM_FROMCON_SIMPLE(contype, symtype) \ -instance ToSym contype symtype where \ - toSym = con - -#define TO_SYM_FROMCON_BV(contype, symtype) \ -instance (KnownNat n, 1 <= n) => ToSym (contype n) (symtype n) where \ - toSym = con - -#define TO_SYM_FROMCON_FUN(conop, symop) \ -instance (SupportedPrim ca, SupportedPrim cb, LinkedRep ca sa, LinkedRep cb sb) => ToSym (conop ca cb) (symop sa sb) where \ - toSym = con - -#define TO_SYM_FROMCON_BV_SOME(contype, symtype) \ -instance ToSym contype symtype where \ - toSym (contype v) = symtype (con v) - -#if 1 -TO_SYM_FROMCON_SIMPLE(Bool, SymBool) -TO_SYM_FROMCON_SIMPLE(Integer, SymInteger) -TO_SYM_FROMCON_BV(IntN, SymIntN) -TO_SYM_FROMCON_BV(WordN, SymWordN) -TO_SYM_FROMCON_FUN((=->), (=~>)) -TO_SYM_FROMCON_FUN((-->), (-~>)) -TO_SYM_FROMCON_BV_SOME(SomeIntN, SomeSymIntN) -TO_SYM_FROMCON_BV_SOME(SomeWordN, SomeSymWordN) -#endif - -#define TO_SYM_FROMBV_SOME(somesymbv, bv) \ -instance (KnownNat n, 1 <= n) => ToSym (bv n) somesymbv where \ - toSym = somesymbv . con - -#if 1 -TO_SYM_FROMBV_SOME(SomeSymIntN, IntN) -TO_SYM_FROMBV_SOME(SomeSymWordN, WordN) -#endif - -#define TOSYM_MACHINE_INTEGER(int, bv) \ -instance ToSym int (bv) where \ - toSym = fromIntegral - -#define TOSYM_MACHINE_INTEGER_SOME(int, somesymbv, bv, bitwidth) \ -instance ToSym int somesymbv where \ - toSym v = somesymbv (con (fromIntegral v :: bv bitwidth)) - -#if 1 -TOSYM_MACHINE_INTEGER(Int8, SymIntN 8) -TOSYM_MACHINE_INTEGER(Int16, SymIntN 16) -TOSYM_MACHINE_INTEGER(Int32, SymIntN 32) -TOSYM_MACHINE_INTEGER(Int64, SymIntN 64) -TOSYM_MACHINE_INTEGER(Word8, SymWordN 8) -TOSYM_MACHINE_INTEGER(Word16, SymWordN 16) -TOSYM_MACHINE_INTEGER(Word32, SymWordN 32) -TOSYM_MACHINE_INTEGER(Word64, SymWordN 64) -TOSYM_MACHINE_INTEGER(Int, SymIntN $intBitwidthQ) -TOSYM_MACHINE_INTEGER(Word, SymWordN $intBitwidthQ) - -TOSYM_MACHINE_INTEGER_SOME(Int8, SomeSymIntN, IntN, 8) -TOSYM_MACHINE_INTEGER_SOME(Int16, SomeSymIntN, IntN, 16) -TOSYM_MACHINE_INTEGER_SOME(Int32, SomeSymIntN, IntN, 32) -TOSYM_MACHINE_INTEGER_SOME(Int64, SomeSymIntN, IntN, 64) -TOSYM_MACHINE_INTEGER_SOME(Word8, SomeSymWordN, WordN, 8) -TOSYM_MACHINE_INTEGER_SOME(Word16, SomeSymWordN, WordN, 16) -TOSYM_MACHINE_INTEGER_SOME(Word32, SomeSymWordN, WordN, 32) -TOSYM_MACHINE_INTEGER_SOME(Word64, SomeSymWordN, WordN, 64) -TOSYM_MACHINE_INTEGER_SOME(Int, SomeSymIntN, IntN, $intBitwidthQ) -TOSYM_MACHINE_INTEGER_SOME(Word, SomeSymWordN, WordN, $intBitwidthQ) -#endif - --- Exception -deriving via - (Default AssertionError) - instance - ToSym AssertionError AssertionError - -deriving via - (Default VerificationConditions) - instance - ToSym VerificationConditions VerificationConditions - -instance (Generic a, Generic b, ToSym' (Rep a) (Rep b)) => ToSym a (Default b) where - toSym = Default . to . toSym' . from - -class ToSym' a b where - toSym' :: a c -> b c - -instance ToSym' U1 U1 where - toSym' = id - -instance (ToSym a b) => ToSym' (K1 i a) (K1 i b) where - toSym' (K1 a) = K1 $ toSym a - -instance (ToSym' a b) => ToSym' (M1 i c1 a) (M1 i c2 b) where - toSym' (M1 a) = M1 $ toSym' a - -instance (ToSym' a1 a2, ToSym' b1 b2) => ToSym' (a1 :+: b1) (a2 :+: b2) where - toSym' (L1 a) = L1 $ toSym' a - toSym' (R1 b) = R1 $ toSym' b - -instance (ToSym' a1 a2, ToSym' b1 b2) => ToSym' (a1 :*: b1) (a2 :*: b2) where - toSym' (a :*: b) = toSym' a :*: toSym' b diff --git a/src/Grisette/Core/Data/FileLocation.hs b/src/Grisette/Core/Data/FileLocation.hs deleted file mode 100644 --- a/src/Grisette/Core/Data/FileLocation.hs +++ /dev/null @@ -1,94 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE Trustworthy #-} - -{- HLINT ignore "Unused LANGUAGE pragma" -} - --- | --- Module : Grisette.Core.Data.FileLocation --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Core.Data.FileLocation - ( -- * Symbolic constant generation with location - FileLocation (..), - nameWithLoc, - slocsym, - ilocsym, - ) -where - -import Control.DeepSeq (NFData) -import Data.Hashable (Hashable) -import qualified Data.Text as T -import Debug.Trace.LocationTH (__LOCATION__) -import GHC.Generics (Generic) -import Grisette.Core.Data.Class.GenSym (FreshIdent, nameWithInfo) -import Grisette.Core.Data.Class.Solvable - ( Solvable (iinfosym, sinfosym), - ) -import Language.Haskell.TH.Syntax (Lift, unsafeTExpCoerce) -import Language.Haskell.TH.Syntax.Compat (SpliceQ, liftSplice) - --- $setup --- >>> import Grisette.Core --- >>> import Grisette.IR.SymPrim --- >>> :set -XTemplateHaskell - --- File location type. -data FileLocation = FileLocation {locPath :: String, locLineno :: Int, locSpan :: (Int, Int)} - deriving (Eq, Ord, Generic, Lift, NFData, Hashable) - -instance Show FileLocation where - show (FileLocation p l (s1, s2)) = p ++ ":" ++ show l ++ ":" ++ show s1 ++ "-" ++ show s2 - -parseFileLocation :: String -> FileLocation -parseFileLocation str = - let r = reverse str - (s2, r1) = break (== '-') r - (s1, r2) = break (== ':') $ tail r1 - (l, p) = break (== ':') $ tail r2 - in FileLocation (reverse $ tail p) (read $ reverse l) (read $ reverse s1, read $ reverse s2) - --- | Identifier with the current location as extra information. --- --- >>> $$(nameWithLoc "a") -- a sample result could be "a::18:4-18" --- a::... --- --- The uniqueness is ensured for the call to 'nameWithLoc' at different location. -nameWithLoc :: T.Text -> SpliceQ FreshIdent -nameWithLoc s = [||nameWithInfo s (parseFileLocation $$(liftSplice $ unsafeTExpCoerce __LOCATION__))||] - --- | Generate simply-named symbolic variables. The file location will be --- attached to the identifier. --- --- >>> $$(slocsym "a") :: SymBool --- a::... --- --- Calling 'slocsymb' with the same name at different location will always --- generate different symbolic constants. Calling 'slocsymb' at the same --- location for multiple times will generate the same symbolic constants. --- --- >>> ($$(slocsym "a") :: SymBool) == $$(slocsym "a") --- False --- >>> let f _ = $$(slocsym "a") :: SymBool --- >>> f () == f () --- True -slocsym :: (Solvable c s) => T.Text -> SpliceQ s -slocsym nm = [||sinfosym nm (parseFileLocation $$(liftSplice $ unsafeTExpCoerce __LOCATION__))||] - --- | Generate indexed symbolic variables. The file location will be attached to identifier. --- --- >>> $$(ilocsym "a" 1) :: SymBool --- a@1::... --- --- Calling 'ilocsymb' with the same name and index at different location will --- always generate different symbolic constants. Calling 'slocsymb' at the same --- location for multiple times will generate the same symbolic constants. -ilocsym :: (Solvable c s) => T.Text -> Int -> SpliceQ s -ilocsym nm idx = [||iinfosym nm idx (parseFileLocation $$(liftSplice $ unsafeTExpCoerce __LOCATION__))||] diff --git a/src/Grisette/Core/Data/MemoUtils.hs b/src/Grisette/Core/Data/MemoUtils.hs deleted file mode 100644 --- a/src/Grisette/Core/Data/MemoUtils.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeFamilies #-} - --- | --- Module : Grisette.Core.Data.MemoUtils --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Core.Data.MemoUtils - ( -- * Hashtable-based memoization - htmemo, - htmemo2, - htmemo3, - htmup, - htmemoFix, - ) -where - -import Data.Function (fix) -import qualified Data.HashTable.IO as H -import Data.Hashable (Hashable) -import System.IO.Unsafe (unsafePerformIO) - -type HashTable k v = H.BasicHashTable k v - --- | Function memoizer with mutable hash table. -htmemo :: (Eq k, Hashable k) => (k -> a) -> k -> a -htmemo f = unsafePerformIO $ do - cache <- H.new :: IO (HashTable k v) - return $ \x -> unsafePerformIO $ do - tryV <- H.lookup cache x - case tryV of - Nothing -> do - -- traceM "New value" - let v = f x - H.insert cache x v - return v - Just v -> return v - --- | Lift a memoizer to work with one more argument. -htmup :: (Eq k, Hashable k) => (b -> c) -> (k -> b) -> (k -> c) -htmup mem f = htmemo (mem . f) - --- | Function memoizer with mutable hash table. Works on binary functions. -htmemo2 :: (Eq k1, Hashable k1, Eq k2, Hashable k2) => (k1 -> k2 -> a) -> (k1 -> k2 -> a) -htmemo2 = htmup htmemo - --- | Function memoizer with mutable hash table. Works on ternary functions. -htmemo3 :: - (Eq k1, Hashable k1, Eq k2, Hashable k2, Eq k3, Hashable k3) => - (k1 -> k2 -> k3 -> a) -> - (k1 -> k2 -> k3 -> a) -htmemo3 = htmup htmemo2 - --- | Memoizing recursion. Use like 'fix'. -htmemoFix :: (Eq k, Hashable k) => ((k -> a) -> (k -> a)) -> k -> a -htmemoFix h = fix (htmemo . h) diff --git a/src/Grisette/Core/Data/Union.hs b/src/Grisette/Core/Data/Union.hs deleted file mode 100644 --- a/src/Grisette/Core/Data/Union.hs +++ /dev/null @@ -1,305 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeFamilies #-} - --- | --- Module : Grisette.Core.Data.Union --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Core.Data.Union - ( -- * The union data structure. - - -- | Please consider using 'Grisette.Core.Control.Monad.UnionM' instead. - Union (..), - ifWithLeftMost, - ifWithStrategy, - fullReconstruct, - ) -where - -import Control.DeepSeq (NFData (rnf), NFData1 (liftRnf), rnf1) -import Data.Functor.Classes - ( Eq1 (liftEq), - Show1 (liftShowsPrec), - showsPrec1, - showsUnaryWith, - ) -import Data.Hashable (Hashable (hashWithSalt)) -import GHC.Generics (Generic, Generic1) -import Grisette.Core.Data.Class.GPretty - ( GPretty (gprettyPrec), - condEnclose, - ) -import Grisette.Core.Data.Class.ITEOp (ITEOp (symIte)) -import Grisette.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.&&), (.||))) -import Grisette.Core.Data.Class.Mergeable - ( Mergeable (rootStrategy), - Mergeable1 (liftRootStrategy), - MergingStrategy (NoStrategy, SimpleStrategy, SortedStrategy), - ) -import Grisette.Core.Data.Class.SimpleMergeable - ( SimpleMergeable (mrgIte), - SimpleMergeable1 (liftMrgIte), - UnionLike - ( mergeWithStrategy, - mrgIfWithStrategy, - mrgSingleWithStrategy, - single, - unionIf - ), - UnionPrjOp (ifView, leftMost, singleView), - mrgIf, - ) -import Grisette.Core.Data.Class.Solvable (pattern Con) -import Grisette.IR.SymPrim.Data.SymPrim - ( AllSyms (allSymsS), - SomeSym (SomeSym), - SymBool, - ) -import Language.Haskell.TH.Syntax (Lift) - -#if MIN_VERSION_prettyprinter(1,7,0) -import Prettyprinter (align, group, nest, vsep) -#else -import Data.Text.Prettyprint.Doc (align, group, nest, vsep) -#endif - --- | The default union implementation. -data Union a - = -- | A single value - UnionSingle a - | -- | A if value - UnionIf - a - -- ^ Cached leftmost value - !Bool - -- ^ Is merged invariant already maintained? - !SymBool - -- ^ If condition - (Union a) - -- ^ True branch - (Union a) - -- ^ False branch - deriving (Generic, Eq, Lift, Generic1) - -instance Eq1 Union where - liftEq e (UnionSingle a) (UnionSingle b) = e a b - liftEq e (UnionIf l1 i1 c1 t1 f1) (UnionIf l2 i2 c2 t2 f2) = - e l1 l2 && i1 == i2 && c1 == c2 && liftEq e t1 t2 && liftEq e f1 f2 - liftEq _ _ _ = False - -instance (NFData a) => NFData (Union a) where - rnf = rnf1 - -instance NFData1 Union where - liftRnf _a (UnionSingle a) = _a a - liftRnf _a (UnionIf a bo b l r) = - _a a `seq` - rnf bo `seq` - rnf b `seq` - liftRnf _a l `seq` - liftRnf _a r - --- | Build 'UnionIf' with leftmost cache correctly maintained. --- --- Usually you should never directly try to build a 'UnionIf' with its --- constructor. -ifWithLeftMost :: Bool -> SymBool -> Union a -> Union a -> Union a -ifWithLeftMost _ (Con c) t f - | c = t - | otherwise = f -ifWithLeftMost inv cond t f = UnionIf (leftMost t) inv cond t f -{-# INLINE ifWithLeftMost #-} - -instance UnionPrjOp Union where - singleView (UnionSingle a) = Just a - singleView _ = Nothing - {-# INLINE singleView #-} - ifView (UnionIf _ _ cond ifTrue ifFalse) = Just (cond, ifTrue, ifFalse) - ifView _ = Nothing - {-# INLINE ifView #-} - leftMost (UnionSingle a) = a - leftMost (UnionIf a _ _ _ _) = a - {-# INLINE leftMost #-} - -instance (Mergeable a) => Mergeable (Union a) where - rootStrategy = SimpleStrategy $ ifWithStrategy rootStrategy - {-# INLINE rootStrategy #-} - -instance Mergeable1 Union where - liftRootStrategy ms = SimpleStrategy $ ifWithStrategy ms - {-# INLINE liftRootStrategy #-} - -instance (Mergeable a) => SimpleMergeable (Union a) where - mrgIte = mrgIf - -instance SimpleMergeable1 Union where - liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) - -instance UnionLike Union where - mergeWithStrategy = fullReconstruct - {-# INLINE mergeWithStrategy #-} - single = UnionSingle - {-# INLINE single #-} - unionIf = ifWithLeftMost False - {-# INLINE unionIf #-} - mrgIfWithStrategy = ifWithStrategy - {-# INLINE mrgIfWithStrategy #-} - mrgSingleWithStrategy _ = UnionSingle - {-# INLINE mrgSingleWithStrategy #-} - -instance Show1 Union where - liftShowsPrec sp _ i (UnionSingle a) = showsUnaryWith sp "Single" i a - liftShowsPrec sp sl i (UnionIf _ _ cond t f) = - showParen (i > 10) $ - showString "If" - . showChar ' ' - . showsPrec 11 cond - . showChar ' ' - . sp1 11 t - . showChar ' ' - . sp1 11 f - where - sp1 = liftShowsPrec sp sl - -instance (Show a) => Show (Union a) where - showsPrec = showsPrec1 - -instance (GPretty a) => GPretty (Union a) where - gprettyPrec n (UnionSingle a) = gprettyPrec n a - gprettyPrec n (UnionIf _ _ cond t f) = - group $ - condEnclose (n > 10) "(" ")" $ - align $ - nest 2 $ - vsep - [ "If", - gprettyPrec 11 cond, - gprettyPrec 11 t, - gprettyPrec 11 f - ] - -instance (Hashable a) => Hashable (Union a) where - s `hashWithSalt` (UnionSingle a) = - s `hashWithSalt` (0 :: Int) `hashWithSalt` a - s `hashWithSalt` (UnionIf _ _ c l r) = - s - `hashWithSalt` (1 :: Int) - `hashWithSalt` c - `hashWithSalt` l - `hashWithSalt` r - -instance (AllSyms a) => AllSyms (Union a) where - allSymsS (UnionSingle v) = allSymsS v - allSymsS (UnionIf _ _ c t f) = \l -> SomeSym c : (allSymsS t . allSymsS f $ l) - --- | Fully reconstruct a 'Union' to maintain the merged invariant. -fullReconstruct :: MergingStrategy a -> Union a -> Union a -fullReconstruct strategy (UnionIf _ False cond t f) = - ifWithStrategyInv - strategy - cond - (fullReconstruct strategy t) - (fullReconstruct strategy f) -fullReconstruct _ u = u -{-# INLINE fullReconstruct #-} - --- | Use a specific strategy to build a 'UnionIf' value. --- --- The merged invariant will be maintained in the result. -ifWithStrategy :: - MergingStrategy a -> - SymBool -> - Union a -> - Union a -> - Union a -ifWithStrategy strategy cond t@(UnionIf _ False _ _ _) f = - ifWithStrategy strategy cond (fullReconstruct strategy t) f -ifWithStrategy strategy cond t f@(UnionIf _ False _ _ _) = - ifWithStrategy strategy cond t (fullReconstruct strategy f) -ifWithStrategy strategy cond t f = ifWithStrategyInv strategy cond t f -{-# INLINE ifWithStrategy #-} - -ifWithStrategyInv :: - MergingStrategy a -> - SymBool -> - Union a -> - Union a -> - Union a -ifWithStrategyInv _ (Con v) t f - | v = t - | otherwise = f -ifWithStrategyInv strategy cond (UnionIf _ True condTrue tt _) f - | cond == condTrue = ifWithStrategyInv strategy cond tt f --- {| symNot cond == condTrue || cond == symNot condTrue = ifWithStrategyInv strategy cond ft f -ifWithStrategyInv strategy cond t (UnionIf _ True condFalse _ ff) - | cond == condFalse = ifWithStrategyInv strategy cond t ff --- {| symNot cond == condTrue || cond == symNot condTrue = ifWithStrategyInv strategy cond t tf -- buggy here condTrue -ifWithStrategyInv (SimpleStrategy m) cond (UnionSingle l) (UnionSingle r) = UnionSingle $ m cond l r -ifWithStrategyInv strategy@(SortedStrategy idxFun substrategy) cond ifTrue ifFalse = case (ifTrue, ifFalse) of - (UnionSingle _, UnionSingle _) -> ssUnionIf cond ifTrue ifFalse - (UnionSingle _, UnionIf {}) -> sgUnionIf cond ifTrue ifFalse - (UnionIf {}, UnionSingle _) -> gsUnionIf cond ifTrue ifFalse - _ -> ggUnionIf cond ifTrue ifFalse - where - ssUnionIf cond' ifTrue' ifFalse' - | idxt < idxf = ifWithLeftMost True cond' ifTrue' ifFalse' - | idxt == idxf = ifWithStrategyInv (substrategy idxt) cond' ifTrue' ifFalse' - | otherwise = ifWithLeftMost True (symNot cond') ifFalse' ifTrue' - where - idxt = idxFun $ leftMost ifTrue' - idxf = idxFun $ leftMost ifFalse' - {-# INLINE ssUnionIf #-} - sgUnionIf cond' ifTrue' ifFalse'@(UnionIf _ True condf ft ff) - | idxft == idxff = ssUnionIf cond' ifTrue' ifFalse' - | idxt < idxft = ifWithLeftMost True cond' ifTrue' ifFalse' - | idxt == idxft = ifWithLeftMost True (cond' .|| condf) (ifWithStrategyInv (substrategy idxt) cond' ifTrue' ft) ff - | otherwise = ifWithLeftMost True (symNot cond' .&& condf) ft (ifWithStrategyInv strategy cond' ifTrue' ff) - where - idxft = idxFun $ leftMost ft - idxff = idxFun $ leftMost ff - idxt = idxFun $ leftMost ifTrue' - sgUnionIf _ _ _ = undefined - {-# INLINE sgUnionIf #-} - gsUnionIf cond' ifTrue'@(UnionIf _ True condt tt tf) ifFalse' - | idxtt == idxtf = ssUnionIf cond' ifTrue' ifFalse' - | idxtt < idxf = ifWithLeftMost True (cond' .&& condt) tt $ ifWithStrategyInv strategy cond' tf ifFalse' - | idxtt == idxf = ifWithLeftMost True (symNot cond' .|| condt) (ifWithStrategyInv (substrategy idxf) cond' tt ifFalse') tf - | otherwise = ifWithLeftMost True (symNot cond') ifFalse' ifTrue' - where - idxtt = idxFun $ leftMost tt - idxtf = idxFun $ leftMost tf - idxf = idxFun $ leftMost ifFalse' - gsUnionIf _ _ _ = undefined - {-# INLINE gsUnionIf #-} - ggUnionIf cond' ifTrue'@(UnionIf _ True condt tt tf) ifFalse'@(UnionIf _ True condf ft ff) - | idxtt == idxtf = sgUnionIf cond' ifTrue' ifFalse' - | idxft == idxff = gsUnionIf cond' ifTrue' ifFalse' - | idxtt < idxft = ifWithLeftMost True (cond' .&& condt) tt $ ifWithStrategyInv strategy cond' tf ifFalse' - | idxtt == idxft = - let newCond = symIte cond' condt condf - newUnionIfTrue = ifWithStrategyInv (substrategy idxtt) cond' tt ft - newUnionIfFalse = ifWithStrategyInv strategy cond' tf ff - in ifWithLeftMost True newCond newUnionIfTrue newUnionIfFalse - | otherwise = ifWithLeftMost True (symNot cond' .&& condf) ft $ ifWithStrategyInv strategy cond' ifTrue' ff - where - idxtt = idxFun $ leftMost tt - idxtf = idxFun $ leftMost tf - idxft = idxFun $ leftMost ft - idxff = idxFun $ leftMost ff - ggUnionIf _ _ _ = undefined - {-# INLINE ggUnionIf #-} -ifWithStrategyInv NoStrategy cond ifTrue ifFalse = ifWithLeftMost True cond ifTrue ifFalse -ifWithStrategyInv _ _ _ _ = error "Invariant violated" -{-# INLINE ifWithStrategyInv #-} diff --git a/src/Grisette/Core/TH.hs b/src/Grisette/Core/TH.hs deleted file mode 100644 --- a/src/Grisette/Core/TH.hs +++ /dev/null @@ -1,142 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskellQuotes #-} -{-# LANGUAGE Trustworthy #-} - --- | --- Module : Grisette.Core.TH --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Core.TH - ( -- * Template Haskell procedures for building constructor wrappers - makeUnionWrapper, - makeUnionWrapper', - ) -where - -import Control.Monad (join, replicateM, when, zipWithM) -import Grisette.Core.THCompat (augmentFinalType) -import Language.Haskell.TH - ( Body (NormalB), - Clause (Clause), - Con (ForallC, GadtC, InfixC, NormalC, RecC, RecGadtC), - Dec (DataD, FunD, NewtypeD, SigD), - Exp (AppE, ConE, LamE, VarE), - Info (DataConI, TyConI), - Name, - Pat (VarP), - Q, - Type (ForallT), - mkName, - newName, - pprint, - reify, - ) -import Language.Haskell.TH.Syntax (Name (Name), OccName (OccName)) - --- | Generate constructor wrappers that wraps the result in a union-like monad with provided names. --- --- > $(makeUnionWrapper' ["mrgTuple2"] ''(,)) --- --- generates --- --- > mrgTuple2 :: (SymBoolOp bool, Monad u, Mergeable bool t1, Mergeable bool t2, MonadUnion bool u) => t1 -> t2 -> u (t1, t2) --- > mrgTuple2 = \v1 v2 -> mrgSingle (v1, v2) -makeUnionWrapper' :: - -- | Names for generated wrappers - [String] -> - -- | The type to generate the wrappers for - Name -> - Q [Dec] -makeUnionWrapper' names typName = do - constructors <- getConstructors typName - when (length names /= length constructors) $ - fail "Number of names does not match the number of constructors" - ds <- zipWithM mkSingleWrapper names constructors - return $ join ds - -occName :: Name -> String -occName (Name (OccName name) _) = name - -getConstructorName :: Con -> Q String -getConstructorName (NormalC name _) = return $ occName name -getConstructorName (RecC name _) = return $ occName name -getConstructorName InfixC {} = - fail "You should use makeUnionWrapper' to manually provide the name for infix constructors" -getConstructorName (ForallC _ _ c) = getConstructorName c -getConstructorName (GadtC [name] _ _) = return $ occName name -getConstructorName (RecGadtC [name] _ _) = return $ occName name -getConstructorName c = fail $ "Unsupported constructor at this time: " ++ pprint c - -getConstructors :: Name -> Q [Con] -getConstructors typName = do - d <- reify typName - case d of - TyConI (DataD _ _ _ _ constructors _) -> return constructors - TyConI (NewtypeD _ _ _ _ constructor _) -> return [constructor] - _ -> fail $ "Unsupported declaration: " ++ pprint d - --- | Generate constructor wrappers that wraps the result in a union-like monad. --- --- > $(makeUnionWrapper "mrg" ''Maybe) --- --- generates --- --- > mrgNothing :: (SymBoolOp bool, Monad u, Mergeable bool t, MonadUnion bool u) => u (Maybe t) --- > mrgNothing = mrgSingle Nothing --- > mrgJust :: (SymBoolOp bool, Monad u, Mergeable bool t, MonadUnion bool u) => t -> u (Maybe t) --- > mrgJust = \x -> mrgSingle (Just x) -makeUnionWrapper :: - -- | Prefix for generated wrappers - String -> - -- | The type to generate the wrappers for - Name -> - Q [Dec] -makeUnionWrapper prefix typName = do - constructors <- getConstructors typName - constructorNames <- mapM getConstructorName constructors - makeUnionWrapper' ((prefix ++) <$> constructorNames) typName - -augmentNormalCExpr :: Int -> Exp -> Q Exp -augmentNormalCExpr n f = do - xs <- replicateM n (newName "x") - let args = map VarP xs - mrgSingleFun <- [|mrgSingle|] - return $ - LamE - args - ( AppE mrgSingleFun $ - foldl AppE f (map VarE xs) - ) - -augmentNormalCType :: Type -> Q Type -augmentNormalCType (ForallT tybinders ctx ty1) = do - ((bndrs, preds), augmentedTyp) <- augmentFinalType ty1 - return $ ForallT (bndrs ++ tybinders) (preds ++ ctx) augmentedTyp -augmentNormalCType t = do - ((bndrs, preds), augmentedTyp) <- augmentFinalType t - return $ ForallT bndrs preds augmentedTyp - -mkSingleWrapper :: String -> Con -> Q [Dec] -mkSingleWrapper name (NormalC oriName b) = do - DataConI _ constructorTyp _ <- reify oriName - augmentedTyp <- augmentNormalCType constructorTyp - let retName = mkName name - expr <- augmentNormalCExpr (length b) (ConE oriName) - return - [ SigD retName augmentedTyp, - FunD retName [Clause [] (NormalB expr) []] - ] -mkSingleWrapper name (RecC oriName b) = do - DataConI _ constructorTyp _ <- reify oriName - augmentedTyp <- augmentNormalCType constructorTyp - let retName = mkName name - expr <- augmentNormalCExpr (length b) (ConE oriName) - return - [ SigD retName augmentedTyp, - FunD retName [Clause [] (NormalB expr) []] - ] -mkSingleWrapper _ v = fail $ "Unsupported constructor" ++ pprint v diff --git a/src/Grisette/Core/THCompat.hs b/src/Grisette/Core/THCompat.hs deleted file mode 100644 --- a/src/Grisette/Core/THCompat.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskellQuotes #-} -{-# LANGUAGE Trustworthy #-} - --- | --- Module : Grisette.Core.THCompat --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Core.THCompat (augmentFinalType) where - -import Data.Bifunctor (Bifunctor (second)) -import Grisette.Core.Control.Monad.UnionM (UnionM) -import Grisette.Core.Data.Class.Mergeable (Mergeable) -#if MIN_VERSION_template_haskell(2,17,0) -import Language.Haskell.TH.Syntax - ( Pred, - Q, - Specificity, - TyVarBndr, - Type - ( AppT, - ArrowT, - MulArrowT - ), - ) -#else -import Language.Haskell.TH.Syntax - ( Pred, - Q, - TyVarBndr, - Type - ( AppT, - ArrowT - ), - ) -#endif - -#if MIN_VERSION_template_haskell(2,17,0) -augmentFinalType :: Type -> Q (([TyVarBndr Specificity], [Pred]), Type) -#else -augmentFinalType :: Type -> Q (([TyVarBndr], [Pred]), Type) -#endif -augmentFinalType (AppT a@(AppT ArrowT _) t) = do - tl <- augmentFinalType t - return $ second (AppT a) tl -#if MIN_VERSION_template_haskell(2,17,0) -augmentFinalType (AppT (AppT (AppT MulArrowT _) var) t) = do - tl <- augmentFinalType t - return $ second (AppT (AppT ArrowT var)) tl -#endif -augmentFinalType t = do - unionType <- [t|UnionM|] - mergeable <- [t|Mergeable|] -#if MIN_VERSION_template_haskell(2,17,0) - return - ( ( [ ], - [ AppT mergeable t - ] - ), - AppT unionType t - ) -#elif MIN_VERSION_template_haskell(2,16,0) - return - ( ( [ ], - [ AppT mergeable t - ] - ), - AppT unionType t - ) -#endif diff --git a/src/Grisette/Experimental/GenSymConstrained.hs b/src/Grisette/Experimental/GenSymConstrained.hs --- a/src/Grisette/Experimental/GenSymConstrained.hs +++ b/src/Grisette/Experimental/GenSymConstrained.hs @@ -11,6 +11,14 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +-- | +-- Module : Grisette.Experimental.GenSymConstrained +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only module Grisette.Experimental.GenSymConstrained ( -- * Symbolic value generation with errors GenSymConstrained (..), @@ -38,13 +46,13 @@ type (:*:) ((:*:)), type (:+:) (L1, R1), ) -import Grisette.Core.Control.Monad.UnionM +import Grisette.Internal.Core.Control.Monad.Union (MonadUnion) +import Grisette.Internal.Core.Control.Monad.UnionM ( UnionM, liftToMonadUnion, ) -import Grisette.Core.Data.Class.GenSym - ( FreshIdent, - GenSym (fresh), +import Grisette.Internal.Core.Data.Class.GenSym + ( GenSym (fresh), GenSymSimple (simpleFresh), ListSpec (ListSpec), MonadFresh, @@ -53,20 +61,22 @@ chooseUnionFresh, runFreshT, ) -import Grisette.Core.Data.Class.LogicalOp (LogicalOp ((.||))) -import Grisette.Core.Data.Class.Mergeable (Mergeable, Mergeable1) -import Grisette.Core.Data.Class.SOrd (SOrd ((.<), (.>=))) -import Grisette.Core.Data.Class.SimpleMergeable - ( UnionLike, - merge, - mrgIf, - mrgSingle, +import Grisette.Internal.Core.Data.Class.LogicalOp (LogicalOp ((.||))) +import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable, Mergeable1) +import Grisette.Internal.Core.Data.Class.SOrd (SOrd ((.<), (.>=))) +import Grisette.Internal.Core.Data.Class.SimpleMergeable + ( mrgIf, ) +import Grisette.Internal.Core.Data.Class.TryMerge + ( mrgSingle, + tryMerge, + ) +import Grisette.Internal.Core.Data.Symbol (Identifier) -- $setup -- >>> import Grisette.Core -- >>> import Grisette.Experimental --- >>> import Grisette.IR.SymPrim +-- >>> import Grisette.SymPrim -- >>> :set -XOverloadedStrings -- >>> :set -XTypeApplications @@ -83,7 +93,7 @@ -- >>> runFreshT (freshConstrained () (SOrdUpperBound (1 :: SymInteger) ())) "a" :: ExceptT () UnionM (UnionM SymInteger) -- ExceptT freshConstrained :: - (MonadFresh m, MonadError e m, UnionLike m) => + (MonadFresh m, MonadError e m, MonadUnion m) => e -> spec -> m (UnionM a) @@ -91,15 +101,15 @@ (GenSymSimpleConstrained spec a) => ( MonadFresh m, MonadError e m, - UnionLike m + MonadUnion m ) => e -> spec -> m (UnionM a) freshConstrained e spec = mrgSingle <$> simpleFreshConstrained e spec -genSymConstrained :: forall spec a e. (GenSymConstrained spec a, Mergeable e) => e -> spec -> FreshIdent -> ExceptT e UnionM (UnionM a) -genSymConstrained e spec = merge . runFreshT (freshConstrained e spec) +genSymConstrained :: forall spec a e. (GenSymConstrained spec a, Mergeable e) => e -> spec -> Identifier -> ExceptT e UnionM (UnionM a) +genSymConstrained e spec = tryMerge . runFreshT (freshConstrained e spec) -- | Class of types in which symbolic values can be generated with some -- specification. @@ -114,13 +124,13 @@ -- >>> runFreshT (simpleFreshConstrained () (SOrdUpperBound (1 :: SymInteger) ())) "a" :: ExceptT () UnionM SymInteger -- ExceptT simpleFreshConstrained :: - (MonadFresh m, MonadError e m, UnionLike m) => + (MonadFresh m, MonadError e m, MonadUnion m) => e -> spec -> m a -genSymSimpleConstrained :: forall spec a e. (GenSymSimpleConstrained spec a, Mergeable e) => e -> spec -> FreshIdent -> ExceptT e UnionM a -genSymSimpleConstrained e spec = merge . runFreshT (simpleFreshConstrained e spec) +genSymSimpleConstrained :: forall spec a e. (GenSymSimpleConstrained spec a, Mergeable e) => e -> spec -> Identifier -> ExceptT e UnionM a +genSymSimpleConstrained e spec = tryMerge . runFreshT (simpleFreshConstrained e spec) instance {-# OVERLAPPABLE #-} (Mergeable a, GenSym spec a) => GenSymConstrained spec a where freshConstrained _ = fresh @@ -191,8 +201,8 @@ ) => GenSymConstrained (Either aspec bspec) (Either a b) where - freshConstrained e (Left aspec) = merge $ (merge . fmap Left) <$> freshConstrained e aspec - freshConstrained e (Right bspec) = merge $ (merge . fmap Right) <$> freshConstrained e bspec + freshConstrained e (Left aspec) = tryMerge $ (tryMerge . fmap Left) <$> freshConstrained e aspec + freshConstrained e (Right bspec) = tryMerge $ (tryMerge . fmap Right) <$> freshConstrained e bspec instance ( GenSymSimpleConstrained a a, @@ -214,19 +224,19 @@ GenSymConstrained (Maybe aspec) (Maybe a) where freshConstrained _ Nothing = mrgSingle $ mrgSingle Nothing - freshConstrained e (Just aspec) = merge $ (merge . fmap Just) <$> freshConstrained e aspec + freshConstrained e (Just aspec) = tryMerge $ (tryMerge . fmap Just) <$> freshConstrained e aspec instance (GenSymSimpleConstrained aspec a) => GenSymSimpleConstrained (Maybe aspec) (Maybe a) where simpleFreshConstrained _ Nothing = mrgSingle Nothing - simpleFreshConstrained e (Just aspec) = merge $ Just <$> simpleFreshConstrained e aspec + simpleFreshConstrained e (Just aspec) = tryMerge $ Just <$> simpleFreshConstrained e aspec instance (GenSymConstrained aspec a, Mergeable a) => GenSymConstrained aspec (Maybe a) where freshConstrained e aspec = do a :: UnionM a <- freshConstrained e aspec - merge $ chooseUnionFresh [return Nothing, Just <$> a] + tryMerge $ chooseUnionFresh [return Nothing, Just <$> a] -- List instance @@ -236,9 +246,9 @@ freshConstrained e v = do l <- gl e v let xs = reverse $ scanr (:) [] l - merge $ chooseUnionFresh $ merge . sequence <$> xs + tryMerge $ chooseUnionFresh $ tryMerge . sequence <$> xs where - gl :: (MonadFresh m, MonadError e m, UnionLike m) => e -> Integer -> m [UnionM a] + gl :: (MonadFresh m, MonadError e m, MonadUnion m) => e -> Integer -> m [UnionM a] gl e1 v1 | v1 <= 0 = mrgSingle [] | otherwise = do @@ -256,9 +266,9 @@ else do l <- gl e maxLen let xs = drop minLen $ reverse $ scanr (:) [] l - merge $ chooseUnionFresh $ merge . sequence <$> xs + tryMerge $ chooseUnionFresh $ tryMerge . sequence <$> xs where - gl :: (MonadFresh m, MonadError e m, UnionLike m) => e -> Int -> m [UnionM a] + gl :: (MonadFresh m, MonadError e m, MonadUnion m) => e -> Int -> m [UnionM a] gl e1 currLen | currLen <= 0 = return [] | otherwise = do @@ -272,7 +282,7 @@ where freshConstrained e l = do r :: [UnionM a] <- traverse (freshConstrained e) l - mrgSingle $ merge $ sequence r + mrgSingle $ tryMerge $ sequence r instance (GenSymSimpleConstrained a a) => @@ -288,9 +298,9 @@ if len < 0 then error $ "Bad lengths: " ++ show len else do - merge $ merge . sequence <$> gl e len + tryMerge $ tryMerge . sequence <$> gl e len where - gl :: (MonadFresh m, MonadError e m, UnionLike m) => e -> Int -> m [UnionM a] + gl :: (MonadFresh m, MonadError e m, MonadUnion m) => e -> Int -> m [UnionM a] gl e1 currLen | currLen <= 0 = mrgSingle [] | otherwise = do @@ -308,7 +318,7 @@ else do gl e len where - gl :: (MonadFresh m, MonadError e m, UnionLike m) => e -> Int -> m [a] + gl :: (MonadFresh m, MonadError e m, MonadUnion m) => e -> Int -> m [a] gl e1 currLen | currLen <= 0 = mrgSingle [] | otherwise = do @@ -340,7 +350,7 @@ GenSymSimpleConstrained (aspec, bspec) (a, b) where simpleFreshConstrained e (aspec, bspec) = do - merge $ + tryMerge $ (,) <$> simpleFreshConstrained e aspec <*> simpleFreshConstrained e bspec @@ -374,7 +384,7 @@ GenSymSimpleConstrained (aspec, bspec, cspec) (a, b, c) where simpleFreshConstrained e (aspec, bspec, cspec) = do - merge $ + tryMerge $ (,,) <$> simpleFreshConstrained e aspec <*> simpleFreshConstrained e bspec @@ -414,7 +424,7 @@ GenSymSimpleConstrained (aspec, bspec, cspec, dspec) (a, b, c, d) where simpleFreshConstrained e (aspec, bspec, cspec, dspec) = do - merge $ + tryMerge $ (,,,) <$> simpleFreshConstrained e aspec <*> simpleFreshConstrained e bspec @@ -460,7 +470,7 @@ GenSymSimpleConstrained (aspec, bspec, cspec, dspec, espec) (a, b, c, d, e) where simpleFreshConstrained e (aspec, bspec, cspec, dspec, espec) = do - merge $ + tryMerge $ (,,,,) <$> simpleFreshConstrained e aspec <*> simpleFreshConstrained e bspec @@ -512,7 +522,7 @@ GenSymSimpleConstrained (aspec, bspec, cspec, dspec, espec, fspec) (a, b, c, d, e, f) where simpleFreshConstrained e (aspec, bspec, cspec, dspec, espec, fspec) = do - merge $ + tryMerge $ (,,,,,) <$> simpleFreshConstrained e aspec <*> simpleFreshConstrained e bspec @@ -570,7 +580,7 @@ GenSymSimpleConstrained (aspec, bspec, cspec, dspec, espec, fspec, gspec) (a, b, c, d, e, f, g) where simpleFreshConstrained e (aspec, bspec, cspec, dspec, espec, fspec, gspec) = do - merge $ + tryMerge $ (,,,,,,) <$> simpleFreshConstrained e aspec <*> simpleFreshConstrained e bspec @@ -634,7 +644,7 @@ GenSymSimpleConstrained (aspec, bspec, cspec, dspec, espec, fspec, gspec, hspec) (a, b, c, d, e, f, g, h) where simpleFreshConstrained e (aspec, bspec, cspec, dspec, espec, fspec, gspec, hspec) = do - merge $ + tryMerge $ (,,,,,,,) <$> simpleFreshConstrained e aspec <*> simpleFreshConstrained e bspec @@ -656,7 +666,7 @@ where freshConstrained e v = do x <- freshConstrained e v - mrgSingle $ merge . fmap MaybeT $ x + mrgSingle $ tryMerge . fmap MaybeT $ x instance {-# OVERLAPPABLE #-} @@ -666,7 +676,7 @@ ) => GenSymSimpleConstrained spec (MaybeT m a) where - simpleFreshConstrained e v = merge $ MaybeT <$> simpleFreshConstrained e v + simpleFreshConstrained e v = tryMerge $ MaybeT <$> simpleFreshConstrained e v instance {-# OVERLAPPING #-} @@ -676,7 +686,7 @@ ) => GenSymSimpleConstrained (MaybeT m a) (MaybeT m a) where - simpleFreshConstrained e (MaybeT v) = merge $ MaybeT <$> simpleFreshConstrained e v + simpleFreshConstrained e (MaybeT v) = tryMerge $ MaybeT <$> simpleFreshConstrained e v instance {-# OVERLAPPING #-} @@ -698,7 +708,7 @@ where freshConstrained e v = do x <- freshConstrained e v - mrgSingle $ merge . fmap ExceptT $ x + mrgSingle $ tryMerge . fmap ExceptT $ x instance {-# OVERLAPPABLE #-} @@ -709,7 +719,7 @@ ) => GenSymSimpleConstrained spec (ExceptT a m b) where - simpleFreshConstrained e v = merge $ ExceptT <$> simpleFreshConstrained e v + simpleFreshConstrained e v = tryMerge $ ExceptT <$> simpleFreshConstrained e v instance {-# OVERLAPPING #-} @@ -720,7 +730,7 @@ ) => GenSymSimpleConstrained (ExceptT e m a) (ExceptT e m a) where - simpleFreshConstrained e (ExceptT v) = merge $ ExceptT <$> simpleFreshConstrained e v + simpleFreshConstrained e (ExceptT v) = tryMerge $ ExceptT <$> simpleFreshConstrained e v instance {-# OVERLAPPING #-} @@ -737,7 +747,7 @@ freshConstrainedNoSpec :: ( MonadFresh m, MonadError e m, - UnionLike m + MonadUnion m ) => e -> m (UnionM (a c)) @@ -763,7 +773,7 @@ forall m c e. ( MonadFresh m, MonadError e m, - UnionLike m + MonadUnion m ) => e -> m (UnionM ((a :+: b) c)) @@ -781,7 +791,7 @@ forall m c e. ( MonadFresh m, MonadError e m, - UnionLike m + MonadUnion m ) => e -> m (UnionM ((a :*: b) c)) @@ -808,18 +818,18 @@ Mergeable a, MonadFresh m, MonadError e m, - UnionLike m + MonadUnion m ) => e -> () -> m (UnionM a) -derivedFreshConstrainedNoSpec e _ = merge $ (merge . fmap to) <$> freshConstrainedNoSpec e +derivedFreshConstrainedNoSpec e _ = tryMerge $ (tryMerge . fmap to) <$> freshConstrainedNoSpec e class GenSymSimpleConstrainedNoSpec a where simpleFreshConstrainedNoSpec :: ( MonadFresh m, MonadError e m, - UnionLike m + MonadUnion m ) => e -> m (a c) @@ -857,19 +867,19 @@ GenSymSimpleConstrainedNoSpec (Rep a), MonadFresh m, MonadError e m, - UnionLike m, + MonadUnion m, Mergeable a ) => e -> () -> m a -derivedSimpleFreshConstrainedNoSpec e _ = merge $ (merge . fmap to) $ simpleFreshConstrainedNoSpec e +derivedSimpleFreshConstrainedNoSpec e _ = tryMerge $ (tryMerge . fmap to) $ simpleFreshConstrainedNoSpec e class GenSymConstrainedSameShape a where simpleFreshConstrainedSameShape :: ( MonadFresh m, MonadError e m, - UnionLike m + MonadUnion m ) => e -> a c -> @@ -918,9 +928,9 @@ Mergeable a, MonadFresh m, MonadError e m, - UnionLike m + MonadUnion m ) => e -> a -> m a -derivedSimpleFreshConstrainedSameShape e a = merge $ (merge . fmap to) $ simpleFreshConstrainedSameShape e (from a) +derivedSimpleFreshConstrainedSameShape e a = tryMerge $ (tryMerge . fmap to) $ simpleFreshConstrainedSameShape e (from a) diff --git a/src/Grisette/Experimental/MonadParallelUnion.hs b/src/Grisette/Experimental/MonadParallelUnion.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Experimental/MonadParallelUnion.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE LambdaCase #-} + +-- | +-- Module : Grisette.Experimental.MonadParallelUnion +-- Copyright : (c) Sirui Lu 2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Experimental.MonadParallelUnion + ( MonadParallelUnion (..), + ) +where + +import Control.DeepSeq (NFData, force) +import Control.Monad.Except (ExceptT (ExceptT), runExceptT) +import Control.Monad.Identity (IdentityT (IdentityT, runIdentityT)) +import qualified Control.Monad.RWS.Lazy as RWSLazy +import qualified Control.Monad.RWS.Strict as RWSStrict +import Control.Monad.Reader (ReaderT (ReaderT, runReaderT)) +import qualified Control.Monad.State.Lazy as StateLazy +import qualified Control.Monad.State.Strict as StateStrict +import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import Control.Parallel.Strategies (rpar, rseq, runEval) +import Grisette.Internal.Core.Control.Monad.Union (MonadUnion) +import Grisette.Internal.Core.Control.Monad.UnionM (UnionM, underlyingUnion) +import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) +import Grisette.Internal.Core.Data.Class.SimpleMergeable (mrgIf) +import Grisette.Internal.Core.Data.Class.TryMerge (TryMerge, tryMerge) +import Grisette.Internal.Core.Data.Union (Union (UnionIf, UnionSingle)) + +-- | Parallel union monad. +-- +-- With the @QualifiedDo@ extension and the "Grisette.Qualified.ParallelUnionDo" +-- module, one can execute the paths in parallel and merge the results with: +-- +-- > :set -XQualifiedDo -XOverloadedStrings +-- > import Grisette +-- > import qualified Grisette.Qualified.ParallelUnionDo as P +-- > P.do +-- > x <- mrgIf "a" (return 1) (return 2) :: UnionM Int +-- > return $ x + 1 +-- > +-- > -- {If a 2 3} +class (MonadUnion m, TryMerge m) => MonadParallelUnion m where + parBindUnion :: (Mergeable b, NFData b) => m a -> (a -> m b) -> m b + +instance (MonadParallelUnion m) => MonadParallelUnion (MaybeT m) where + parBindUnion (MaybeT x) f = + MaybeT $ + x `parBindUnion` \case + Nothing -> return Nothing + Just x'' -> runMaybeT $ f x'' + {-# INLINE parBindUnion #-} + +instance (MonadParallelUnion m, Mergeable e, NFData e) => MonadParallelUnion (ExceptT e m) where + parBindUnion (ExceptT x) f = + ExceptT $ + x `parBindUnion` \case + Left e -> return $ Left e + Right x'' -> runExceptT $ f x'' + {-# INLINE parBindUnion #-} + +instance (MonadParallelUnion m, Mergeable s, NFData s) => MonadParallelUnion (StateLazy.StateT s m) where + parBindUnion (StateLazy.StateT x) f = StateLazy.StateT $ \s -> + x s `parBindUnion` \case + ~(a, s') -> StateLazy.runStateT (f a) s' + {-# INLINE parBindUnion #-} + +instance (MonadParallelUnion m, Mergeable s, NFData s) => MonadParallelUnion (StateStrict.StateT s m) where + parBindUnion (StateStrict.StateT x) f = StateStrict.StateT $ \s -> + x s `parBindUnion` \case + (a, s') -> StateStrict.runStateT (f a) s' + {-# INLINE parBindUnion #-} + +instance (MonadParallelUnion m, Mergeable s, Monoid s, NFData s) => MonadParallelUnion (WriterLazy.WriterT s m) where + parBindUnion (WriterLazy.WriterT x) f = + WriterLazy.WriterT $ + x `parBindUnion` \case + ~(a, w) -> + WriterLazy.runWriterT (f a) `parBindUnion` \case + ~(b, w') -> return (b, w <> w') + {-# INLINE parBindUnion #-} + +instance (MonadParallelUnion m, Mergeable s, Monoid s, NFData s) => MonadParallelUnion (WriterStrict.WriterT s m) where + parBindUnion (WriterStrict.WriterT x) f = + WriterStrict.WriterT $ + x `parBindUnion` \case + (a, w) -> + WriterStrict.runWriterT (f a) `parBindUnion` \case + (b, w') -> return (b, w <> w') + {-# INLINE parBindUnion #-} + +instance (MonadParallelUnion m, Mergeable a, NFData a) => MonadParallelUnion (ReaderT a m) where + parBindUnion (ReaderT x) f = ReaderT $ \a -> + x a `parBindUnion` \a' -> runReaderT (f a') a + {-# INLINE parBindUnion #-} + +instance (MonadParallelUnion m) => MonadParallelUnion (IdentityT m) where + parBindUnion (IdentityT x) f = IdentityT $ x `parBindUnion` (tryMerge . runIdentityT . f) + {-# INLINE parBindUnion #-} + +instance + (MonadParallelUnion m, Mergeable s, Mergeable r, Mergeable w, Monoid w, NFData r, NFData w, NFData s) => + MonadParallelUnion (RWSStrict.RWST r w s m) + where + parBindUnion m k = RWSStrict.RWST $ \r s -> + RWSStrict.runRWST m r s `parBindUnion` \case + (a, s', w) -> + RWSStrict.runRWST (k a) r s' `parBindUnion` \case + (b, s'', w') -> return (b, s'', w <> w') + {-# INLINE parBindUnion #-} + +instance + (MonadParallelUnion m, Mergeable s, Mergeable r, Mergeable w, Monoid w, NFData r, NFData w, NFData s) => + MonadParallelUnion (RWSLazy.RWST r w s m) + where + parBindUnion m k = RWSLazy.RWST $ \r s -> + RWSLazy.runRWST m r s `parBindUnion` \case + ~(a, s', w) -> + RWSLazy.runRWST (k a) r s' `parBindUnion` \case + ~(b, s'', w') -> return (b, s'', w <> w') + {-# INLINE parBindUnion #-} + +parBindUnion'' :: (Mergeable b, NFData b) => Union a -> (a -> UnionM b) -> UnionM b +parBindUnion'' (UnionSingle a) f = tryMerge $ f a +parBindUnion'' u f = parBindUnion' u f + +parBindUnion' :: (Mergeable b, NFData b) => Union a -> (a -> UnionM b) -> UnionM b +parBindUnion' (UnionSingle a') f' = f' a' +parBindUnion' (UnionIf _ _ cond ifTrue ifFalse) f' = runEval $ do + l <- rpar $ force $ parBindUnion' ifTrue f' + r <- rpar $ force $ parBindUnion' ifFalse f' + l' <- rseq l + r' <- rseq r + rseq $ mrgIf cond l' r' +{-# INLINE parBindUnion' #-} + +instance MonadParallelUnion UnionM where + parBindUnion = parBindUnion'' . underlyingUnion + {-# INLINE parBindUnion #-} diff --git a/src/Grisette/Experimental/Qualified/ParallelUnionDo.hs b/src/Grisette/Experimental/Qualified/ParallelUnionDo.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Experimental/Qualified/ParallelUnionDo.hs @@ -0,0 +1,22 @@ +-- | +-- Module : Grisette.Qualified.ParallelUnionDo +-- Copyright : (c) Sirui Lu 2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Experimental.Qualified.ParallelUnionDo ((>>=), (>>)) where + +import Control.Parallel.Strategies (NFData) +import Grisette.Experimental.MonadParallelUnion + ( MonadParallelUnion (parBindUnion), + ) +import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) +import Prelude (const, ($)) + +(>>=) :: (MonadParallelUnion m, Mergeable b, NFData b) => m a -> (a -> m b) -> m b +(>>=) = parBindUnion + +(>>) :: (MonadParallelUnion m, Mergeable b, NFData b) => m a -> m b -> m b +(>>) a b = parBindUnion a $ const b diff --git a/src/Grisette/IR/SymPrim.hs b/src/Grisette/IR/SymPrim.hs deleted file mode 100644 --- a/src/Grisette/IR/SymPrim.hs +++ /dev/null @@ -1,87 +0,0 @@ -{-# LANGUAGE ExplicitNamespaces #-} --- Disable this warning because we are re-exporting things. -{-# OPTIONS_GHC -Wno-missing-import-lists #-} - --- | --- Module : Grisette.IR.SymPrim --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.IR.SymPrim - ( -- * Symbolic type implementation - - -- ** Extended types - IntN, - WordN, - SomeWordN (..), - SomeIntN (..), - type (=->) (..), - type (-->), - (-->), - - -- ** Symbolic types - SupportedPrim, - SymRep (SymType), - ConRep (ConType), - LinkedRep, - SymBool (..), - SymInteger (..), - SymWordN (..), - SymIntN (..), - SomeSymWordN (..), - SomeSymIntN (..), - type (=~>) (..), - type (-~>) (..), - TypedSymbol (..), - symSize, - symsSize, - AllSyms (..), - allSymsSize, - - -- ** Symbolic constant sets and models - SymbolSet (..), - Model (..), - ModelValuePair (..), - ModelSymPair (..), - ) -where - -import Grisette.Core.Data.BV - ( IntN, - SomeIntN (..), - SomeWordN (..), - WordN, - ) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term - ( ConRep (..), - LinkedRep, - SupportedPrim, - SymRep (..), - TypedSymbol (..), - type (-->), - ) -import Grisette.IR.SymPrim.Data.Prim.Model - ( Model (..), - ModelValuePair (..), - SymbolSet (..), - ) -import Grisette.IR.SymPrim.Data.SymPrim - ( AllSyms (..), - ModelSymPair (..), - SomeSymIntN (..), - SomeSymWordN (..), - SymBool (..), - SymIntN (..), - SymInteger (..), - SymWordN (..), - allSymsSize, - symSize, - symsSize, - (-->), - type (-~>) (..), - type (=~>) (..), - ) -import Grisette.IR.SymPrim.Data.TabularFun (type (=->) (..)) diff --git a/src/Grisette/IR/SymPrim/Data/IntBitwidth.hs b/src/Grisette/IR/SymPrim/Data/IntBitwidth.hs deleted file mode 100644 --- a/src/Grisette/IR/SymPrim/Data/IntBitwidth.hs +++ /dev/null @@ -1,15 +0,0 @@ --- | --- Module : Grisette.IR.SymPrim.Data.IntBitwidth --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.IR.SymPrim.Data.IntBitwidth (intBitwidthQ) where - -import Data.Bits (FiniteBits (finiteBitSize)) -import Language.Haskell.TH (TyLit (NumTyLit), Type (LitT), TypeQ) - -intBitwidthQ :: TypeQ -intBitwidthQ = return $ LitT (NumTyLit $ toInteger $ finiteBitSize (undefined :: Int)) diff --git a/src/Grisette/IR/SymPrim/Data/Prim/Helpers.hs b/src/Grisette/IR/SymPrim/Data/Prim/Helpers.hs deleted file mode 100644 --- a/src/Grisette/IR/SymPrim/Data/Prim/Helpers.hs +++ /dev/null @@ -1,124 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} - --- | --- Module : Grisette.IR.SymPrim.Data.Prim.Helpers --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.IR.SymPrim.Data.Prim.Helpers - ( pattern UnaryTermPatt, - pattern BinaryTermPatt, - pattern TernaryTermPatt, - pattern UnsafeUnaryTermPatt, - pattern UnsafeBinaryTermPatt, - pattern Unsafe1t21BinaryTermPatt, - pattern Unsafe1u2t32TernaryTermPatt, - ) -where - -import Data.Typeable (Typeable, cast) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term - ( Term (BinaryTerm, TernaryTerm, UnaryTerm), - ) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermUtils - ( castTerm, - ) -import Unsafe.Coerce (unsafeCoerce) - -unsafeUnaryTermView :: forall a b tag. (Typeable tag) => Term a -> Maybe (tag, Term b) -unsafeUnaryTermView (UnaryTerm _ (tag :: tagt) t1) = - case cast tag of - Just t -> Just (t, unsafeCoerce t1) - Nothing -> Nothing --- (,) <$> cast tag <*> castTerm t1 -unsafeUnaryTermView _ = Nothing - -pattern UnsafeUnaryTermPatt :: forall a b tag. (Typeable tag) => tag -> Term b -> Term a -pattern UnsafeUnaryTermPatt tag t <- (unsafeUnaryTermView @a @b @tag -> Just (tag, t)) - -unaryTermView :: forall a b tag. (Typeable tag, Typeable b) => Term a -> Maybe (tag, Term b) -unaryTermView (UnaryTerm _ (tag :: tagt) t1) = - (,) <$> cast tag <*> castTerm t1 -unaryTermView _ = Nothing - -pattern UnaryTermPatt :: forall a b tag. (Typeable tag, Typeable b) => tag -> Term b -> Term a -pattern UnaryTermPatt tag t <- (unaryTermView @a @b @tag -> Just (tag, t)) - -unsafeBinaryTermView :: forall a b c tag. (Typeable tag) => Term a -> Maybe (tag, Term b, Term c) -unsafeBinaryTermView (BinaryTerm _ (tag :: tagt) t1 t2) = - case cast tag of - Just t -> Just (t, unsafeCoerce t1, unsafeCoerce t2) - Nothing -> Nothing --- (,) <$> cast tag <*> castTerm t1 -unsafeBinaryTermView _ = Nothing - -pattern UnsafeBinaryTermPatt :: forall a b c tag. (Typeable tag) => tag -> Term b -> Term c -> Term a -pattern UnsafeBinaryTermPatt tag t1 t2 <- (unsafeBinaryTermView @a @b @c @tag -> Just (tag, t1, t2)) - -unsafe1t21BinaryTermView :: forall a b tag. (Typeable tag, Typeable b) => Term a -> Maybe (tag, Term b, Term b) -unsafe1t21BinaryTermView (BinaryTerm _ (tag :: tagt) t1 t2) = - case (cast tag, cast t1) of - (Just tg, Just t1') -> Just (tg, t1', unsafeCoerce t2) - _ -> Nothing --- (,) <$> cast tag <*> castTerm t1 -unsafe1t21BinaryTermView _ = Nothing - -pattern Unsafe1t21BinaryTermPatt :: forall a b tag. (Typeable tag, Typeable b) => tag -> Term b -> Term b -> Term a -pattern Unsafe1t21BinaryTermPatt tag t1 t2 <- (unsafe1t21BinaryTermView @a @b @tag -> Just (tag, t1, t2)) - -binaryTermView :: forall a b c tag. (Typeable tag, Typeable b, Typeable c) => Term a -> Maybe (tag, Term b, Term c) -binaryTermView (BinaryTerm _ (tag :: tagt) t1 t2) = - (,,) <$> cast tag <*> castTerm t1 <*> castTerm t2 -binaryTermView _ = Nothing - -pattern BinaryTermPatt :: forall a b c tag. (Typeable tag, Typeable b, Typeable c) => tag -> Term b -> Term c -> Term a -pattern BinaryTermPatt tag l r <- (binaryTermView @a @b @c @tag -> Just (tag, l, r)) - -unsafe1u2t32TernaryTermView :: - forall a b c tag. - (Typeable tag, Typeable c) => - Term a -> - Maybe (tag, Term b, Term c, Term c) -unsafe1u2t32TernaryTermView (TernaryTerm _ (tag :: tagt) t1 t2 t3) = - case (cast tag, castTerm t2) of - (Just tg, Just t2') -> Just (tg, unsafeCoerce t1, t2', unsafeCoerce t3) - _ -> Nothing -unsafe1u2t32TernaryTermView _ = Nothing - -pattern Unsafe1u2t32TernaryTermPatt :: - forall a b c tag. - (Typeable tag, Typeable c) => - tag -> - Term b -> - Term c -> - Term c -> - Term a -pattern Unsafe1u2t32TernaryTermPatt tag a b c <- - (unsafe1u2t32TernaryTermView @a @b @c @tag -> Just (tag, a, b, c)) - -ternaryTermView :: - forall a b c d tag. - (Typeable tag, Typeable b, Typeable c, Typeable d) => - Term a -> - Maybe (tag, Term b, Term c, Term d) -ternaryTermView (TernaryTerm _ (tag :: tagt) t1 t2 t3) = - (,,,) <$> cast tag <*> castTerm t1 <*> castTerm t2 <*> castTerm t3 -ternaryTermView _ = Nothing - -pattern TernaryTermPatt :: - forall a b c d tag. - (Typeable tag, Typeable b, Typeable c, Typeable d) => - tag -> - Term b -> - Term c -> - Term d -> - Term a -pattern TernaryTermPatt tag a b c <- (ternaryTermView @a @b @c @d @tag -> Just (tag, a, b, c)) diff --git a/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/Caches.hs b/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/Caches.hs deleted file mode 100644 --- a/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/Caches.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -fno-cse #-} - --- | --- Module : Grisette.IR.SymPrim.Data.Prim.InternedTerm.Caches --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.IR.SymPrim.Data.Prim.InternedTerm.Caches (typeMemoizedCache) where - -import Control.Concurrent - ( forkIO, - newEmptyMVar, - putMVar, - readMVar, - takeMVar, - tryPutMVar, - ) -import Data.Data (Proxy (Proxy), TypeRep, Typeable, typeRep) -import qualified Data.HashMap.Strict as M -import Data.IORef (IORef, atomicModifyIORef', newIORef) -import Data.Interned (Cache, Interned, mkCache) -import GHC.Base (Any) -import GHC.IO (unsafeDupablePerformIO, unsafePerformIO) -import Unsafe.Coerce (unsafeCoerce) - -mkOnceIO :: IO a -> IO (IO a) -mkOnceIO io = do - mv <- newEmptyMVar - demand <- newEmptyMVar - forkIO (takeMVar demand >> io >>= putMVar mv) - return (tryPutMVar demand () >> readMVar mv) - -termCacheCell :: IO (IORef (M.HashMap TypeRep Any)) -termCacheCell = unsafePerformIO $ mkOnceIO $ newIORef M.empty -{-# NOINLINE termCacheCell #-} - -typeMemoizedCache :: forall a. (Interned a, Typeable a) => Cache a -typeMemoizedCache = unsafeDupablePerformIO $ do - c <- termCacheCell - atomicModifyIORef' c $ \m -> - case M.lookup (typeRep (Proxy @a)) m of - Just d -> (m, unsafeCoerce d) - Nothing -> (M.insert (typeRep (Proxy @a)) (unsafeCoerce r1) m, r1) - where - r1 :: Cache a - !r1 = mkCache - {-# NOINLINE r1 #-} diff --git a/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/InternedCtors.hs b/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/InternedCtors.hs deleted file mode 100644 --- a/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/InternedCtors.hs +++ /dev/null @@ -1,448 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- Module : Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors - ( constructUnary, - constructBinary, - constructTernary, - conTerm, - symTerm, - ssymTerm, - isymTerm, - sinfosymTerm, - iinfosymTerm, - notTerm, - orTerm, - andTerm, - eqvTerm, - iteTerm, - addNumTerm, - uminusNumTerm, - timesNumTerm, - absNumTerm, - signumNumTerm, - ltNumTerm, - leNumTerm, - andBitsTerm, - orBitsTerm, - xorBitsTerm, - complementBitsTerm, - shiftLeftTerm, - shiftRightTerm, - rotateLeftTerm, - rotateRightTerm, - toSignedTerm, - toUnsignedTerm, - bvconcatTerm, - bvselectTerm, - bvextendTerm, - bvsignExtendTerm, - bvzeroExtendTerm, - tabularFunApplyTerm, - generalFunApplyTerm, - divIntegralTerm, - modIntegralTerm, - quotIntegralTerm, - remIntegralTerm, - divBoundedIntegralTerm, - modBoundedIntegralTerm, - quotBoundedIntegralTerm, - remBoundedIntegralTerm, - ) -where - -import Control.DeepSeq (NFData) -import Data.Array ((!)) -import Data.Bits (Bits, FiniteBits) -import qualified Data.HashMap.Strict as M -import Data.Hashable (Hashable (hash)) -import Data.IORef (atomicModifyIORef') -import Data.Interned - ( Interned (Uninterned, cache, cacheWidth, describe, identify), - ) -import Data.Interned.Internal - ( Cache (getCache), - CacheState (CacheState), - ) -import qualified Data.Text as T -import GHC.IO (unsafeDupablePerformIO) -import GHC.TypeNats (KnownNat, type (+), type (<=)) -import Grisette.Core.Data.Class.BitVector - ( SizedBV, - ) -import Grisette.Core.Data.Class.SignConversion (SignConversion) -import Grisette.Core.Data.Class.SymRotate (SymRotate) -import Grisette.Core.Data.Class.SymShift (SymShift) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term - ( BinaryOp, - SupportedPrim, - Term, - TernaryOp, - TypedSymbol (IndexedSymbol, SimpleSymbol, WithInfo), - UTerm - ( UAbsNumTerm, - UAddNumTerm, - UAndBitsTerm, - UAndTerm, - UBVConcatTerm, - UBVExtendTerm, - UBVSelectTerm, - UBinaryTerm, - UComplementBitsTerm, - UConTerm, - UDivBoundedIntegralTerm, - UDivIntegralTerm, - UEqvTerm, - UGeneralFunApplyTerm, - UITETerm, - ULENumTerm, - ULTNumTerm, - UModBoundedIntegralTerm, - UModIntegralTerm, - UNotTerm, - UOrBitsTerm, - UOrTerm, - UQuotBoundedIntegralTerm, - UQuotIntegralTerm, - URemBoundedIntegralTerm, - URemIntegralTerm, - URotateLeftTerm, - URotateRightTerm, - UShiftLeftTerm, - UShiftRightTerm, - USignumNumTerm, - USymTerm, - UTabularFunApplyTerm, - UTernaryTerm, - UTimesNumTerm, - UToSignedTerm, - UToUnsignedTerm, - UUMinusNumTerm, - UUnaryTerm, - UXorBitsTerm - ), - UnaryOp, - type (-->), - ) -import Grisette.IR.SymPrim.Data.TabularFun - ( type (=->), - ) -import Language.Haskell.TH.Syntax (Lift) -import Type.Reflection (Typeable, typeRep) - -internTerm :: forall t. (SupportedPrim t) => Uninterned (Term t) -> Term t -internTerm !bt = unsafeDupablePerformIO $ atomicModifyIORef' slot go - where - slot = getCache cache ! r - !dt = describe bt - !hdt = hash dt - !wid = cacheWidth dt - r = hdt `mod` wid - go (CacheState i m) = case M.lookup dt m of - Nothing -> let t = identify (wid * i + r) bt in (CacheState (i + 1) (M.insert dt t m), t) - Just t -> (CacheState i m, t) - -constructUnary :: - forall tag arg t. - (SupportedPrim t, UnaryOp tag arg t, Typeable tag, Typeable t, Show tag) => - tag -> - Term arg -> - Term t -constructUnary tag tm = let x = internTerm $ UUnaryTerm tag tm in x -{-# INLINE constructUnary #-} - -constructBinary :: - forall tag arg1 arg2 t. - (SupportedPrim t, BinaryOp tag arg1 arg2 t, Typeable tag, Typeable t, Show tag) => - tag -> - Term arg1 -> - Term arg2 -> - Term t -constructBinary tag tm1 tm2 = internTerm $ UBinaryTerm tag tm1 tm2 -{-# INLINE constructBinary #-} - -constructTernary :: - forall tag arg1 arg2 arg3 t. - (SupportedPrim t, TernaryOp tag arg1 arg2 arg3 t, Typeable tag, Typeable t, Show tag) => - tag -> - Term arg1 -> - Term arg2 -> - Term arg3 -> - Term t -constructTernary tag tm1 tm2 tm3 = internTerm $ UTernaryTerm tag tm1 tm2 tm3 -{-# INLINE constructTernary #-} - -conTerm :: (SupportedPrim t, Typeable t, Hashable t, Eq t, Show t) => t -> Term t -conTerm t = internTerm $ UConTerm t -{-# INLINE conTerm #-} - -symTerm :: forall t. (SupportedPrim t, Typeable t) => TypedSymbol t -> Term t -symTerm t = internTerm $ USymTerm t -{-# INLINE symTerm #-} - -ssymTerm :: (SupportedPrim t, Typeable t) => T.Text -> Term t -ssymTerm = symTerm . SimpleSymbol -{-# INLINE ssymTerm #-} - -isymTerm :: (SupportedPrim t, Typeable t) => T.Text -> Int -> Term t -isymTerm str idx = symTerm $ IndexedSymbol str idx -{-# INLINE isymTerm #-} - -sinfosymTerm :: - (SupportedPrim t, Typeable t, Typeable a, Ord a, Lift a, NFData a, Show a, Hashable a) => - T.Text -> - a -> - Term t -sinfosymTerm s info = symTerm $ WithInfo (SimpleSymbol s) info -{-# INLINE sinfosymTerm #-} - -iinfosymTerm :: - (SupportedPrim t, Typeable t, Typeable a, Ord a, Lift a, NFData a, Show a, Hashable a) => - T.Text -> - Int -> - a -> - Term t -iinfosymTerm str idx info = symTerm $ WithInfo (IndexedSymbol str idx) info -{-# INLINE iinfosymTerm #-} - -notTerm :: Term Bool -> Term Bool -notTerm = internTerm . UNotTerm -{-# INLINE notTerm #-} - -orTerm :: Term Bool -> Term Bool -> Term Bool -orTerm l r = internTerm $ UOrTerm l r -{-# INLINE orTerm #-} - -andTerm :: Term Bool -> Term Bool -> Term Bool -andTerm l r = internTerm $ UAndTerm l r -{-# INLINE andTerm #-} - -eqvTerm :: (SupportedPrim a) => Term a -> Term a -> Term Bool -eqvTerm l r = internTerm $ UEqvTerm l r -{-# INLINE eqvTerm #-} - -iteTerm :: (SupportedPrim a) => Term Bool -> Term a -> Term a -> Term a -iteTerm c l r = internTerm $ UITETerm c l r -{-# INLINE iteTerm #-} - -addNumTerm :: (SupportedPrim a, Num a) => Term a -> Term a -> Term a -addNumTerm l r = internTerm $ UAddNumTerm l r -{-# INLINE addNumTerm #-} - -uminusNumTerm :: (SupportedPrim a, Num a) => Term a -> Term a -uminusNumTerm = internTerm . UUMinusNumTerm -{-# INLINE uminusNumTerm #-} - -timesNumTerm :: (SupportedPrim a, Num a) => Term a -> Term a -> Term a -timesNumTerm l r = internTerm $ UTimesNumTerm l r -{-# INLINE timesNumTerm #-} - -absNumTerm :: (SupportedPrim a, Num a) => Term a -> Term a -absNumTerm = internTerm . UAbsNumTerm -{-# INLINE absNumTerm #-} - -signumNumTerm :: (SupportedPrim a, Num a) => Term a -> Term a -signumNumTerm = internTerm . USignumNumTerm -{-# INLINE signumNumTerm #-} - -ltNumTerm :: (SupportedPrim a, Num a, Ord a) => Term a -> Term a -> Term Bool -ltNumTerm l r = internTerm $ ULTNumTerm l r -{-# INLINE ltNumTerm #-} - -leNumTerm :: (SupportedPrim a, Num a, Ord a) => Term a -> Term a -> Term Bool -leNumTerm l r = internTerm $ ULENumTerm l r -{-# INLINE leNumTerm #-} - -andBitsTerm :: (SupportedPrim a, Bits a) => Term a -> Term a -> Term a -andBitsTerm l r = internTerm $ UAndBitsTerm l r -{-# INLINE andBitsTerm #-} - -orBitsTerm :: (SupportedPrim a, Bits a) => Term a -> Term a -> Term a -orBitsTerm l r = internTerm $ UOrBitsTerm l r -{-# INLINE orBitsTerm #-} - -xorBitsTerm :: (SupportedPrim a, Bits a) => Term a -> Term a -> Term a -xorBitsTerm l r = internTerm $ UXorBitsTerm l r -{-# INLINE xorBitsTerm #-} - -complementBitsTerm :: (SupportedPrim a, Bits a) => Term a -> Term a -complementBitsTerm = internTerm . UComplementBitsTerm -{-# INLINE complementBitsTerm #-} - -shiftLeftTerm :: (SupportedPrim a, Integral a, FiniteBits a, SymShift a) => Term a -> Term a -> Term a -shiftLeftTerm t n = internTerm $ UShiftLeftTerm t n -{-# INLINE shiftLeftTerm #-} - -shiftRightTerm :: (SupportedPrim a, Integral a, FiniteBits a, SymShift a) => Term a -> Term a -> Term a -shiftRightTerm t n = internTerm $ UShiftRightTerm t n -{-# INLINE shiftRightTerm #-} - -rotateLeftTerm :: (SupportedPrim a, Integral a, FiniteBits a, SymRotate a) => Term a -> Term a -> Term a -rotateLeftTerm t n = internTerm $ URotateLeftTerm t n -{-# INLINE rotateLeftTerm #-} - -rotateRightTerm :: (SupportedPrim a, Integral a, FiniteBits a, SymRotate a) => Term a -> Term a -> Term a -rotateRightTerm t n = internTerm $ URotateRightTerm t n -{-# INLINE rotateRightTerm #-} - -toSignedTerm :: - ( SupportedPrim u, - SupportedPrim s, - SignConversion u s - ) => - Term u -> - Term s -toSignedTerm = internTerm . UToSignedTerm - -toUnsignedTerm :: - ( SupportedPrim u, - SupportedPrim s, - SignConversion u s - ) => - Term s -> - Term u -toUnsignedTerm = internTerm . UToUnsignedTerm - -bvconcatTerm :: - ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n), - Typeable bv, - KnownNat a, - KnownNat b, - KnownNat (a + b), - 1 <= a, - 1 <= b, - 1 <= a + b, - SizedBV bv - ) => - Term (bv a) -> - Term (bv b) -> - Term (bv (a + b)) -bvconcatTerm l r = internTerm $ UBVConcatTerm l r -{-# INLINE bvconcatTerm #-} - -bvselectTerm :: - forall bv n ix w p q. - ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n), - Typeable bv, - KnownNat n, - KnownNat ix, - KnownNat w, - 1 <= n, - 1 <= w, - ix + w <= n, - SizedBV bv - ) => - p ix -> - q w -> - Term (bv n) -> - Term (bv w) -bvselectTerm _ _ v = internTerm $ UBVSelectTerm (typeRep @ix) (typeRep @w) v -{-# INLINE bvselectTerm #-} - -bvextendTerm :: - forall bv l r proxy. - ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n), - Typeable bv, - KnownNat l, - KnownNat r, - 1 <= l, - 1 <= r, - l <= r, - SizedBV bv - ) => - Bool -> - proxy r -> - Term (bv l) -> - Term (bv r) -bvextendTerm signed _ v = internTerm $ UBVExtendTerm signed (typeRep @r) v -{-# INLINE bvextendTerm #-} - -bvsignExtendTerm :: - forall bv l r proxy. - ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n), - Typeable bv, - KnownNat l, - KnownNat r, - 1 <= l, - 1 <= r, - l <= r, - SizedBV bv - ) => - proxy r -> - Term (bv l) -> - Term (bv r) -bvsignExtendTerm _ v = internTerm $ UBVExtendTerm True (typeRep @r) v -{-# INLINE bvsignExtendTerm #-} - -bvzeroExtendTerm :: - forall bv l r proxy. - ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n), - Typeable bv, - KnownNat l, - KnownNat r, - 1 <= l, - 1 <= r, - l <= r, - SizedBV bv - ) => - proxy r -> - Term (bv l) -> - Term (bv r) -bvzeroExtendTerm _ v = internTerm $ UBVExtendTerm False (typeRep @r) v -{-# INLINE bvzeroExtendTerm #-} - -tabularFunApplyTerm :: (SupportedPrim a, SupportedPrim b) => Term (a =-> b) -> Term a -> Term b -tabularFunApplyTerm f a = internTerm $ UTabularFunApplyTerm f a -{-# INLINE tabularFunApplyTerm #-} - -generalFunApplyTerm :: (SupportedPrim a, SupportedPrim b) => Term (a --> b) -> Term a -> Term b -generalFunApplyTerm f a = internTerm $ UGeneralFunApplyTerm f a -{-# INLINE generalFunApplyTerm #-} - -divIntegralTerm :: (SupportedPrim a, Integral a) => Term a -> Term a -> Term a -divIntegralTerm l r = internTerm $ UDivIntegralTerm l r -{-# INLINE divIntegralTerm #-} - -modIntegralTerm :: (SupportedPrim a, Integral a) => Term a -> Term a -> Term a -modIntegralTerm l r = internTerm $ UModIntegralTerm l r -{-# INLINE modIntegralTerm #-} - -quotIntegralTerm :: (SupportedPrim a, Integral a) => Term a -> Term a -> Term a -quotIntegralTerm l r = internTerm $ UQuotIntegralTerm l r -{-# INLINE quotIntegralTerm #-} - -remIntegralTerm :: (SupportedPrim a, Integral a) => Term a -> Term a -> Term a -remIntegralTerm l r = internTerm $ URemIntegralTerm l r -{-# INLINE remIntegralTerm #-} - -divBoundedIntegralTerm :: (SupportedPrim a, Bounded a, Integral a) => Term a -> Term a -> Term a -divBoundedIntegralTerm l r = internTerm $ UDivBoundedIntegralTerm l r -{-# INLINE divBoundedIntegralTerm #-} - -modBoundedIntegralTerm :: (SupportedPrim a, Bounded a, Integral a) => Term a -> Term a -> Term a -modBoundedIntegralTerm l r = internTerm $ UModBoundedIntegralTerm l r -{-# INLINE modBoundedIntegralTerm #-} - -quotBoundedIntegralTerm :: (SupportedPrim a, Bounded a, Integral a) => Term a -> Term a -> Term a -quotBoundedIntegralTerm l r = internTerm $ UQuotBoundedIntegralTerm l r -{-# INLINE quotBoundedIntegralTerm #-} - -remBoundedIntegralTerm :: (SupportedPrim a, Bounded a, Integral a) => Term a -> Term a -> Term a -remBoundedIntegralTerm l r = internTerm $ URemBoundedIntegralTerm l r -{-# INLINE remBoundedIntegralTerm #-} diff --git a/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/InternedCtors.hs-boot b/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/InternedCtors.hs-boot deleted file mode 100644 --- a/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/InternedCtors.hs-boot +++ /dev/null @@ -1,237 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -module Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors - ( constructUnary, - constructBinary, - constructTernary, - conTerm, - symTerm, - ssymTerm, - isymTerm, - sinfosymTerm, - iinfosymTerm, - notTerm, - orTerm, - andTerm, - eqvTerm, - iteTerm, - addNumTerm, - uminusNumTerm, - timesNumTerm, - absNumTerm, - signumNumTerm, - ltNumTerm, - leNumTerm, - andBitsTerm, - orBitsTerm, - xorBitsTerm, - complementBitsTerm, - shiftLeftTerm, - shiftRightTerm, - rotateLeftTerm, - rotateRightTerm, - toSignedTerm, - toUnsignedTerm, - bvconcatTerm, - bvselectTerm, - bvextendTerm, - bvsignExtendTerm, - bvzeroExtendTerm, - tabularFunApplyTerm, - generalFunApplyTerm, - divIntegralTerm, - modIntegralTerm, - quotIntegralTerm, - remIntegralTerm, - divBoundedIntegralTerm, - modBoundedIntegralTerm, - quotBoundedIntegralTerm, - remBoundedIntegralTerm, - ) -where - -import Control.DeepSeq (NFData) -import Data.Bits (Bits, FiniteBits) -import Data.Hashable (Hashable) -import qualified Data.Text as T -import Data.Typeable (Typeable) -import GHC.TypeNats (KnownNat, type (+), type (<=)) -import Grisette.Core.Data.Class.BitVector - ( SizedBV, - ) -import Grisette.Core.Data.Class.SignConversion (SignConversion) -import Grisette.Core.Data.Class.SymRotate (SymRotate) -import Grisette.Core.Data.Class.SymShift (SymShift) -import {-# SOURCE #-} Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term - ( BinaryOp, - SupportedPrim, - Term, - TernaryOp, - TypedSymbol, - UnaryOp, - type (-->), - ) -import Grisette.IR.SymPrim.Data.TabularFun - ( type (=->), - ) -import Language.Haskell.TH.Syntax (Lift) - -constructUnary :: - forall tag arg t. - (SupportedPrim t, UnaryOp tag arg t, Typeable tag, Typeable t, Show tag) => - tag -> - Term arg -> - Term t -constructBinary :: - forall tag arg1 arg2 t. - (SupportedPrim t, BinaryOp tag arg1 arg2 t, Typeable tag, Typeable t, Show tag) => - tag -> - Term arg1 -> - Term arg2 -> - Term t -constructTernary :: - forall tag arg1 arg2 arg3 t. - (SupportedPrim t, TernaryOp tag arg1 arg2 arg3 t, Typeable tag, Typeable t, Show tag) => - tag -> - Term arg1 -> - Term arg2 -> - Term arg3 -> - Term t -conTerm :: (SupportedPrim t, Typeable t, Hashable t, Eq t, Show t) => t -> Term t -symTerm :: (SupportedPrim t, Typeable t) => TypedSymbol t -> Term t -ssymTerm :: (SupportedPrim t, Typeable t) => T.Text -> Term t -isymTerm :: (SupportedPrim t, Typeable t) => T.Text -> Int -> Term t -sinfosymTerm :: - (SupportedPrim t, Typeable t, Typeable a, Ord a, Lift a, NFData a, Show a, Hashable a) => - T.Text -> - a -> - Term t -iinfosymTerm :: - (SupportedPrim t, Typeable t, Typeable a, Ord a, Lift a, NFData a, Show a, Hashable a) => - T.Text -> - Int -> - a -> - Term t -notTerm :: Term Bool -> Term Bool -orTerm :: Term Bool -> Term Bool -> Term Bool -andTerm :: Term Bool -> Term Bool -> Term Bool -eqvTerm :: (SupportedPrim a) => Term a -> Term a -> Term Bool -iteTerm :: (SupportedPrim a) => Term Bool -> Term a -> Term a -> Term a -addNumTerm :: (SupportedPrim a, Num a) => Term a -> Term a -> Term a -uminusNumTerm :: (SupportedPrim a, Num a) => Term a -> Term a -timesNumTerm :: (SupportedPrim a, Num a) => Term a -> Term a -> Term a -absNumTerm :: (SupportedPrim a, Num a) => Term a -> Term a -signumNumTerm :: (SupportedPrim a, Num a) => Term a -> Term a -ltNumTerm :: (SupportedPrim a, Num a, Ord a) => Term a -> Term a -> Term Bool -leNumTerm :: (SupportedPrim a, Num a, Ord a) => Term a -> Term a -> Term Bool -andBitsTerm :: (SupportedPrim a, Bits a) => Term a -> Term a -> Term a -orBitsTerm :: (SupportedPrim a, Bits a) => Term a -> Term a -> Term a -xorBitsTerm :: (SupportedPrim a, Bits a) => Term a -> Term a -> Term a -complementBitsTerm :: (SupportedPrim a, Bits a) => Term a -> Term a -shiftLeftTerm :: (SupportedPrim a, Integral a, FiniteBits a, SymShift a) => Term a -> Term a -> Term a -shiftRightTerm :: (SupportedPrim a, Integral a, FiniteBits a, SymShift a) => Term a -> Term a -> Term a -rotateLeftTerm :: (SupportedPrim a, Integral a, FiniteBits a, SymRotate a) => Term a -> Term a -> Term a -rotateRightTerm :: (SupportedPrim a, Integral a, FiniteBits a, SymRotate a) => Term a -> Term a -> Term a -toSignedTerm :: - ( SupportedPrim u, - SupportedPrim s, - SignConversion u s - ) => - Term u -> - Term s -toUnsignedTerm :: - ( SupportedPrim u, - SupportedPrim s, - SignConversion u s - ) => - Term s -> - Term u -bvconcatTerm :: - ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n), - Typeable bv, - KnownNat a, - KnownNat b, - KnownNat (a + b), - 1 <= a, - 1 <= b, - 1 <= a + b, - SizedBV bv - ) => - Term (bv a) -> - Term (bv b) -> - Term (bv (a + b)) -bvselectTerm :: - forall bv n ix w p q. - ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n), - Typeable bv, - KnownNat n, - KnownNat ix, - KnownNat w, - 1 <= n, - 1 <= w, - ix + w <= n, - SizedBV bv - ) => - p ix -> - q w -> - Term (bv n) -> - Term (bv w) -bvextendTerm :: - forall bv l r proxy. - ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n), - Typeable bv, - KnownNat l, - KnownNat r, - 1 <= l, - 1 <= r, - l <= r, - SizedBV bv - ) => - Bool -> - proxy r -> - Term (bv l) -> - Term (bv r) -bvsignExtendTerm :: - forall bv l r proxy. - ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n), - Typeable bv, - KnownNat l, - KnownNat r, - 1 <= l, - 1 <= r, - l <= r, - SizedBV bv - ) => - proxy r -> - Term (bv l) -> - Term (bv r) -bvzeroExtendTerm :: - forall bv l r proxy. - ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n), - Typeable bv, - KnownNat l, - KnownNat r, - 1 <= l, - 1 <= r, - l <= r, - SizedBV bv - ) => - proxy r -> - Term (bv l) -> - Term (bv r) -tabularFunApplyTerm :: (SupportedPrim a, SupportedPrim b) => Term (a =-> b) -> Term a -> Term b -generalFunApplyTerm :: (SupportedPrim a, SupportedPrim b) => Term (a --> b) -> Term a -> Term b -divIntegralTerm :: (SupportedPrim a, Integral a) => Term a -> Term a -> Term a -modIntegralTerm :: (SupportedPrim a, Integral a) => Term a -> Term a -> Term a -quotIntegralTerm :: (SupportedPrim a, Integral a) => Term a -> Term a -> Term a -remIntegralTerm :: (SupportedPrim a, Integral a) => Term a -> Term a -> Term a -divBoundedIntegralTerm :: (SupportedPrim a, Bounded a, Integral a) => Term a -> Term a -> Term a -modBoundedIntegralTerm :: (SupportedPrim a, Bounded a, Integral a) => Term a -> Term a -> Term a -quotBoundedIntegralTerm :: (SupportedPrim a, Bounded a, Integral a) => Term a -> Term a -> Term a -remBoundedIntegralTerm :: (SupportedPrim a, Bounded a, Integral a) => Term a -> Term a -> Term a diff --git a/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/SomeTerm.hs b/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/SomeTerm.hs deleted file mode 100644 --- a/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/SomeTerm.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - --- | --- Module : Grisette.IR.SymPrim.Data.Prim.InternedTerm.SomeTerm --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.IR.SymPrim.Data.Prim.InternedTerm.SomeTerm (SomeTerm (..)) where - -import Data.Hashable (Hashable (hashWithSalt)) -import Data.Typeable (Proxy (Proxy), typeRep) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term - ( SupportedPrim, - Term, - ) -import {-# SOURCE #-} Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermUtils - ( identityWithTypeRep, - ) - -data SomeTerm where - SomeTerm :: forall a. (SupportedPrim a) => Term a -> SomeTerm - -instance Eq SomeTerm where - (SomeTerm t1) == (SomeTerm t2) = identityWithTypeRep t1 == identityWithTypeRep t2 - -instance Hashable SomeTerm where - hashWithSalt s (SomeTerm t) = hashWithSalt s $ identityWithTypeRep t - -instance Show SomeTerm where - show (SomeTerm (t :: Term a)) = "<<" ++ show t ++ " :: " ++ show (typeRep (Proxy @a)) ++ ">>" diff --git a/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/Term.hs b/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/Term.hs deleted file mode 100644 --- a/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/Term.hs +++ /dev/null @@ -1,1194 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskellQuotes #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- Module : Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term - ( SupportedPrim (..), - SymRep (..), - ConRep (..), - LinkedRep (..), - UnaryOp (..), - BinaryOp (..), - TernaryOp (..), - TypedSymbol (..), - SomeTypedSymbol (..), - showUntyped, - withSymbolSupported, - someTypedSymbol, - Term (..), - UTerm (..), - type (-->) (..), - buildGeneralFun, - prettyPrintTerm, - ) -where - -import Control.DeepSeq (NFData (rnf)) -import Data.Bits (Bits, FiniteBits) -import Data.Function (on) -import Data.Hashable (Hashable (hashWithSalt)) -import Data.Interned - ( Cache, - Id, - Interned (Description, Uninterned, cache, describe, identify), - ) -import Data.Kind (Constraint) -import Data.String (IsString (fromString)) -import qualified Data.Text as T -import Data.Typeable (Proxy (Proxy), cast) -import GHC.Generics (Generic) -import GHC.TypeNats (KnownNat, Nat, type (+), type (<=)) -import Grisette.Core.Data.BV (IntN, WordN) -import Grisette.Core.Data.Class.BitVector - ( SizedBV, - ) -import Grisette.Core.Data.Class.Function (Function (Arg, Ret, (#))) -import Grisette.Core.Data.Class.SignConversion (SignConversion) -import Grisette.Core.Data.Class.SymRotate (SymRotate) -import Grisette.Core.Data.Class.SymShift (SymShift) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Caches - ( typeMemoizedCache, - ) -import {-# SOURCE #-} Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors - ( absNumTerm, - addNumTerm, - andBitsTerm, - andTerm, - bvconcatTerm, - bvextendTerm, - bvselectTerm, - complementBitsTerm, - conTerm, - constructBinary, - constructTernary, - constructUnary, - divBoundedIntegralTerm, - divIntegralTerm, - eqvTerm, - generalFunApplyTerm, - iteTerm, - leNumTerm, - ltNumTerm, - modBoundedIntegralTerm, - modIntegralTerm, - notTerm, - orBitsTerm, - orTerm, - quotBoundedIntegralTerm, - quotIntegralTerm, - remBoundedIntegralTerm, - remIntegralTerm, - rotateLeftTerm, - rotateRightTerm, - shiftLeftTerm, - shiftRightTerm, - signumNumTerm, - symTerm, - tabularFunApplyTerm, - timesNumTerm, - toSignedTerm, - toUnsignedTerm, - uminusNumTerm, - xorBitsTerm, - ) -import {-# SOURCE #-} Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermSubstitution - ( substTerm, - ) -import {-# SOURCE #-} Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermUtils - ( identity, - introSupportedPrimConstraint, - pformat, - ) -import Grisette.IR.SymPrim.Data.Prim.ModelValue - ( ModelValue, - toModelValue, - ) -import Grisette.IR.SymPrim.Data.Prim.Utils - ( eqHeteroRep, - eqTypeRepBool, - ) -import Grisette.IR.SymPrim.Data.TabularFun - ( type (=->) (TabularFun), - ) -import Language.Haskell.TH.Syntax (Lift (lift, liftTyped)) -import Language.Haskell.TH.Syntax.Compat (unTypeSplice) -import Type.Reflection - ( SomeTypeRep (SomeTypeRep), - TypeRep, - Typeable, - eqTypeRep, - typeRep, - type (:~~:) (HRefl), - ) - -#if MIN_VERSION_prettyprinter(1,7,0) -import Prettyprinter - ( column, - pageWidth, - Doc, - PageWidth(Unbounded, AvailablePerLine), - Pretty(pretty), - ) -#else -import Data.Text.Prettyprint.Doc - ( column, - pageWidth, - Doc, - PageWidth(Unbounded, AvailablePerLine), - Pretty(pretty), - ) -#endif - --- $setup --- >>> import Grisette.Core --- >>> import Grisette.IR.SymPrim - --- | Indicates that a type is supported and can be represented as a symbolic --- term. -class (Lift t, Typeable t, Hashable t, Eq t, Show t, NFData t) => SupportedPrim t where - type PrimConstraint t :: Constraint - type PrimConstraint _ = () - default withPrim :: (PrimConstraint t) => proxy t -> ((PrimConstraint t) => a) -> a - withPrim :: proxy t -> ((PrimConstraint t) => a) -> a - withPrim _ i = i - termCache :: Cache (Term t) - termCache = typeMemoizedCache - pformatCon :: t -> String - default pformatCon :: (Show t) => t -> String - pformatCon = show - pformatSym :: TypedSymbol t -> String - pformatSym = showUntyped - defaultValue :: t - defaultValueDynamic :: proxy t -> ModelValue - defaultValueDynamic _ = toModelValue (defaultValue @t) - --- | Type family to resolve the concrete type associated with a symbolic type. -class ConRep sym where - type ConType sym - --- | Type family to resolve the symbolic type associated with a concrete type. -class (SupportedPrim con) => SymRep con where - type SymType con - --- | One-to-one mapping between symbolic types and concrete types. -class - (ConRep sym, SymRep con, sym ~ SymType con, con ~ ConType sym) => - LinkedRep con sym - | con -> sym, - sym -> con - where - underlyingTerm :: sym -> Term con - wrapTerm :: Term con -> sym - -class - (SupportedPrim arg, SupportedPrim t, Lift tag, NFData tag, Show tag, Typeable tag, Eq tag, Hashable tag) => - UnaryOp tag arg t - | tag arg -> t - where - partialEvalUnary :: (Typeable tag, Typeable t) => tag -> Term arg -> Term t - pformatUnary :: tag -> Term arg -> String - -class - ( SupportedPrim arg1, - SupportedPrim arg2, - SupportedPrim t, - Lift tag, - NFData tag, - Show tag, - Typeable tag, - Eq tag, - Hashable tag - ) => - BinaryOp tag arg1 arg2 t - | tag arg1 arg2 -> t - where - partialEvalBinary :: (Typeable tag, Typeable t) => tag -> Term arg1 -> Term arg2 -> Term t - pformatBinary :: tag -> Term arg1 -> Term arg2 -> String - -class - ( SupportedPrim arg1, - SupportedPrim arg2, - SupportedPrim arg3, - SupportedPrim t, - Lift tag, - NFData tag, - Show tag, - Typeable tag, - Eq tag, - Hashable tag - ) => - TernaryOp tag arg1 arg2 arg3 t - | tag arg1 arg2 arg3 -> t - where - partialEvalTernary :: (Typeable tag, Typeable t) => tag -> Term arg1 -> Term arg2 -> Term arg3 -> Term t - pformatTernary :: tag -> Term arg1 -> Term arg2 -> Term arg3 -> String - --- | A typed symbol is a symbol that is associated with a type. Note that the --- same symbol bodies with different types are considered different symbols --- and can coexist in a term. --- --- Simple symbols can be created with the 'OverloadedStrings' extension: --- --- >>> :set -XOverloadedStrings --- >>> "a" :: TypedSymbol Bool --- a :: Bool -data TypedSymbol t where - SimpleSymbol :: (SupportedPrim t) => T.Text -> TypedSymbol t - IndexedSymbol :: (SupportedPrim t) => T.Text -> Int -> TypedSymbol t - WithInfo :: - forall t a. - ( SupportedPrim t, - Typeable a, - Ord a, - Lift a, - NFData a, - Show a, - Hashable a - ) => - TypedSymbol t -> - a -> - TypedSymbol t - --- deriving (Eq, Ord, Generic, Lift, NFData) - -instance Eq (TypedSymbol t) where - SimpleSymbol x == SimpleSymbol y = x == y - IndexedSymbol x i == IndexedSymbol y j = i == j && x == y - WithInfo s1 (i1 :: a) == WithInfo s2 (i2 :: b) = case eqTypeRep (typeRep @a) (typeRep @b) of - Just HRefl -> i1 == i2 && s1 == s2 - _ -> False - _ == _ = False - -instance Ord (TypedSymbol t) where - SimpleSymbol x <= SimpleSymbol y = x <= y - IndexedSymbol x i <= IndexedSymbol y j = i < j || (i == j && x <= y) - WithInfo s1 (i1 :: a) <= WithInfo s2 (i2 :: b) = case eqTypeRep (typeRep @a) (typeRep @b) of - Just HRefl -> s1 < s2 || (s1 == s2 && i1 <= i2) - _ -> False - _ <= _ = False - -instance Lift (TypedSymbol t) where - liftTyped (SimpleSymbol x) = [||SimpleSymbol x||] - liftTyped (IndexedSymbol x i) = [||IndexedSymbol x i||] - liftTyped (WithInfo s1 i1) = [||WithInfo s1 i1||] - -instance Show (TypedSymbol t) where - show (SimpleSymbol str) = T.unpack str ++ " :: " ++ show (typeRep @t) - show (IndexedSymbol str i) = T.unpack str ++ "@" ++ show i ++ " :: " ++ show (typeRep @t) - show (WithInfo s info) = showUntyped s ++ ":" ++ show info ++ " :: " ++ show (typeRep @t) - -showUntyped :: TypedSymbol t -> String -showUntyped (SimpleSymbol str) = T.unpack str -showUntyped (IndexedSymbol str i) = T.unpack str ++ "@" ++ show i -showUntyped (WithInfo s info) = showUntyped s ++ ":" ++ show info - -instance Hashable (TypedSymbol t) where - s `hashWithSalt` SimpleSymbol x = s `hashWithSalt` x - s `hashWithSalt` IndexedSymbol x i = s `hashWithSalt` x `hashWithSalt` i - s `hashWithSalt` WithInfo sym info = s `hashWithSalt` sym `hashWithSalt` info - -instance NFData (TypedSymbol t) where - rnf (SimpleSymbol str) = rnf str - rnf (IndexedSymbol str i) = rnf str `seq` rnf i - rnf (WithInfo s info) = rnf s `seq` rnf info - -instance (SupportedPrim t) => IsString (TypedSymbol t) where - fromString = SimpleSymbol . T.pack - -withSymbolSupported :: TypedSymbol t -> ((SupportedPrim t) => a) -> a -withSymbolSupported (SimpleSymbol _) a = a -withSymbolSupported (IndexedSymbol _ _) a = a -withSymbolSupported (WithInfo _ _) a = a - -{- -data TypedSymbol t where - TypedSymbol :: (SupportedPrim t) => Symbol -> TypedSymbol t - -typedSymbol :: forall proxy t. (SupportedPrim t) => proxy t -> Symbol -> TypedSymbol t -typedSymbol _ = TypedSymbol - -instance NFData (TypedSymbol t) where - rnf (TypedSymbol s) = rnf s - -instance Eq (TypedSymbol t) where - (TypedSymbol s1) == (TypedSymbol s2) = s1 == s2 - -instance Ord (TypedSymbol t) where - (TypedSymbol s1) <= (TypedSymbol s2) = s1 <= s2 - -instance Hashable (TypedSymbol t) where - hashWithSalt s (TypedSymbol s1) = s `hashWithSalt` s1 - -instance Show (TypedSymbol t) where - show (TypedSymbol s) = show s ++ " :: " ++ show (typeRep @t) - -instance Lift (TypedSymbol t) where - liftTyped (TypedSymbol s) = [||TypedSymbol s||] - -} - -data SomeTypedSymbol where - SomeTypedSymbol :: forall t. TypeRep t -> TypedSymbol t -> SomeTypedSymbol - -instance NFData SomeTypedSymbol where - rnf (SomeTypedSymbol p s) = rnf (SomeTypeRep p) `seq` rnf s - -instance Eq SomeTypedSymbol where - (SomeTypedSymbol t1 s1) == (SomeTypedSymbol t2 s2) = case eqTypeRep t1 t2 of - Just HRefl -> s1 == s2 - _ -> False - -instance Ord SomeTypedSymbol where - (SomeTypedSymbol t1 s1) <= (SomeTypedSymbol t2 s2) = - SomeTypeRep t1 < SomeTypeRep t2 - || ( case eqTypeRep t1 t2 of - Just HRefl -> s1 <= s2 - _ -> False - ) - -instance Hashable SomeTypedSymbol where - hashWithSalt s (SomeTypedSymbol t1 s1) = s `hashWithSalt` s1 `hashWithSalt` t1 - -instance Show SomeTypedSymbol where - show (SomeTypedSymbol _ s) = show s - -someTypedSymbol :: forall t. TypedSymbol t -> SomeTypedSymbol -someTypedSymbol s@(SimpleSymbol _) = SomeTypedSymbol (typeRep @t) s -someTypedSymbol s@(IndexedSymbol _ _) = SomeTypedSymbol (typeRep @t) s -someTypedSymbol s@(WithInfo _ _) = SomeTypedSymbol (typeRep @t) s - -data Term t where - ConTerm :: (SupportedPrim t) => {-# UNPACK #-} !Id -> !t -> Term t - SymTerm :: (SupportedPrim t) => {-# UNPACK #-} !Id -> !(TypedSymbol t) -> Term t - UnaryTerm :: - (UnaryOp tag arg t) => - {-# UNPACK #-} !Id -> - !tag -> - !(Term arg) -> - Term t - BinaryTerm :: - (BinaryOp tag arg1 arg2 t) => - {-# UNPACK #-} !Id -> - !tag -> - !(Term arg1) -> - !(Term arg2) -> - Term t - TernaryTerm :: - (TernaryOp tag arg1 arg2 arg3 t) => - {-# UNPACK #-} !Id -> - !tag -> - !(Term arg1) -> - !(Term arg2) -> - !(Term arg3) -> - Term t - NotTerm :: {-# UNPACK #-} !Id -> !(Term Bool) -> Term Bool - OrTerm :: {-# UNPACK #-} !Id -> !(Term Bool) -> !(Term Bool) -> Term Bool - AndTerm :: {-# UNPACK #-} !Id -> !(Term Bool) -> !(Term Bool) -> Term Bool - EqvTerm :: (SupportedPrim t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term Bool - ITETerm :: (SupportedPrim t) => {-# UNPACK #-} !Id -> !(Term Bool) -> !(Term t) -> !(Term t) -> Term t - AddNumTerm :: (SupportedPrim t, Num t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t - UMinusNumTerm :: (SupportedPrim t, Num t) => {-# UNPACK #-} !Id -> !(Term t) -> Term t - TimesNumTerm :: (SupportedPrim t, Num t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t - AbsNumTerm :: (SupportedPrim t, Num t) => {-# UNPACK #-} !Id -> !(Term t) -> Term t - SignumNumTerm :: (SupportedPrim t, Num t) => {-# UNPACK #-} !Id -> !(Term t) -> Term t - LTNumTerm :: (SupportedPrim t, Num t, Ord t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term Bool - LENumTerm :: (SupportedPrim t, Num t, Ord t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term Bool - AndBitsTerm :: (SupportedPrim t, Bits t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t - OrBitsTerm :: (SupportedPrim t, Bits t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t - XorBitsTerm :: (SupportedPrim t, Bits t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t - ComplementBitsTerm :: (SupportedPrim t, Bits t) => {-# UNPACK #-} !Id -> !(Term t) -> Term t - ShiftLeftTerm :: (SupportedPrim t, Integral t, FiniteBits t, SymShift t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t - ShiftRightTerm :: (SupportedPrim t, Integral t, FiniteBits t, SymShift t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t - RotateLeftTerm :: (SupportedPrim t, Integral t, FiniteBits t, SymRotate t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t - RotateRightTerm :: (SupportedPrim t, Integral t, FiniteBits t, SymRotate t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t - ToSignedTerm :: - ( SupportedPrim u, - SupportedPrim s, - SignConversion u s - ) => - {-# UNPACK #-} !Id -> - !(Term u) -> - Term s - ToUnsignedTerm :: - ( SupportedPrim u, - SupportedPrim s, - SignConversion u s - ) => - {-# UNPACK #-} !Id -> - !(Term s) -> - Term u - BVConcatTerm :: - ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n), - Typeable bv, - KnownNat a, - KnownNat b, - KnownNat (a + b), - 1 <= a, - 1 <= b, - 1 <= a + b, - SizedBV bv - ) => - {-# UNPACK #-} !Id -> - !(Term (bv a)) -> - !(Term (bv b)) -> - Term (bv (a + b)) - BVSelectTerm :: - ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n), - Typeable bv, - KnownNat n, - KnownNat ix, - KnownNat w, - 1 <= n, - 1 <= w, - ix + w <= n, - SizedBV bv - ) => - {-# UNPACK #-} !Id -> - !(TypeRep ix) -> - !(TypeRep w) -> - !(Term (bv n)) -> - Term (bv w) - BVExtendTerm :: - ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n), - Typeable bv, - KnownNat l, - KnownNat r, - 1 <= l, - 1 <= r, - l <= r, - SizedBV bv - ) => - {-# UNPACK #-} !Id -> - !Bool -> - !(TypeRep r) -> - !(Term (bv l)) -> - Term (bv r) - TabularFunApplyTerm :: - ( SupportedPrim a, - SupportedPrim b - ) => - {-# UNPACK #-} !Id -> - Term (a =-> b) -> - Term a -> - Term b - GeneralFunApplyTerm :: - ( SupportedPrim a, - SupportedPrim b - ) => - {-# UNPACK #-} !Id -> - Term (a --> b) -> - Term a -> - Term b - DivIntegralTerm :: (SupportedPrim t, Integral t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t - ModIntegralTerm :: (SupportedPrim t, Integral t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t - QuotIntegralTerm :: (SupportedPrim t, Integral t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t - RemIntegralTerm :: (SupportedPrim t, Integral t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t - DivBoundedIntegralTerm :: (SupportedPrim t, Bounded t, Integral t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t - ModBoundedIntegralTerm :: (SupportedPrim t, Bounded t, Integral t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t - QuotBoundedIntegralTerm :: (SupportedPrim t, Bounded t, Integral t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t - RemBoundedIntegralTerm :: (SupportedPrim t, Bounded t, Integral t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t - -instance NFData (Term a) where - rnf i = identity i `seq` () - -instance Lift (Term t) where - lift = unTypeSplice . liftTyped - liftTyped (ConTerm _ i) = [||conTerm i||] - liftTyped (SymTerm _ sym) = [||symTerm sym||] - liftTyped (UnaryTerm _ tag arg) = [||constructUnary tag arg||] - liftTyped (BinaryTerm _ tag arg1 arg2) = [||constructBinary tag arg1 arg2||] - liftTyped (TernaryTerm _ tag arg1 arg2 arg3) = [||constructTernary tag arg1 arg2 arg3||] - liftTyped (NotTerm _ arg) = [||notTerm arg||] - liftTyped (OrTerm _ arg1 arg2) = [||orTerm arg1 arg2||] - liftTyped (AndTerm _ arg1 arg2) = [||andTerm arg1 arg2||] - liftTyped (EqvTerm _ arg1 arg2) = [||eqvTerm arg1 arg2||] - liftTyped (ITETerm _ cond arg1 arg2) = [||iteTerm cond arg1 arg2||] - liftTyped (AddNumTerm _ arg1 arg2) = [||addNumTerm arg1 arg2||] - liftTyped (UMinusNumTerm _ arg) = [||uminusNumTerm arg||] - liftTyped (TimesNumTerm _ arg1 arg2) = [||timesNumTerm arg1 arg2||] - liftTyped (AbsNumTerm _ arg) = [||absNumTerm arg||] - liftTyped (SignumNumTerm _ arg) = [||signumNumTerm arg||] - liftTyped (LTNumTerm _ arg1 arg2) = [||ltNumTerm arg1 arg2||] - liftTyped (LENumTerm _ arg1 arg2) = [||leNumTerm arg1 arg2||] - liftTyped (AndBitsTerm _ arg1 arg2) = [||andBitsTerm arg1 arg2||] - liftTyped (OrBitsTerm _ arg1 arg2) = [||orBitsTerm arg1 arg2||] - liftTyped (XorBitsTerm _ arg1 arg2) = [||xorBitsTerm arg1 arg2||] - liftTyped (ComplementBitsTerm _ arg) = [||complementBitsTerm arg||] - liftTyped (ShiftLeftTerm _ arg n) = [||shiftLeftTerm arg n||] - liftTyped (ShiftRightTerm _ arg n) = [||shiftRightTerm arg n||] - liftTyped (RotateLeftTerm _ arg n) = [||rotateLeftTerm arg n||] - liftTyped (RotateRightTerm _ arg n) = [||rotateRightTerm arg n||] - liftTyped (ToSignedTerm _ v) = [||toSignedTerm v||] - liftTyped (ToUnsignedTerm _ v) = [||toUnsignedTerm v||] - liftTyped (BVConcatTerm _ arg1 arg2) = [||bvconcatTerm arg1 arg2||] - liftTyped (BVSelectTerm _ (_ :: TypeRep ix) (_ :: TypeRep w) arg) = [||bvselectTerm (Proxy @ix) (Proxy @w) arg||] - liftTyped (BVExtendTerm _ signed (_ :: TypeRep n) arg) = [||bvextendTerm signed (Proxy @n) arg||] - liftTyped (TabularFunApplyTerm _ func arg) = [||tabularFunApplyTerm func arg||] - liftTyped (GeneralFunApplyTerm _ func arg) = [||generalFunApplyTerm func arg||] - liftTyped (DivIntegralTerm _ arg1 arg2) = [||divIntegralTerm arg1 arg2||] - liftTyped (ModIntegralTerm _ arg1 arg2) = [||modIntegralTerm arg1 arg2||] - liftTyped (QuotIntegralTerm _ arg1 arg2) = [||quotIntegralTerm arg1 arg2||] - liftTyped (RemIntegralTerm _ arg1 arg2) = [||remIntegralTerm arg1 arg2||] - liftTyped (DivBoundedIntegralTerm _ arg1 arg2) = [||divBoundedIntegralTerm arg1 arg2||] - liftTyped (ModBoundedIntegralTerm _ arg1 arg2) = [||modBoundedIntegralTerm arg1 arg2||] - liftTyped (QuotBoundedIntegralTerm _ arg1 arg2) = [||quotBoundedIntegralTerm arg1 arg2||] - liftTyped (RemBoundedIntegralTerm _ arg1 arg2) = [||remBoundedIntegralTerm arg1 arg2||] - -instance Show (Term ty) where - show (ConTerm i v) = "ConTerm{id=" ++ show i ++ ", v=" ++ show v ++ "}" - show (SymTerm i name) = - "SymTerm{id=" - ++ show i - ++ ", name=" - ++ show name - ++ ", type=" - ++ show (typeRep @ty) - ++ "}" - show (UnaryTerm i tag arg) = "Unary{id=" ++ show i ++ ", tag=" ++ show tag ++ ", arg=" ++ show arg ++ "}" - show (BinaryTerm i tag arg1 arg2) = - "Binary{id=" - ++ show i - ++ ", tag=" - ++ show tag - ++ ", arg1=" - ++ show arg1 - ++ ", arg2=" - ++ show arg2 - ++ "}" - show (TernaryTerm i tag arg1 arg2 arg3) = - "Ternary{id=" - ++ show i - ++ ", tag=" - ++ show tag - ++ ", arg1=" - ++ show arg1 - ++ ", arg2=" - ++ show arg2 - ++ ", arg3=" - ++ show arg3 - ++ "}" - show (NotTerm i arg) = "Not{id=" ++ show i ++ ", arg=" ++ show arg ++ "}" - show (OrTerm i arg1 arg2) = "Or{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" - show (AndTerm i arg1 arg2) = "And{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" - show (EqvTerm i arg1 arg2) = "Eqv{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" - show (ITETerm i cond l r) = - "ITE{id=" - ++ show i - ++ ", cond=" - ++ show cond - ++ ", then=" - ++ show l - ++ ", else=" - ++ show r - ++ "}" - show (AddNumTerm i arg1 arg2) = "AddNum{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" - show (UMinusNumTerm i arg) = "UMinusNum{id=" ++ show i ++ ", arg=" ++ show arg ++ "}" - show (TimesNumTerm i arg1 arg2) = "TimesNum{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" - show (AbsNumTerm i arg) = "AbsNum{id=" ++ show i ++ ", arg=" ++ show arg ++ "}" - show (SignumNumTerm i arg) = "SignumNum{id=" ++ show i ++ ", arg=" ++ show arg ++ "}" - show (LTNumTerm i arg1 arg2) = "LTNum{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" - show (LENumTerm i arg1 arg2) = "LENum{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" - show (AndBitsTerm i arg1 arg2) = "AndBits{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" - show (OrBitsTerm i arg1 arg2) = "OrBits{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" - show (XorBitsTerm i arg1 arg2) = "XorBits{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" - show (ComplementBitsTerm i arg) = "ComplementBits{id=" ++ show i ++ ", arg=" ++ show arg ++ "}" - show (ShiftLeftTerm i arg n) = "ShiftLeft{id=" ++ show i ++ ", arg=" ++ show arg ++ ", n=" ++ show n ++ "}" - show (ShiftRightTerm i arg n) = "ShiftRight{id=" ++ show i ++ ", arg=" ++ show arg ++ ", n=" ++ show n ++ "}" - show (RotateLeftTerm i arg n) = "RotateLeft{id=" ++ show i ++ ", arg=" ++ show arg ++ ", n=" ++ show n ++ "}" - show (RotateRightTerm i arg n) = "RotateRight{id=" ++ show i ++ ", arg=" ++ show arg ++ ", n=" ++ show n ++ "}" - show (ToSignedTerm i arg) = "ToSigned{id=" ++ show i ++ ", arg=" ++ show arg ++ "}" - show (ToUnsignedTerm i arg) = "ToUnsigned{id=" ++ show i ++ ", arg=" ++ show arg ++ "}" - show (BVConcatTerm i arg1 arg2) = "BVConcat{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" - show (BVSelectTerm i ix w arg) = - "BVSelect{id=" ++ show i ++ ", ix=" ++ show ix ++ ", w=" ++ show w ++ ", arg=" ++ show arg ++ "}" - show (BVExtendTerm i signed n arg) = - "BVExtend{id=" ++ show i ++ ", signed=" ++ show signed ++ ", n=" ++ show n ++ ", arg=" ++ show arg ++ "}" - show (TabularFunApplyTerm i func arg) = - "TabularFunApply{id=" ++ show i ++ ", func=" ++ show func ++ ", arg=" ++ show arg ++ "}" - show (GeneralFunApplyTerm i func arg) = - "GeneralFunApply{id=" ++ show i ++ ", func=" ++ show func ++ ", arg=" ++ show arg ++ "}" - show (DivIntegralTerm i arg1 arg2) = - "DivIntegral{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" - show (ModIntegralTerm i arg1 arg2) = - "ModIntegral{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" - show (QuotIntegralTerm i arg1 arg2) = - "QuotIntegral{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" - show (RemIntegralTerm i arg1 arg2) = - "RemIntegral{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" - show (DivBoundedIntegralTerm i arg1 arg2) = - "DivBoundedIntegral{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" - show (ModBoundedIntegralTerm i arg1 arg2) = - "ModBoundedIntegral{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" - show (QuotBoundedIntegralTerm i arg1 arg2) = - "QuotBoundedIntegral{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" - show (RemBoundedIntegralTerm i arg1 arg2) = - "RemBoundedIntegral{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" - -prettyPrintTerm :: Term t -> Doc ann -prettyPrintTerm v = - column - ( \c -> - pageWidth $ \case - AvailablePerLine i r -> - if fromIntegral (c + len) > fromIntegral i * r - then "..." - else pretty formatted - Unbounded -> pretty formatted - ) - where - formatted = introSupportedPrimConstraint v $ pformat v - len = length formatted - -instance (SupportedPrim t) => Eq (Term t) where - (==) = (==) `on` identity - -instance (SupportedPrim t) => Hashable (Term t) where - hashWithSalt s t = hashWithSalt s $ identity t - -data UTerm t where - UConTerm :: (SupportedPrim t) => !t -> UTerm t - USymTerm :: (SupportedPrim t) => !(TypedSymbol t) -> UTerm t - UUnaryTerm :: (UnaryOp tag arg t) => !tag -> !(Term arg) -> UTerm t - UBinaryTerm :: - (BinaryOp tag arg1 arg2 t) => - !tag -> - !(Term arg1) -> - !(Term arg2) -> - UTerm t - UTernaryTerm :: - (TernaryOp tag arg1 arg2 arg3 t) => - !tag -> - !(Term arg1) -> - !(Term arg2) -> - !(Term arg3) -> - UTerm t - UNotTerm :: !(Term Bool) -> UTerm Bool - UOrTerm :: !(Term Bool) -> !(Term Bool) -> UTerm Bool - UAndTerm :: !(Term Bool) -> !(Term Bool) -> UTerm Bool - UEqvTerm :: (SupportedPrim t) => !(Term t) -> !(Term t) -> UTerm Bool - UITETerm :: (SupportedPrim t) => !(Term Bool) -> !(Term t) -> !(Term t) -> UTerm t - UAddNumTerm :: (SupportedPrim t, Num t) => !(Term t) -> !(Term t) -> UTerm t - UUMinusNumTerm :: (SupportedPrim t, Num t) => !(Term t) -> UTerm t - UTimesNumTerm :: (SupportedPrim t, Num t) => !(Term t) -> !(Term t) -> UTerm t - UAbsNumTerm :: (SupportedPrim t, Num t) => !(Term t) -> UTerm t - USignumNumTerm :: (SupportedPrim t, Num t) => !(Term t) -> UTerm t - ULTNumTerm :: (SupportedPrim t, Num t, Ord t) => !(Term t) -> !(Term t) -> UTerm Bool - ULENumTerm :: (SupportedPrim t, Num t, Ord t) => !(Term t) -> !(Term t) -> UTerm Bool - UAndBitsTerm :: (SupportedPrim t, Bits t) => !(Term t) -> !(Term t) -> UTerm t - UOrBitsTerm :: (SupportedPrim t, Bits t) => !(Term t) -> !(Term t) -> UTerm t - UXorBitsTerm :: (SupportedPrim t, Bits t) => !(Term t) -> !(Term t) -> UTerm t - UComplementBitsTerm :: (SupportedPrim t, Bits t) => !(Term t) -> UTerm t - UShiftLeftTerm :: (SupportedPrim t, Integral t, FiniteBits t, SymShift t) => !(Term t) -> !(Term t) -> UTerm t - UShiftRightTerm :: (SupportedPrim t, Integral t, FiniteBits t, SymShift t) => !(Term t) -> !(Term t) -> UTerm t - URotateLeftTerm :: (SupportedPrim t, Integral t, FiniteBits t, SymRotate t) => !(Term t) -> !(Term t) -> UTerm t - URotateRightTerm :: (SupportedPrim t, Integral t, FiniteBits t, SymRotate t) => !(Term t) -> !(Term t) -> UTerm t - UToSignedTerm :: - ( SupportedPrim u, - SupportedPrim s, - SignConversion u s - ) => - !(Term u) -> - UTerm s - UToUnsignedTerm :: - ( SupportedPrim u, - SupportedPrim s, - SignConversion u s - ) => - !(Term s) -> - UTerm u - UBVConcatTerm :: - ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n), - Typeable bv, - KnownNat a, - KnownNat b, - KnownNat (a + b), - 1 <= a, - 1 <= b, - 1 <= a + b, - SizedBV bv - ) => - !(Term (bv a)) -> - !(Term (bv b)) -> - UTerm (bv (a + b)) - UBVSelectTerm :: - ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n), - Typeable bv, - KnownNat n, - KnownNat ix, - KnownNat w, - 1 <= n, - 1 <= w, - ix + w <= n, - SizedBV bv - ) => - !(TypeRep ix) -> - !(TypeRep w) -> - !(Term (bv n)) -> - UTerm (bv w) - UBVExtendTerm :: - ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n), - Typeable bv, - KnownNat l, - KnownNat r, - 1 <= l, - 1 <= r, - l <= r, - SizedBV bv - ) => - !Bool -> - !(TypeRep r) -> - !(Term (bv l)) -> - UTerm (bv r) - UTabularFunApplyTerm :: - ( SupportedPrim a, - SupportedPrim b - ) => - Term (a =-> b) -> - Term a -> - UTerm b - UGeneralFunApplyTerm :: - ( SupportedPrim a, - SupportedPrim b - ) => - Term (a --> b) -> - Term a -> - UTerm b - UDivIntegralTerm :: (SupportedPrim t, Integral t) => !(Term t) -> !(Term t) -> UTerm t - UModIntegralTerm :: (SupportedPrim t, Integral t) => !(Term t) -> !(Term t) -> UTerm t - UQuotIntegralTerm :: (SupportedPrim t, Integral t) => !(Term t) -> !(Term t) -> UTerm t - URemIntegralTerm :: (SupportedPrim t, Integral t) => !(Term t) -> !(Term t) -> UTerm t - UDivBoundedIntegralTerm :: (SupportedPrim t, Bounded t, Integral t) => !(Term t) -> !(Term t) -> UTerm t - UModBoundedIntegralTerm :: (SupportedPrim t, Bounded t, Integral t) => !(Term t) -> !(Term t) -> UTerm t - UQuotBoundedIntegralTerm :: (SupportedPrim t, Bounded t, Integral t) => !(Term t) -> !(Term t) -> UTerm t - URemBoundedIntegralTerm :: (SupportedPrim t, Bounded t, Integral t) => !(Term t) -> !(Term t) -> UTerm t - -eqTypedId :: (TypeRep a, Id) -> (TypeRep b, Id) -> Bool -eqTypedId (a, i1) (b, i2) = i1 == i2 && eqTypeRepBool a b -{-# INLINE eqTypedId #-} - -eqHeteroTag :: (Eq a) => (TypeRep a, a) -> (TypeRep b, b) -> Bool -eqHeteroTag (tpa, taga) (tpb, tagb) = eqHeteroRep tpa tpb taga tagb -{-# INLINE eqHeteroTag #-} - -instance (SupportedPrim t) => Interned (Term t) where - type Uninterned (Term t) = UTerm t - data Description (Term t) where - DConTerm :: t -> Description (Term t) - DSymTerm :: TypedSymbol t -> Description (Term t) - DUnaryTerm :: - (Eq tag, Hashable tag) => - {-# UNPACK #-} !(TypeRep tag, tag) -> - {-# UNPACK #-} !(TypeRep arg, Id) -> - Description (Term t) - DBinaryTerm :: - (Eq tag, Hashable tag) => - {-# UNPACK #-} !(TypeRep tag, tag) -> - {-# UNPACK #-} !(TypeRep arg1, Id) -> - {-# UNPACK #-} !(TypeRep arg2, Id) -> - Description (Term t) - DTernaryTerm :: - (Eq tag, Hashable tag) => - {-# UNPACK #-} !(TypeRep tag, tag) -> - {-# UNPACK #-} !(TypeRep arg1, Id) -> - {-# UNPACK #-} !(TypeRep arg2, Id) -> - {-# UNPACK #-} !(TypeRep arg3, Id) -> - Description (Term t) - DNotTerm :: {-# UNPACK #-} !Id -> Description (Term Bool) - DOrTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term Bool) - DAndTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term Bool) - DEqvTerm :: TypeRep args -> {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term Bool) - DITETerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term t) - DAddNumTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term t) - DUMinusNumTerm :: {-# UNPACK #-} !Id -> Description (Term t) - DTimesNumTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term t) - DAbsNumTerm :: {-# UNPACK #-} !Id -> Description (Term t) - DSignumNumTerm :: {-# UNPACK #-} !Id -> Description (Term t) - DLTNumTerm :: TypeRep args -> {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term Bool) - DLENumTerm :: TypeRep args -> {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term Bool) - DAndBitsTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term t) - DOrBitsTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term t) - DXorBitsTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term t) - DComplementBitsTerm :: {-# UNPACK #-} !Id -> Description (Term t) - DShiftLeftTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term t) - DShiftRightTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term t) - DRotateLeftTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term t) - DRotateRightTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term t) - DBVConcatTerm :: TypeRep bv1 -> TypeRep bv2 -> {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term t) - DToSignedTerm :: - !(TypeRep u, Id) -> - Description (Term s) - DToUnsignedTerm :: - !(TypeRep s, Id) -> - Description (Term u) - DBVSelectTerm :: - forall bv (n :: Nat) (w :: Nat) (ix :: Nat). - !(TypeRep ix) -> - !(TypeRep (bv n), Id) -> - Description (Term (bv w)) - DBVExtendTerm :: - forall bv (l :: Nat) (r :: Nat). - !Bool -> - !(TypeRep r) -> - {-# UNPACK #-} !(TypeRep (bv l), Id) -> - Description (Term (bv r)) - DTabularFunApplyTerm :: - {-# UNPACK #-} !(TypeRep (a =-> b), Id) -> - {-# UNPACK #-} !(TypeRep a, Id) -> - Description (Term b) - DGeneralFunApplyTerm :: - {-# UNPACK #-} !(TypeRep (a --> b), Id) -> - {-# UNPACK #-} !(TypeRep a, Id) -> - Description (Term b) - DDivIntegralTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term a) - DModIntegralTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term a) - DQuotIntegralTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term a) - DRemIntegralTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term a) - DDivBoundedIntegralTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term a) - DModBoundedIntegralTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term a) - DQuotBoundedIntegralTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term a) - DRemBoundedIntegralTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term a) - - describe (UConTerm v) = DConTerm v - describe ((USymTerm name) :: UTerm t) = DSymTerm @t name - describe ((UUnaryTerm (tag :: tagt) (tm :: Term arg)) :: UTerm t) = - DUnaryTerm (typeRep, tag) (typeRep :: TypeRep arg, identity tm) - describe ((UBinaryTerm (tag :: tagt) (tm1 :: Term arg1) (tm2 :: Term arg2)) :: UTerm t) = - DBinaryTerm @tagt @arg1 @arg2 @t (typeRep, tag) (typeRep, identity tm1) (typeRep, identity tm2) - describe ((UTernaryTerm (tag :: tagt) (tm1 :: Term arg1) (tm2 :: Term arg2) (tm3 :: Term arg3)) :: UTerm t) = - DTernaryTerm @tagt @arg1 @arg2 @arg3 @t - (typeRep, tag) - (typeRep, identity tm1) - (typeRep, identity tm2) - (typeRep, identity tm3) - describe (UNotTerm arg) = DNotTerm (identity arg) - describe (UOrTerm arg1 arg2) = DOrTerm (identity arg1) (identity arg2) - describe (UAndTerm arg1 arg2) = DAndTerm (identity arg1) (identity arg2) - describe (UEqvTerm (arg1 :: Term arg) arg2) = DEqvTerm (typeRep :: TypeRep arg) (identity arg1) (identity arg2) - describe (UITETerm cond (l :: Term arg) r) = DITETerm (identity cond) (identity l) (identity r) - describe (UAddNumTerm arg1 arg2) = DAddNumTerm (identity arg1) (identity arg2) - describe (UUMinusNumTerm arg) = DUMinusNumTerm (identity arg) - describe (UTimesNumTerm arg1 arg2) = DTimesNumTerm (identity arg1) (identity arg2) - describe (UAbsNumTerm arg) = DAbsNumTerm (identity arg) - describe (USignumNumTerm arg) = DSignumNumTerm (identity arg) - describe (ULTNumTerm (arg1 :: arg) arg2) = DLTNumTerm (typeRep :: TypeRep arg) (identity arg1) (identity arg2) - describe (ULENumTerm (arg1 :: arg) arg2) = DLENumTerm (typeRep :: TypeRep arg) (identity arg1) (identity arg2) - describe (UAndBitsTerm arg1 arg2) = DAndBitsTerm (identity arg1) (identity arg2) - describe (UOrBitsTerm arg1 arg2) = DOrBitsTerm (identity arg1) (identity arg2) - describe (UXorBitsTerm arg1 arg2) = DXorBitsTerm (identity arg1) (identity arg2) - describe (UComplementBitsTerm arg) = DComplementBitsTerm (identity arg) - describe (UShiftLeftTerm arg n) = DShiftLeftTerm (identity arg) (identity n) - describe (UShiftRightTerm arg n) = DShiftRightTerm (identity arg) (identity n) - describe (URotateLeftTerm arg n) = DRotateLeftTerm (identity arg) (identity n) - describe (URotateRightTerm arg n) = DRotateRightTerm (identity arg) (identity n) - describe (UToSignedTerm (arg :: Term bv)) = DToSignedTerm (typeRep :: TypeRep bv, identity arg) - describe (UToUnsignedTerm (arg :: Term bv)) = DToSignedTerm (typeRep :: TypeRep bv, identity arg) - describe (UBVConcatTerm (arg1 :: bv1) (arg2 :: bv2)) = - DBVConcatTerm (typeRep :: TypeRep bv1) (typeRep :: TypeRep bv2) (identity arg1) (identity arg2) - describe (UBVSelectTerm (ix :: TypeRep ix) _ (arg :: Term arg)) = - DBVSelectTerm ix (typeRep :: TypeRep arg, identity arg) - describe (UBVExtendTerm signed (n :: TypeRep n) (arg :: Term arg)) = - DBVExtendTerm signed n (typeRep :: TypeRep arg, identity arg) - describe (UTabularFunApplyTerm (func :: Term f) (arg :: Term a)) = - DTabularFunApplyTerm (typeRep :: TypeRep f, identity func) (typeRep :: TypeRep a, identity arg) - describe (UGeneralFunApplyTerm (func :: Term f) (arg :: Term a)) = - DGeneralFunApplyTerm (typeRep :: TypeRep f, identity func) (typeRep :: TypeRep a, identity arg) - describe (UDivIntegralTerm arg1 arg2) = DDivIntegralTerm (identity arg1) (identity arg2) - describe (UModIntegralTerm arg1 arg2) = DModIntegralTerm (identity arg1) (identity arg2) - describe (UQuotIntegralTerm arg1 arg2) = DRemIntegralTerm (identity arg1) (identity arg2) - describe (URemIntegralTerm arg1 arg2) = DQuotIntegralTerm (identity arg1) (identity arg2) - describe (UDivBoundedIntegralTerm arg1 arg2) = DDivBoundedIntegralTerm (identity arg1) (identity arg2) - describe (UModBoundedIntegralTerm arg1 arg2) = DModBoundedIntegralTerm (identity arg1) (identity arg2) - describe (UQuotBoundedIntegralTerm arg1 arg2) = DRemBoundedIntegralTerm (identity arg1) (identity arg2) - describe (URemBoundedIntegralTerm arg1 arg2) = DQuotBoundedIntegralTerm (identity arg1) (identity arg2) - - identify i = go - where - go (UConTerm v) = ConTerm i v - go (USymTerm v) = SymTerm i v - go (UUnaryTerm tag tm) = UnaryTerm i tag tm - go (UBinaryTerm tag tm1 tm2) = BinaryTerm i tag tm1 tm2 - go (UTernaryTerm tag tm1 tm2 tm3) = TernaryTerm i tag tm1 tm2 tm3 - go (UNotTerm arg) = NotTerm i arg - go (UOrTerm arg1 arg2) = OrTerm i arg1 arg2 - go (UAndTerm arg1 arg2) = AndTerm i arg1 arg2 - go (UEqvTerm arg1 arg2) = EqvTerm i arg1 arg2 - go (UITETerm cond l r) = ITETerm i cond l r - go (UAddNumTerm arg1 arg2) = AddNumTerm i arg1 arg2 - go (UUMinusNumTerm arg) = UMinusNumTerm i arg - go (UTimesNumTerm arg1 arg2) = TimesNumTerm i arg1 arg2 - go (UAbsNumTerm arg) = AbsNumTerm i arg - go (USignumNumTerm arg) = SignumNumTerm i arg - go (ULTNumTerm arg1 arg2) = LTNumTerm i arg1 arg2 - go (ULENumTerm arg1 arg2) = LENumTerm i arg1 arg2 - go (UAndBitsTerm arg1 arg2) = AndBitsTerm i arg1 arg2 - go (UOrBitsTerm arg1 arg2) = OrBitsTerm i arg1 arg2 - go (UXorBitsTerm arg1 arg2) = XorBitsTerm i arg1 arg2 - go (UComplementBitsTerm arg) = ComplementBitsTerm i arg - go (UShiftLeftTerm arg n) = ShiftLeftTerm i arg n - go (UShiftRightTerm arg n) = ShiftRightTerm i arg n - go (URotateLeftTerm arg n) = RotateLeftTerm i arg n - go (URotateRightTerm arg n) = RotateRightTerm i arg n - go (UToSignedTerm arg) = ToSignedTerm i arg - go (UToUnsignedTerm arg) = ToUnsignedTerm i arg - go (UBVConcatTerm arg1 arg2) = BVConcatTerm i arg1 arg2 - go (UBVSelectTerm ix w arg) = BVSelectTerm i ix w arg - go (UBVExtendTerm signed n arg) = BVExtendTerm i signed n arg - go (UTabularFunApplyTerm func arg) = TabularFunApplyTerm i func arg - go (UGeneralFunApplyTerm func arg) = GeneralFunApplyTerm i func arg - go (UDivIntegralTerm arg1 arg2) = DivIntegralTerm i arg1 arg2 - go (UModIntegralTerm arg1 arg2) = ModIntegralTerm i arg1 arg2 - go (UQuotIntegralTerm arg1 arg2) = QuotIntegralTerm i arg1 arg2 - go (URemIntegralTerm arg1 arg2) = RemIntegralTerm i arg1 arg2 - go (UDivBoundedIntegralTerm arg1 arg2) = DivBoundedIntegralTerm i arg1 arg2 - go (UModBoundedIntegralTerm arg1 arg2) = ModBoundedIntegralTerm i arg1 arg2 - go (UQuotBoundedIntegralTerm arg1 arg2) = QuotBoundedIntegralTerm i arg1 arg2 - go (URemBoundedIntegralTerm arg1 arg2) = RemBoundedIntegralTerm i arg1 arg2 - cache = termCache - -instance (SupportedPrim t) => Eq (Description (Term t)) where - DConTerm (l :: tyl) == DConTerm (r :: tyr) = cast @tyl @tyr l == Just r - DSymTerm ls == DSymTerm rs = ls == rs - DUnaryTerm (tagl :: tagl) li == DUnaryTerm (tagr :: tagr) ri = eqHeteroTag tagl tagr && eqTypedId li ri - DBinaryTerm (tagl :: tagl) li1 li2 == DBinaryTerm (tagr :: tagr) ri1 ri2 = - eqHeteroTag tagl tagr && eqTypedId li1 ri1 && eqTypedId li2 ri2 - DTernaryTerm (tagl :: tagl) li1 li2 li3 == DTernaryTerm (tagr :: tagr) ri1 ri2 ri3 = - eqHeteroTag tagl tagr && eqTypedId li1 ri1 && eqTypedId li2 ri2 && eqTypedId li3 ri3 - DNotTerm li == DNotTerm ri = li == ri - DOrTerm li1 li2 == DOrTerm ri1 ri2 = li1 == ri1 && li2 == ri2 - DAndTerm li1 li2 == DAndTerm ri1 ri2 = li1 == ri1 && li2 == ri2 - DEqvTerm lrep li1 li2 == DEqvTerm rrep ri1 ri2 = eqTypeRepBool lrep rrep && li1 == ri1 && li2 == ri2 - DITETerm lc li1 li2 == DITETerm rc ri1 ri2 = lc == rc && li1 == ri1 && li2 == ri2 - DAddNumTerm li1 li2 == DAddNumTerm ri1 ri2 = li1 == ri1 && li2 == ri2 - DUMinusNumTerm li == DUMinusNumTerm ri = li == ri - DTimesNumTerm li1 li2 == DTimesNumTerm ri1 ri2 = li1 == ri1 && li2 == ri2 - DAbsNumTerm li == DAbsNumTerm ri = li == ri - DSignumNumTerm li == DSignumNumTerm ri = li == ri - DLTNumTerm lrep li1 li2 == DLTNumTerm rrep ri1 ri2 = eqTypeRepBool lrep rrep && li1 == ri1 && li2 == ri2 - DLENumTerm lrep li1 li2 == DLENumTerm rrep ri1 ri2 = eqTypeRepBool lrep rrep && li1 == ri1 && li2 == ri2 - DAndBitsTerm li1 li2 == DAndBitsTerm ri1 ri2 = li1 == ri1 && li2 == ri2 - DOrBitsTerm li1 li2 == DOrBitsTerm ri1 ri2 = li1 == ri1 && li2 == ri2 - DXorBitsTerm li1 li2 == DXorBitsTerm ri1 ri2 = li1 == ri1 && li2 == ri2 - DComplementBitsTerm li == DComplementBitsTerm ri = li == ri - DShiftLeftTerm li ln == DShiftLeftTerm ri rn = li == ri && ln == rn - DShiftRightTerm li ln == DShiftRightTerm ri rn = li == ri && ln == rn - DRotateLeftTerm li ln == DRotateLeftTerm ri rn = li == ri && ln == rn - DRotateRightTerm li ln == DRotateRightTerm ri rn = li == ri && ln == rn - DToSignedTerm li == DToSignedTerm ri = eqTypedId li ri - DToUnsignedTerm li == DToUnsignedTerm ri = eqTypedId li ri - DBVConcatTerm lrep1 lrep2 li1 li2 == DBVConcatTerm rrep1 rrep2 ri1 ri2 = - eqTypeRepBool lrep1 rrep1 && eqTypeRepBool lrep2 rrep2 && li1 == ri1 && li2 == ri2 - DBVSelectTerm lix li == DBVSelectTerm rix ri = - eqTypeRepBool lix rix && eqTypedId li ri - DBVExtendTerm lIsSigned ln li == DBVExtendTerm rIsSigned rn ri = - lIsSigned == rIsSigned - && eqTypeRepBool ln rn - && eqTypedId li ri - DTabularFunApplyTerm lf li == DTabularFunApplyTerm rf ri = eqTypedId lf rf && eqTypedId li ri - DGeneralFunApplyTerm lf li == DGeneralFunApplyTerm rf ri = eqTypedId lf rf && eqTypedId li ri - DDivIntegralTerm li1 li2 == DDivIntegralTerm ri1 ri2 = li1 == ri1 && li2 == ri2 - DModIntegralTerm li1 li2 == DModIntegralTerm ri1 ri2 = li1 == ri1 && li2 == ri2 - DQuotIntegralTerm li1 li2 == DQuotIntegralTerm ri1 ri2 = li1 == ri1 && li2 == ri2 - DRemIntegralTerm li1 li2 == DRemIntegralTerm ri1 ri2 = li1 == ri1 && li2 == ri2 - DDivBoundedIntegralTerm li1 li2 == DDivBoundedIntegralTerm ri1 ri2 = li1 == ri1 && li2 == ri2 - DModBoundedIntegralTerm li1 li2 == DModBoundedIntegralTerm ri1 ri2 = li1 == ri1 && li2 == ri2 - DQuotBoundedIntegralTerm li1 li2 == DQuotBoundedIntegralTerm ri1 ri2 = li1 == ri1 && li2 == ri2 - DRemBoundedIntegralTerm li1 li2 == DRemBoundedIntegralTerm ri1 ri2 = li1 == ri1 && li2 == ri2 - _ == _ = False - -instance (SupportedPrim t) => Hashable (Description (Term t)) where - hashWithSalt s (DConTerm c) = s `hashWithSalt` (0 :: Int) `hashWithSalt` c - hashWithSalt s (DSymTerm name) = s `hashWithSalt` (1 :: Int) `hashWithSalt` name - hashWithSalt s (DUnaryTerm tag id1) = s `hashWithSalt` (2 :: Int) `hashWithSalt` tag `hashWithSalt` id1 - hashWithSalt s (DBinaryTerm tag id1 id2) = - s `hashWithSalt` (3 :: Int) `hashWithSalt` tag `hashWithSalt` id1 `hashWithSalt` id2 - hashWithSalt s (DTernaryTerm tag id1 id2 id3) = - s `hashWithSalt` (4 :: Int) `hashWithSalt` tag `hashWithSalt` id1 `hashWithSalt` id2 `hashWithSalt` id3 - hashWithSalt s (DNotTerm id1) = s `hashWithSalt` (5 :: Int) `hashWithSalt` id1 - hashWithSalt s (DOrTerm id1 id2) = s `hashWithSalt` (6 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 - hashWithSalt s (DAndTerm id1 id2) = s `hashWithSalt` (7 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 - hashWithSalt s (DEqvTerm rep id1 id2) = - s - `hashWithSalt` (8 :: Int) - `hashWithSalt` rep - `hashWithSalt` id1 - `hashWithSalt` id2 - hashWithSalt s (DITETerm idc id1 id2) = - s - `hashWithSalt` (9 :: Int) - `hashWithSalt` idc - `hashWithSalt` id1 - `hashWithSalt` id2 - hashWithSalt s (DAddNumTerm id1 id2) = s `hashWithSalt` (10 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 - hashWithSalt s (DUMinusNumTerm id1) = s `hashWithSalt` (11 :: Int) `hashWithSalt` id1 - hashWithSalt s (DTimesNumTerm id1 id2) = s `hashWithSalt` (12 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 - hashWithSalt s (DAbsNumTerm id1) = s `hashWithSalt` (13 :: Int) `hashWithSalt` id1 - hashWithSalt s (DSignumNumTerm id1) = s `hashWithSalt` (14 :: Int) `hashWithSalt` id1 - hashWithSalt s (DLTNumTerm rep id1 id2) = - s `hashWithSalt` (15 :: Int) `hashWithSalt` rep `hashWithSalt` id1 `hashWithSalt` id2 - hashWithSalt s (DLENumTerm rep id1 id2) = - s `hashWithSalt` (16 :: Int) `hashWithSalt` rep `hashWithSalt` id1 `hashWithSalt` id2 - hashWithSalt s (DAndBitsTerm id1 id2) = s `hashWithSalt` (17 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 - hashWithSalt s (DOrBitsTerm id1 id2) = s `hashWithSalt` (18 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 - hashWithSalt s (DXorBitsTerm id1 id2) = s `hashWithSalt` (19 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 - hashWithSalt s (DComplementBitsTerm id1) = s `hashWithSalt` (20 :: Int) `hashWithSalt` id1 - hashWithSalt s (DShiftLeftTerm id1 idn) = s `hashWithSalt` (38 :: Int) `hashWithSalt` id1 `hashWithSalt` idn - hashWithSalt s (DShiftRightTerm id1 idn) = s `hashWithSalt` (39 :: Int) `hashWithSalt` id1 `hashWithSalt` idn - hashWithSalt s (DRotateLeftTerm id1 idn) = s `hashWithSalt` (40 :: Int) `hashWithSalt` id1 `hashWithSalt` idn - hashWithSalt s (DRotateRightTerm id1 idn) = s `hashWithSalt` (41 :: Int) `hashWithSalt` id1 `hashWithSalt` idn - hashWithSalt s (DToSignedTerm id) = s `hashWithSalt` (23 :: Int) `hashWithSalt` id - hashWithSalt s (DToUnsignedTerm id) = s `hashWithSalt` (24 :: Int) `hashWithSalt` id - hashWithSalt s (DBVConcatTerm rep1 rep2 id1 id2) = - s `hashWithSalt` (25 :: Int) `hashWithSalt` rep1 `hashWithSalt` rep2 `hashWithSalt` id1 `hashWithSalt` id2 - hashWithSalt s (DBVSelectTerm ix id1) = s `hashWithSalt` (26 :: Int) `hashWithSalt` ix `hashWithSalt` id1 - hashWithSalt s (DBVExtendTerm signed n id1) = - s - `hashWithSalt` (27 :: Int) - `hashWithSalt` signed - `hashWithSalt` n - `hashWithSalt` id1 - hashWithSalt s (DTabularFunApplyTerm id1 id2) = s `hashWithSalt` (28 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 - hashWithSalt s (DGeneralFunApplyTerm id1 id2) = s `hashWithSalt` (29 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 - hashWithSalt s (DDivIntegralTerm id1 id2) = s `hashWithSalt` (30 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 - hashWithSalt s (DModIntegralTerm id1 id2) = s `hashWithSalt` (31 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 - hashWithSalt s (DQuotIntegralTerm id1 id2) = s `hashWithSalt` (32 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 - hashWithSalt s (DRemIntegralTerm id1 id2) = s `hashWithSalt` (33 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 - hashWithSalt s (DDivBoundedIntegralTerm id1 id2) = s `hashWithSalt` (34 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 - hashWithSalt s (DModBoundedIntegralTerm id1 id2) = s `hashWithSalt` (35 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 - hashWithSalt s (DQuotBoundedIntegralTerm id1 id2) = s `hashWithSalt` (36 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 - hashWithSalt s (DRemBoundedIntegralTerm id1 id2) = s `hashWithSalt` (37 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 - --- Basic Bool -defaultValueForBool :: Bool -defaultValueForBool = False - -defaultValueForBoolDyn :: ModelValue -defaultValueForBoolDyn = toModelValue defaultValueForBool - -instance SupportedPrim Bool where - pformatCon True = "true" - pformatCon False = "false" - defaultValue = defaultValueForBool - defaultValueDynamic _ = defaultValueForBoolDyn - -defaultValueForInteger :: Integer -defaultValueForInteger = 0 - -defaultValueForIntegerDyn :: ModelValue -defaultValueForIntegerDyn = toModelValue defaultValueForInteger - --- Basic Integer -instance SupportedPrim Integer where - pformatCon = show - defaultValue = defaultValueForInteger - defaultValueDynamic _ = defaultValueForIntegerDyn - --- Signed BV -instance (KnownNat w, 1 <= w) => SupportedPrim (IntN w) where - type PrimConstraint (IntN w) = (KnownNat w, 1 <= w) - pformatCon = show - defaultValue = 0 - --- Unsigned BV -instance (KnownNat w, 1 <= w) => SupportedPrim (WordN w) where - type PrimConstraint (WordN w) = (KnownNat w, 1 <= w) - pformatCon = show - defaultValue = 0 - --- | General symbolic function type. Use the '#' operator to apply the function. --- Note that this function should be applied to symbolic values only. It is by --- itself already a symbolic value, but can be considered partially concrete --- as the function body is specified. Use 'Grisette.IR.SymPrim.Data.SymPrim.-~>' for uninterpreted general --- symbolic functions. --- --- The result would be partially evaluated. --- --- >>> :set -XOverloadedStrings --- >>> :set -XTypeOperators --- >>> let f = ("x" :: TypedSymbol Integer) --> ("x" + 1 + "y" :: SymInteger) :: Integer --> Integer --- >>> f # 1 -- 1 has the type SymInteger --- (+ 2 y) --- >>> f # "a" -- "a" has the type SymInteger --- (+ 1 (+ a y)) -data (-->) a b where - GeneralFun :: (SupportedPrim a, SupportedPrim b) => TypedSymbol a -> Term b -> a --> b - -instance (LinkedRep a sa, LinkedRep b sb) => Function (a --> b) where - type Arg (a --> b) = SymType a - type Ret (a --> b) = SymType b - (GeneralFun s t) # x = wrapTerm $ substTerm s (underlyingTerm x) t - -{- -pattern GeneralFun :: () => (SupportedPrim a, SupportedPrim b) => TypedSymbol a -> Term b -> a --> b -pattern GeneralFun arg v <- GeneralFun arg v - -{-# COMPLETE GeneralFun #-} --} - -infixr 0 --> - -buildGeneralFun :: () => (SupportedPrim a, SupportedPrim b) => TypedSymbol a -> Term b -> a --> b -buildGeneralFun arg v = GeneralFun newarg (substTerm arg (symTerm newarg) v) - where - newarg = WithInfo arg ARG - -data ARG = ARG - deriving (Eq, Ord, Lift, Show, Generic) - -instance NFData ARG where - rnf ARG = () - -instance Hashable ARG where - hashWithSalt s ARG = s `hashWithSalt` (0 :: Int) - -instance Eq (a --> b) where - GeneralFun sym1 tm1 == GeneralFun sym2 tm2 = sym1 == sym2 && tm1 == tm2 - -instance Show (a --> b) where - show (GeneralFun sym tm) = "\\(" ++ show sym ++ ") -> " ++ pformat tm - -instance Lift (a --> b) where - liftTyped (GeneralFun sym tm) = [||GeneralFun sym tm||] - -instance Hashable (a --> b) where - s `hashWithSalt` (GeneralFun sym tm) = s `hashWithSalt` sym `hashWithSalt` tm - -instance NFData (a --> b) where - rnf (GeneralFun sym tm) = rnf sym `seq` rnf tm - -instance (SupportedPrim a, SupportedPrim b) => SupportedPrim (a --> b) where - type PrimConstraint (a --> b) = (SupportedPrim a, SupportedPrim b) - defaultValue = buildGeneralFun (SimpleSymbol "a") (conTerm defaultValue) - -instance - (SupportedPrim a, SupportedPrim b) => - SupportedPrim (a =-> b) - where - type PrimConstraint (a =-> b) = (SupportedPrim a, SupportedPrim b) - defaultValue = TabularFun [] (defaultValue @b) diff --git a/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/Term.hs-boot b/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/Term.hs-boot deleted file mode 100644 --- a/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/Term.hs-boot +++ /dev/null @@ -1,402 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -module Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term - ( SupportedPrim (..), - SymRep (..), - ConRep (..), - LinkedRep (..), - UnaryOp (..), - BinaryOp (..), - TernaryOp (..), - TypedSymbol (..), - SomeTypedSymbol (..), - Term (..), - UTerm (..), - type (-->) (..), - buildGeneralFun, - ) -where - -import Control.DeepSeq (NFData) -import Data.Bits (Bits, FiniteBits) -import Data.Hashable (Hashable) -import Data.Interned (Cache, Id) -import Data.Kind (Constraint) -import qualified Data.Text as T -import GHC.TypeNats (KnownNat, type (+), type (<=)) -import Grisette.Core.Data.Class.BitVector - ( SizedBV, - ) -import Grisette.Core.Data.Class.SignConversion (SignConversion) -import Grisette.Core.Data.Class.SymRotate (SymRotate) -import Grisette.Core.Data.Class.SymShift (SymShift) -import Grisette.IR.SymPrim.Data.Prim.ModelValue - ( ModelValue, - toModelValue, - ) -import Grisette.IR.SymPrim.Data.TabularFun - ( type (=->), - ) -import Language.Haskell.TH.Syntax (Lift) -import Type.Reflection (TypeRep, Typeable) - -class (Lift t, Typeable t, Hashable t, Eq t, Show t, NFData t) => SupportedPrim t where - type PrimConstraint t :: Constraint - type PrimConstraint _ = () - default withPrim :: (PrimConstraint t) => proxy t -> ((PrimConstraint t) => a) -> a - withPrim :: proxy t -> ((PrimConstraint t) => a) -> a - withPrim _ i = i - termCache :: Cache (Term t) - termCache = typeMemoizedCache - pformatCon :: t -> String - default pformatCon :: (Show t) => t -> String - pformatCon = show - pformatSym :: TypedSymbol t -> String - pformatSym _ = showUntyped - defaultValue :: t - defaultValueDynamic :: proxy t -> ModelValue - defaultValueDynamic _ = toModelValue (defaultValue @t) - -class ConRep sym where - type ConType sym - -class (SupportedPrim con) => SymRep con where - type SymType con - -class - (ConRep sym, SymRep con, sym ~ SymType con, con ~ ConType sym) => - LinkedRep con sym - | con -> sym, - sym -> con - where - underlyingTerm :: sym -> Term con - wrapTerm :: Term con -> sym - -class - (SupportedPrim arg, SupportedPrim t, Lift tag, NFData tag, Show tag, Typeable tag, Eq tag, Hashable tag) => - UnaryOp tag arg t - | tag arg -> t - where - partialEvalUnary :: (Typeable tag, Typeable t) => tag -> Term arg -> Term t - pformatUnary :: tag -> Term arg -> String - -class - ( SupportedPrim arg1, - SupportedPrim arg2, - SupportedPrim t, - Lift tag, - NFData tag, - Show tag, - Typeable tag, - Eq tag, - Hashable tag - ) => - BinaryOp tag arg1 arg2 t - | tag arg1 arg2 -> t - where - partialEvalBinary :: (Typeable tag, Typeable t) => tag -> Term arg1 -> Term arg2 -> Term t - pformatBinary :: tag -> Term arg1 -> Term arg2 -> String - -class - ( SupportedPrim arg1, - SupportedPrim arg2, - SupportedPrim arg3, - SupportedPrim t, - Lift tag, - NFData tag, - Show tag, - Typeable tag, - Eq tag, - Hashable tag - ) => - TernaryOp tag arg1 arg2 arg3 t - | tag arg1 arg2 arg3 -> t - where - partialEvalTernary :: (Typeable tag, Typeable t) => tag -> Term arg1 -> Term arg2 -> Term arg3 -> Term t - pformatTernary :: tag -> Term arg1 -> Term arg2 -> Term arg3 -> String - -data TypedSymbol t where - SimpleSymbol :: (SupportedPrim t) => T.Text -> TypedSymbol t - IndexedSymbol :: (SupportedPrim t) => T.Text -> Int -> TypedSymbol t - WithInfo :: - forall t a. - ( SupportedPrim t, - Typeable a, - Ord a, - Lift a, - NFData a, - Show a, - Hashable a - ) => - TypedSymbol t -> - a -> - TypedSymbol t - -data SomeTypedSymbol where - SomeTypedSymbol :: forall t. TypeRep t -> TypedSymbol t -> SomeTypedSymbol - -data Term t where - ConTerm :: (SupportedPrim t) => {-# UNPACK #-} !Id -> !t -> Term t - SymTerm :: (SupportedPrim t) => {-# UNPACK #-} !Id -> !(TypedSymbol t) -> Term t - UnaryTerm :: - (UnaryOp tag arg t) => - {-# UNPACK #-} !Id -> - !tag -> - !(Term arg) -> - Term t - BinaryTerm :: - (BinaryOp tag arg1 arg2 t) => - {-# UNPACK #-} !Id -> - !tag -> - !(Term arg1) -> - !(Term arg2) -> - Term t - TernaryTerm :: - (TernaryOp tag arg1 arg2 arg3 t) => - {-# UNPACK #-} !Id -> - !tag -> - !(Term arg1) -> - !(Term arg2) -> - !(Term arg3) -> - Term t - NotTerm :: {-# UNPACK #-} !Id -> !(Term Bool) -> Term Bool - OrTerm :: {-# UNPACK #-} !Id -> !(Term Bool) -> !(Term Bool) -> Term Bool - AndTerm :: {-# UNPACK #-} !Id -> !(Term Bool) -> !(Term Bool) -> Term Bool - EqvTerm :: (SupportedPrim t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term Bool - ITETerm :: (SupportedPrim t) => {-# UNPACK #-} !Id -> !(Term Bool) -> !(Term t) -> !(Term t) -> Term t - AddNumTerm :: (SupportedPrim t, Num t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t - UMinusNumTerm :: (SupportedPrim t, Num t) => {-# UNPACK #-} !Id -> !(Term t) -> Term t - TimesNumTerm :: (SupportedPrim t, Num t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t - AbsNumTerm :: (SupportedPrim t, Num t) => {-# UNPACK #-} !Id -> !(Term t) -> Term t - SignumNumTerm :: (SupportedPrim t, Num t) => {-# UNPACK #-} !Id -> !(Term t) -> Term t - LTNumTerm :: (SupportedPrim t, Num t, Ord t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term Bool - LENumTerm :: (SupportedPrim t, Num t, Ord t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term Bool - AndBitsTerm :: (SupportedPrim t, Bits t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t - OrBitsTerm :: (SupportedPrim t, Bits t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t - XorBitsTerm :: (SupportedPrim t, Bits t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t - ComplementBitsTerm :: (SupportedPrim t, Bits t) => {-# UNPACK #-} !Id -> !(Term t) -> Term t - ShiftLeftTerm :: (SupportedPrim t, Integral t, FiniteBits t, SymShift t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t - ShiftRightTerm :: (SupportedPrim t, Integral t, FiniteBits t, SymShift t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t - RotateLeftTerm :: (SupportedPrim t, Integral t, FiniteBits t, SymRotate t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t - RotateRightTerm :: (SupportedPrim t, Integral t, FiniteBits t, SymRotate t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t - ToSignedTerm :: - ( SupportedPrim u, - SupportedPrim s, - SignConversion u s - ) => - {-# UNPACK #-} !Id -> - !(Term u) -> - Term s - ToUnsignedTerm :: - ( SupportedPrim u, - SupportedPrim s, - SignConversion u s - ) => - {-# UNPACK #-} !Id -> - !(Term s) -> - Term u - BVConcatTerm :: - ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n), - Typeable bv, - KnownNat a, - KnownNat b, - KnownNat (a + b), - 1 <= a, - 1 <= b, - 1 <= (a + b), - SizedBV bv - ) => - {-# UNPACK #-} !Id -> - !(Term (bv a)) -> - !(Term (bv b)) -> - Term (bv (a + b)) - BVSelectTerm :: - ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n), - Typeable bv, - KnownNat n, - KnownNat ix, - KnownNat w, - 1 <= n, - 1 <= w, - ix + w <= n, - SizedBV bv - ) => - {-# UNPACK #-} !Id -> - !(TypeRep ix) -> - !(TypeRep w) -> - !(Term (bv n)) -> - Term (bv w) - BVExtendTerm :: - ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n), - Typeable bv, - KnownNat l, - KnownNat r, - 1 <= l, - 1 <= r, - l <= r, - SizedBV bv - ) => - {-# UNPACK #-} !Id -> - !Bool -> - !(TypeRep r) -> - !(Term (bv l)) -> - Term (bv r) - TabularFunApplyTerm :: - ( SupportedPrim a, - SupportedPrim b - ) => - {-# UNPACK #-} !Id -> - Term (a =-> b) -> - Term a -> - Term b - GeneralFunApplyTerm :: - ( SupportedPrim a, - SupportedPrim b - ) => - {-# UNPACK #-} !Id -> - Term (a --> b) -> - Term a -> - Term b - DivIntegralTerm :: (SupportedPrim t, Integral t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t - ModIntegralTerm :: (SupportedPrim t, Integral t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t - QuotIntegralTerm :: (SupportedPrim t, Integral t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t - RemIntegralTerm :: (SupportedPrim t, Integral t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t - DivBoundedIntegralTerm :: (SupportedPrim t, Bounded t, Integral t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t - ModBoundedIntegralTerm :: (SupportedPrim t, Bounded t, Integral t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t - QuotBoundedIntegralTerm :: (SupportedPrim t, Bounded t, Integral t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t - RemBoundedIntegralTerm :: (SupportedPrim t, Bounded t, Integral t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t - -data UTerm t where - UConTerm :: (SupportedPrim t) => !t -> UTerm t - USymTerm :: (SupportedPrim t) => !(TypedSymbol t) -> UTerm t - UUnaryTerm :: (UnaryOp tag arg t) => !tag -> !(Term arg) -> UTerm t - UBinaryTerm :: - (BinaryOp tag arg1 arg2 t) => - !tag -> - !(Term arg1) -> - !(Term arg2) -> - UTerm t - UTernaryTerm :: - (TernaryOp tag arg1 arg2 arg3 t) => - !tag -> - !(Term arg1) -> - !(Term arg2) -> - !(Term arg3) -> - UTerm t - UNotTerm :: !(Term Bool) -> UTerm Bool - UOrTerm :: !(Term Bool) -> !(Term Bool) -> UTerm Bool - UAndTerm :: !(Term Bool) -> !(Term Bool) -> UTerm Bool - UEqvTerm :: (SupportedPrim t) => !(Term t) -> !(Term t) -> UTerm Bool - UITETerm :: (SupportedPrim t) => !(Term Bool) -> !(Term t) -> !(Term t) -> UTerm t - UAddNumTerm :: (SupportedPrim t, Num t) => !(Term t) -> !(Term t) -> UTerm t - UUMinusNumTerm :: (SupportedPrim t, Num t) => !(Term t) -> UTerm t - UTimesNumTerm :: (SupportedPrim t, Num t) => !(Term t) -> !(Term t) -> UTerm t - UAbsNumTerm :: (SupportedPrim t, Num t) => !(Term t) -> UTerm t - USignumNumTerm :: (SupportedPrim t, Num t) => !(Term t) -> UTerm t - ULTNumTerm :: (SupportedPrim t, Num t, Ord t) => !(Term t) -> !(Term t) -> UTerm Bool - ULENumTerm :: (SupportedPrim t, Num t, Ord t) => !(Term t) -> !(Term t) -> UTerm Bool - UAndBitsTerm :: (SupportedPrim t, Bits t) => !(Term t) -> !(Term t) -> UTerm t - UOrBitsTerm :: (SupportedPrim t, Bits t) => !(Term t) -> !(Term t) -> UTerm t - UXorBitsTerm :: (SupportedPrim t, Bits t) => !(Term t) -> !(Term t) -> UTerm t - UComplementBitsTerm :: (SupportedPrim t, Bits t) => !(Term t) -> UTerm t - UShiftLeftTerm :: (SupportedPrim t, Integral t, FiniteBits t, SymShift t) => !(Term t) -> !(Term t) -> UTerm t - UShiftRightTerm :: (SupportedPrim t, Integral t, FiniteBits t, SymShift t) => !(Term t) -> !(Term t) -> UTerm t - URotateLeftTerm :: (SupportedPrim t, Integral t, FiniteBits t, SymRotate t) => !(Term t) -> !(Term t) -> UTerm t - URotateRightTerm :: (SupportedPrim t, Integral t, FiniteBits t, SymRotate t) => !(Term t) -> !(Term t) -> UTerm t - UToSignedTerm :: - ( SupportedPrim u, - SupportedPrim s, - SignConversion u s - ) => - !(Term u) -> - UTerm s - UToUnsignedTerm :: - ( SupportedPrim u, - SupportedPrim s, - SignConversion u s - ) => - !(Term s) -> - UTerm u - UBVConcatTerm :: - ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n), - Typeable bv, - KnownNat a, - KnownNat b, - KnownNat (a + b), - 1 <= a, - 1 <= b, - 1 <= a + b, - SizedBV bv - ) => - !(Term (bv a)) -> - !(Term (bv b)) -> - UTerm (bv (a + b)) - UBVSelectTerm :: - ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n), - Typeable bv, - KnownNat n, - KnownNat ix, - KnownNat w, - 1 <= n, - 1 <= w, - ix + w <= n, - SizedBV bv - ) => - !(TypeRep ix) -> - !(TypeRep w) -> - !(Term (bv n)) -> - UTerm (bv w) - UBVExtendTerm :: - ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n), - Typeable bv, - KnownNat l, - KnownNat r, - 1 <= l, - 1 <= r, - l <= r, - SizedBV bv - ) => - !Bool -> - !(TypeRep r) -> - !(Term (bv l)) -> - UTerm (bv r) - UTabularFunApplyTerm :: - ( SupportedPrim a, - SupportedPrim b - ) => - Term (a =-> b) -> - Term a -> - UTerm b - UGeneralFunApplyTerm :: - ( SupportedPrim a, - SupportedPrim b - ) => - Term (a --> b) -> - Term a -> - UTerm b - UDivIntegralTerm :: (SupportedPrim t, Integral t) => !(Term t) -> !(Term t) -> UTerm t - UModIntegralTerm :: (SupportedPrim t, Integral t) => !(Term t) -> !(Term t) -> UTerm t - UQuotIntegralTerm :: (SupportedPrim t, Integral t) => !(Term t) -> !(Term t) -> UTerm t - URemIntegralTerm :: (SupportedPrim t, Integral t) => !(Term t) -> !(Term t) -> UTerm t - UDivBoundedIntegralTerm :: (SupportedPrim t, Bounded t, Integral t) => !(Term t) -> !(Term t) -> UTerm t - UModBoundedIntegralTerm :: (SupportedPrim t, Bounded t, Integral t) => !(Term t) -> !(Term t) -> UTerm t - UQuotBoundedIntegralTerm :: (SupportedPrim t, Bounded t, Integral t) => !(Term t) -> !(Term t) -> UTerm t - URemBoundedIntegralTerm :: (SupportedPrim t, Bounded t, Integral t) => !(Term t) -> !(Term t) -> UTerm t - -data (-->) a b where - GeneralFun :: (SupportedPrim a, SupportedPrim b) => TypedSymbol a -> Term b -> a --> b - -infixr 0 --> - -buildGeneralFun :: (SupportedPrim a, SupportedPrim b) => TypedSymbol a -> Term b -> a --> b diff --git a/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/TermSubstitution.hs b/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/TermSubstitution.hs deleted file mode 100644 --- a/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/TermSubstitution.hs +++ /dev/null @@ -1,194 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} - --- | --- Module : Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermSubstitution --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermSubstitution - ( substTerm, - ) -where - -import Grisette.Core.Data.MemoUtils (htmemo) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors - ( conTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.SomeTerm - ( SomeTerm (SomeTerm), - ) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term - ( BinaryOp (partialEvalBinary), - SupportedPrim, - Term - ( AbsNumTerm, - AddNumTerm, - AndBitsTerm, - AndTerm, - BVConcatTerm, - BVExtendTerm, - BVSelectTerm, - BinaryTerm, - ComplementBitsTerm, - ConTerm, - DivBoundedIntegralTerm, - DivIntegralTerm, - EqvTerm, - GeneralFunApplyTerm, - ITETerm, - LENumTerm, - LTNumTerm, - ModBoundedIntegralTerm, - ModIntegralTerm, - NotTerm, - OrBitsTerm, - OrTerm, - QuotBoundedIntegralTerm, - QuotIntegralTerm, - RemBoundedIntegralTerm, - RemIntegralTerm, - RotateLeftTerm, - RotateRightTerm, - ShiftLeftTerm, - ShiftRightTerm, - SignumNumTerm, - SymTerm, - TabularFunApplyTerm, - TernaryTerm, - TimesNumTerm, - ToSignedTerm, - ToUnsignedTerm, - UMinusNumTerm, - UnaryTerm, - XorBitsTerm - ), - TernaryOp (partialEvalTernary), - TypedSymbol, - UnaryOp (partialEvalUnary), - someTypedSymbol, - type (-->) (GeneralFun), - ) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.BV - ( pevalBVConcatTerm, - pevalBVExtendTerm, - pevalBVSelectTerm, - pevalToSignedTerm, - pevalToUnsignedTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bits - ( pevalAndBitsTerm, - pevalComplementBitsTerm, - pevalOrBitsTerm, - pevalRotateLeftTerm, - pevalRotateRightTerm, - pevalShiftLeftTerm, - pevalShiftRightTerm, - pevalXorBitsTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool - ( pevalAndTerm, - pevalEqvTerm, - pevalITETerm, - pevalNotTerm, - pevalOrTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.GeneralFun - ( pevalGeneralFunApplyTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.Integral - ( pevalDivBoundedIntegralTerm, - pevalDivIntegralTerm, - pevalModBoundedIntegralTerm, - pevalModIntegralTerm, - pevalQuotBoundedIntegralTerm, - pevalQuotIntegralTerm, - pevalRemBoundedIntegralTerm, - pevalRemIntegralTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.Num - ( pevalAbsNumTerm, - pevalAddNumTerm, - pevalLeNumTerm, - pevalLtNumTerm, - pevalSignumNumTerm, - pevalTimesNumTerm, - pevalUMinusNumTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.TabularFun - ( pevalTabularFunApplyTerm, - ) -import Type.Reflection - ( TypeRep, - eqTypeRep, - typeRep, - pattern App, - type (:~~:) (HRefl), - ) -import Unsafe.Coerce (unsafeCoerce) - -substTerm :: forall a b. (SupportedPrim a, SupportedPrim b) => TypedSymbol a -> Term a -> Term b -> Term b -substTerm sym term = gov - where - gov :: (SupportedPrim x) => Term x -> Term x - gov b = case go (SomeTerm b) of - SomeTerm v -> unsafeCoerce v - go :: SomeTerm -> SomeTerm - go = htmemo $ \stm@(SomeTerm (tm :: Term v)) -> - case tm of - ConTerm _ cv -> case (typeRep :: TypeRep v) of - App (App gf _) _ -> - case eqTypeRep gf (typeRep @(-->)) of - Just HRefl -> case cv of - GeneralFun sym1 tm1 -> - if someTypedSymbol sym1 == someTypedSymbol sym - then stm - else SomeTerm $ conTerm $ GeneralFun sym1 (gov tm1) - Nothing -> stm - _ -> stm - SymTerm _ ts -> SomeTerm $ if someTypedSymbol ts == someTypedSymbol sym then unsafeCoerce term else tm - UnaryTerm _ tag te -> SomeTerm $ partialEvalUnary tag (gov te) - BinaryTerm _ tag te te' -> SomeTerm $ partialEvalBinary tag (gov te) (gov te') - TernaryTerm _ tag op1 op2 op3 -> SomeTerm $ partialEvalTernary tag (gov op1) (gov op2) (gov op3) - NotTerm _ op -> SomeTerm $ pevalNotTerm (gov op) - OrTerm _ op1 op2 -> SomeTerm $ pevalOrTerm (gov op1) (gov op2) - AndTerm _ op1 op2 -> SomeTerm $ pevalAndTerm (gov op1) (gov op2) - EqvTerm _ op1 op2 -> SomeTerm $ pevalEqvTerm (gov op1) (gov op2) - ITETerm _ c op1 op2 -> SomeTerm $ pevalITETerm (gov c) (gov op1) (gov op2) - AddNumTerm _ op1 op2 -> SomeTerm $ pevalAddNumTerm (gov op1) (gov op2) - UMinusNumTerm _ op -> SomeTerm $ pevalUMinusNumTerm (gov op) - TimesNumTerm _ op1 op2 -> SomeTerm $ pevalTimesNumTerm (gov op1) (gov op2) - AbsNumTerm _ op -> SomeTerm $ pevalAbsNumTerm (gov op) - SignumNumTerm _ op -> SomeTerm $ pevalSignumNumTerm (gov op) - LTNumTerm _ op1 op2 -> SomeTerm $ pevalLtNumTerm (gov op1) (gov op2) - LENumTerm _ op1 op2 -> SomeTerm $ pevalLeNumTerm (gov op1) (gov op2) - AndBitsTerm _ op1 op2 -> SomeTerm $ pevalAndBitsTerm (gov op1) (gov op2) - OrBitsTerm _ op1 op2 -> SomeTerm $ pevalOrBitsTerm (gov op1) (gov op2) - XorBitsTerm _ op1 op2 -> SomeTerm $ pevalXorBitsTerm (gov op1) (gov op2) - ComplementBitsTerm _ op -> SomeTerm $ pevalComplementBitsTerm (gov op) - ShiftLeftTerm _ op n -> SomeTerm $ pevalShiftLeftTerm (gov op) (gov n) - RotateLeftTerm _ op n -> SomeTerm $ pevalRotateLeftTerm (gov op) (gov n) - ShiftRightTerm _ op n -> SomeTerm $ pevalShiftRightTerm (gov op) (gov n) - RotateRightTerm _ op n -> SomeTerm $ pevalRotateRightTerm (gov op) (gov n) - ToSignedTerm _ op -> SomeTerm $ pevalToSignedTerm op - ToUnsignedTerm _ op -> SomeTerm $ pevalToUnsignedTerm op - BVConcatTerm _ op1 op2 -> SomeTerm $ pevalBVConcatTerm (gov op1) (gov op2) - BVSelectTerm _ ix w op -> SomeTerm $ pevalBVSelectTerm ix w (gov op) - BVExtendTerm _ n signed op -> SomeTerm $ pevalBVExtendTerm n signed (gov op) - TabularFunApplyTerm _ f op -> SomeTerm $ pevalTabularFunApplyTerm (gov f) (gov op) - GeneralFunApplyTerm _ f op -> SomeTerm $ pevalGeneralFunApplyTerm (gov f) (gov op) - DivIntegralTerm _ op1 op2 -> SomeTerm $ pevalDivIntegralTerm (gov op1) (gov op2) - ModIntegralTerm _ op1 op2 -> SomeTerm $ pevalModIntegralTerm (gov op1) (gov op2) - QuotIntegralTerm _ op1 op2 -> SomeTerm $ pevalQuotIntegralTerm (gov op1) (gov op2) - RemIntegralTerm _ op1 op2 -> SomeTerm $ pevalRemIntegralTerm (gov op1) (gov op2) - DivBoundedIntegralTerm _ op1 op2 -> SomeTerm $ pevalDivBoundedIntegralTerm (gov op1) (gov op2) - ModBoundedIntegralTerm _ op1 op2 -> SomeTerm $ pevalModBoundedIntegralTerm (gov op1) (gov op2) - QuotBoundedIntegralTerm _ op1 op2 -> SomeTerm $ pevalQuotBoundedIntegralTerm (gov op1) (gov op2) - RemBoundedIntegralTerm _ op1 op2 -> SomeTerm $ pevalRemBoundedIntegralTerm (gov op1) (gov op2) diff --git a/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/TermSubstitution.hs-boot b/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/TermSubstitution.hs-boot deleted file mode 100644 --- a/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/TermSubstitution.hs-boot +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE RankNTypes #-} - -module Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermSubstitution - ( substTerm, - ) -where - -import {-# SOURCE #-} Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term - ( SupportedPrim, - Term, - TypedSymbol, - ) - -substTerm :: - forall a b. - (SupportedPrim a, SupportedPrim b) => - TypedSymbol a -> - Term a -> - Term b -> - Term b diff --git a/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/TermUtils.hs b/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/TermUtils.hs deleted file mode 100644 --- a/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/TermUtils.hs +++ /dev/null @@ -1,449 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - --- | --- Module : Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermUtils --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermUtils - ( identity, - identityWithTypeRep, - introSupportedPrimConstraint, - extractSymbolicsTerm, - castTerm, - pformat, - someTermsSize, - someTermSize, - termSize, - termsSize, - ) -where - -import Control.Monad.State - ( MonadState (get, put), - State, - evalState, - execState, - gets, - modify', - ) -import qualified Data.HashMap.Strict as M -import qualified Data.HashSet as S -import Data.Interned (Id) -import Data.Typeable - ( Proxy (Proxy), - TypeRep, - Typeable, - cast, - typeRep, - ) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.SomeTerm - ( SomeTerm (SomeTerm), - ) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term - ( BinaryOp (pformatBinary), - SomeTypedSymbol (SomeTypedSymbol), - SupportedPrim (pformatCon, pformatSym), - Term - ( AbsNumTerm, - AddNumTerm, - AndBitsTerm, - AndTerm, - BVConcatTerm, - BVExtendTerm, - BVSelectTerm, - BinaryTerm, - ComplementBitsTerm, - ConTerm, - DivBoundedIntegralTerm, - DivIntegralTerm, - EqvTerm, - GeneralFunApplyTerm, - ITETerm, - LENumTerm, - LTNumTerm, - ModBoundedIntegralTerm, - ModIntegralTerm, - NotTerm, - OrBitsTerm, - OrTerm, - QuotBoundedIntegralTerm, - QuotIntegralTerm, - RemBoundedIntegralTerm, - RemIntegralTerm, - RotateLeftTerm, - RotateRightTerm, - ShiftLeftTerm, - ShiftRightTerm, - SignumNumTerm, - SymTerm, - TabularFunApplyTerm, - TernaryTerm, - TimesNumTerm, - ToSignedTerm, - ToUnsignedTerm, - UMinusNumTerm, - UnaryTerm, - XorBitsTerm - ), - TernaryOp (pformatTernary), - TypedSymbol, - UnaryOp (pformatUnary), - ) -import qualified Type.Reflection as R - -identity :: Term t -> Id -identity = snd . identityWithTypeRep -{-# INLINE identity #-} - -identityWithTypeRep :: forall t. Term t -> (TypeRep, Id) -identityWithTypeRep (ConTerm i _) = (typeRep (Proxy @t), i) -identityWithTypeRep (SymTerm i _) = (typeRep (Proxy @t), i) -identityWithTypeRep (UnaryTerm i _ _) = (typeRep (Proxy @t), i) -identityWithTypeRep (BinaryTerm i _ _ _) = (typeRep (Proxy @t), i) -identityWithTypeRep (TernaryTerm i _ _ _ _) = (typeRep (Proxy @t), i) -identityWithTypeRep (NotTerm i _) = (typeRep (Proxy @t), i) -identityWithTypeRep (OrTerm i _ _) = (typeRep (Proxy @t), i) -identityWithTypeRep (AndTerm i _ _) = (typeRep (Proxy @t), i) -identityWithTypeRep (EqvTerm i _ _) = (typeRep (Proxy @t), i) -identityWithTypeRep (ITETerm i _ _ _) = (typeRep (Proxy @t), i) -identityWithTypeRep (AddNumTerm i _ _) = (typeRep (Proxy @t), i) -identityWithTypeRep (UMinusNumTerm i _) = (typeRep (Proxy @t), i) -identityWithTypeRep (TimesNumTerm i _ _) = (typeRep (Proxy @t), i) -identityWithTypeRep (AbsNumTerm i _) = (typeRep (Proxy @t), i) -identityWithTypeRep (SignumNumTerm i _) = (typeRep (Proxy @t), i) -identityWithTypeRep (LTNumTerm i _ _) = (typeRep (Proxy @t), i) -identityWithTypeRep (LENumTerm i _ _) = (typeRep (Proxy @t), i) -identityWithTypeRep (AndBitsTerm i _ _) = (typeRep (Proxy @t), i) -identityWithTypeRep (OrBitsTerm i _ _) = (typeRep (Proxy @t), i) -identityWithTypeRep (XorBitsTerm i _ _) = (typeRep (Proxy @t), i) -identityWithTypeRep (ComplementBitsTerm i _) = (typeRep (Proxy @t), i) -identityWithTypeRep (ShiftLeftTerm i _ _) = (typeRep (Proxy @t), i) -identityWithTypeRep (ShiftRightTerm i _ _) = (typeRep (Proxy @t), i) -identityWithTypeRep (RotateLeftTerm i _ _) = (typeRep (Proxy @t), i) -identityWithTypeRep (RotateRightTerm i _ _) = (typeRep (Proxy @t), i) -identityWithTypeRep (ToSignedTerm i _) = (typeRep (Proxy @t), i) -identityWithTypeRep (ToUnsignedTerm i _) = (typeRep (Proxy @t), i) -identityWithTypeRep (BVConcatTerm i _ _) = (typeRep (Proxy @t), i) -identityWithTypeRep (BVSelectTerm i _ _ _) = (typeRep (Proxy @t), i) -identityWithTypeRep (BVExtendTerm i _ _ _) = (typeRep (Proxy @t), i) -identityWithTypeRep (TabularFunApplyTerm i _ _) = (typeRep (Proxy @t), i) -identityWithTypeRep (GeneralFunApplyTerm i _ _) = (typeRep (Proxy @t), i) -identityWithTypeRep (DivIntegralTerm i _ _) = (typeRep (Proxy @t), i) -identityWithTypeRep (ModIntegralTerm i _ _) = (typeRep (Proxy @t), i) -identityWithTypeRep (QuotIntegralTerm i _ _) = (typeRep (Proxy @t), i) -identityWithTypeRep (RemIntegralTerm i _ _) = (typeRep (Proxy @t), i) -identityWithTypeRep (DivBoundedIntegralTerm i _ _) = (typeRep (Proxy @t), i) -identityWithTypeRep (ModBoundedIntegralTerm i _ _) = (typeRep (Proxy @t), i) -identityWithTypeRep (QuotBoundedIntegralTerm i _ _) = (typeRep (Proxy @t), i) -identityWithTypeRep (RemBoundedIntegralTerm i _ _) = (typeRep (Proxy @t), i) -{-# INLINE identityWithTypeRep #-} - -introSupportedPrimConstraint :: forall t a. Term t -> ((SupportedPrim t) => a) -> a -introSupportedPrimConstraint ConTerm {} x = x -introSupportedPrimConstraint SymTerm {} x = x -introSupportedPrimConstraint UnaryTerm {} x = x -introSupportedPrimConstraint BinaryTerm {} x = x -introSupportedPrimConstraint TernaryTerm {} x = x -introSupportedPrimConstraint NotTerm {} x = x -introSupportedPrimConstraint OrTerm {} x = x -introSupportedPrimConstraint AndTerm {} x = x -introSupportedPrimConstraint EqvTerm {} x = x -introSupportedPrimConstraint ITETerm {} x = x -introSupportedPrimConstraint AddNumTerm {} x = x -introSupportedPrimConstraint UMinusNumTerm {} x = x -introSupportedPrimConstraint TimesNumTerm {} x = x -introSupportedPrimConstraint AbsNumTerm {} x = x -introSupportedPrimConstraint SignumNumTerm {} x = x -introSupportedPrimConstraint LTNumTerm {} x = x -introSupportedPrimConstraint LENumTerm {} x = x -introSupportedPrimConstraint AndBitsTerm {} x = x -introSupportedPrimConstraint OrBitsTerm {} x = x -introSupportedPrimConstraint XorBitsTerm {} x = x -introSupportedPrimConstraint ComplementBitsTerm {} x = x -introSupportedPrimConstraint ShiftLeftTerm {} x = x -introSupportedPrimConstraint RotateLeftTerm {} x = x -introSupportedPrimConstraint ShiftRightTerm {} x = x -introSupportedPrimConstraint RotateRightTerm {} x = x -introSupportedPrimConstraint ToSignedTerm {} x = x -introSupportedPrimConstraint ToUnsignedTerm {} x = x -introSupportedPrimConstraint BVConcatTerm {} x = x -introSupportedPrimConstraint BVSelectTerm {} x = x -introSupportedPrimConstraint BVExtendTerm {} x = x -introSupportedPrimConstraint TabularFunApplyTerm {} x = x -introSupportedPrimConstraint GeneralFunApplyTerm {} x = x -introSupportedPrimConstraint DivIntegralTerm {} x = x -introSupportedPrimConstraint ModIntegralTerm {} x = x -introSupportedPrimConstraint QuotIntegralTerm {} x = x -introSupportedPrimConstraint RemIntegralTerm {} x = x -introSupportedPrimConstraint DivBoundedIntegralTerm {} x = x -introSupportedPrimConstraint ModBoundedIntegralTerm {} x = x -introSupportedPrimConstraint QuotBoundedIntegralTerm {} x = x -introSupportedPrimConstraint RemBoundedIntegralTerm {} x = x -{-# INLINE introSupportedPrimConstraint #-} - -extractSymbolicsSomeTerm :: SomeTerm -> S.HashSet SomeTypedSymbol -extractSymbolicsSomeTerm t1 = evalState (gocached t1) M.empty - where - gocached :: SomeTerm -> State (M.HashMap SomeTerm (S.HashSet SomeTypedSymbol)) (S.HashSet SomeTypedSymbol) - gocached t = do - v <- gets (M.lookup t) - case v of - Just x -> return x - Nothing -> do - res <- go t - st <- get - put $ M.insert t res st - return res - go :: SomeTerm -> State (M.HashMap SomeTerm (S.HashSet SomeTypedSymbol)) (S.HashSet SomeTypedSymbol) - go (SomeTerm ConTerm {}) = return S.empty - go (SomeTerm (SymTerm _ (sym :: TypedSymbol a))) = return $ S.singleton $ SomeTypedSymbol (R.typeRep @a) sym - go (SomeTerm (UnaryTerm _ _ arg)) = goUnary arg - go (SomeTerm (BinaryTerm _ _ arg1 arg2)) = goBinary arg1 arg2 - go (SomeTerm (TernaryTerm _ _ arg1 arg2 arg3)) = goTernary arg1 arg2 arg3 - go (SomeTerm (NotTerm _ arg)) = goUnary arg - go (SomeTerm (OrTerm _ arg1 arg2)) = goBinary arg1 arg2 - go (SomeTerm (AndTerm _ arg1 arg2)) = goBinary arg1 arg2 - go (SomeTerm (EqvTerm _ arg1 arg2)) = goBinary arg1 arg2 - go (SomeTerm (ITETerm _ cond arg1 arg2)) = goTernary cond arg1 arg2 - go (SomeTerm (AddNumTerm _ arg1 arg2)) = goBinary arg1 arg2 - go (SomeTerm (UMinusNumTerm _ arg)) = goUnary arg - go (SomeTerm (TimesNumTerm _ arg1 arg2)) = goBinary arg1 arg2 - go (SomeTerm (AbsNumTerm _ arg)) = goUnary arg - go (SomeTerm (SignumNumTerm _ arg)) = goUnary arg - go (SomeTerm (LTNumTerm _ arg1 arg2)) = goBinary arg1 arg2 - go (SomeTerm (LENumTerm _ arg1 arg2)) = goBinary arg1 arg2 - go (SomeTerm (AndBitsTerm _ arg1 arg2)) = goBinary arg1 arg2 - go (SomeTerm (OrBitsTerm _ arg1 arg2)) = goBinary arg1 arg2 - go (SomeTerm (XorBitsTerm _ arg1 arg2)) = goBinary arg1 arg2 - go (SomeTerm (ComplementBitsTerm _ arg)) = goUnary arg - go (SomeTerm (ShiftLeftTerm _ arg n1)) = goBinary arg n1 - go (SomeTerm (ShiftRightTerm _ arg n1)) = goBinary arg n1 - go (SomeTerm (RotateLeftTerm _ arg n1)) = goBinary arg n1 - go (SomeTerm (RotateRightTerm _ arg n1)) = goBinary arg n1 - go (SomeTerm (ToSignedTerm _ arg)) = goUnary arg - go (SomeTerm (ToUnsignedTerm _ arg)) = goUnary arg - go (SomeTerm (BVConcatTerm _ arg1 arg2)) = goBinary arg1 arg2 - go (SomeTerm (BVSelectTerm _ _ _ arg)) = goUnary arg - go (SomeTerm (BVExtendTerm _ _ _ arg)) = goUnary arg - go (SomeTerm (TabularFunApplyTerm _ func arg)) = goBinary func arg - go (SomeTerm (GeneralFunApplyTerm _ func arg)) = goBinary func arg - go (SomeTerm (DivIntegralTerm _ arg1 arg2)) = goBinary arg1 arg2 - go (SomeTerm (ModIntegralTerm _ arg1 arg2)) = goBinary arg1 arg2 - go (SomeTerm (QuotIntegralTerm _ arg1 arg2)) = goBinary arg1 arg2 - go (SomeTerm (RemIntegralTerm _ arg1 arg2)) = goBinary arg1 arg2 - go (SomeTerm (DivBoundedIntegralTerm _ arg1 arg2)) = goBinary arg1 arg2 - go (SomeTerm (ModBoundedIntegralTerm _ arg1 arg2)) = goBinary arg1 arg2 - go (SomeTerm (QuotBoundedIntegralTerm _ arg1 arg2)) = goBinary arg1 arg2 - go (SomeTerm (RemBoundedIntegralTerm _ arg1 arg2)) = goBinary arg1 arg2 - goUnary arg = gocached (SomeTerm arg) - goBinary arg1 arg2 = do - r1 <- gocached (SomeTerm arg1) - r2 <- gocached (SomeTerm arg2) - return $ r1 <> r2 - goTernary arg1 arg2 arg3 = do - r1 <- gocached (SomeTerm arg1) - r2 <- gocached (SomeTerm arg2) - r3 <- gocached (SomeTerm arg3) - return $ r1 <> r2 <> r3 -{-# INLINEABLE extractSymbolicsSomeTerm #-} - -extractSymbolicsTerm :: (SupportedPrim a) => Term a -> S.HashSet SomeTypedSymbol -extractSymbolicsTerm t = extractSymbolicsSomeTerm (SomeTerm t) -{-# INLINE extractSymbolicsTerm #-} - -castTerm :: forall a b. (Typeable b) => Term a -> Maybe (Term b) -castTerm t@ConTerm {} = cast t -castTerm t@SymTerm {} = cast t -castTerm t@UnaryTerm {} = cast t -castTerm t@BinaryTerm {} = cast t -castTerm t@TernaryTerm {} = cast t -castTerm t@NotTerm {} = cast t -castTerm t@OrTerm {} = cast t -castTerm t@AndTerm {} = cast t -castTerm t@EqvTerm {} = cast t -castTerm t@ITETerm {} = cast t -castTerm t@AddNumTerm {} = cast t -castTerm t@UMinusNumTerm {} = cast t -castTerm t@TimesNumTerm {} = cast t -castTerm t@AbsNumTerm {} = cast t -castTerm t@SignumNumTerm {} = cast t -castTerm t@LTNumTerm {} = cast t -castTerm t@LENumTerm {} = cast t -castTerm t@AndBitsTerm {} = cast t -castTerm t@OrBitsTerm {} = cast t -castTerm t@XorBitsTerm {} = cast t -castTerm t@ComplementBitsTerm {} = cast t -castTerm t@ShiftLeftTerm {} = cast t -castTerm t@ShiftRightTerm {} = cast t -castTerm t@RotateLeftTerm {} = cast t -castTerm t@RotateRightTerm {} = cast t -castTerm t@ToSignedTerm {} = cast t -castTerm t@ToUnsignedTerm {} = cast t -castTerm t@BVConcatTerm {} = cast t -castTerm t@BVSelectTerm {} = cast t -castTerm t@BVExtendTerm {} = cast t -castTerm t@TabularFunApplyTerm {} = cast t -castTerm t@GeneralFunApplyTerm {} = cast t -castTerm t@DivIntegralTerm {} = cast t -castTerm t@ModIntegralTerm {} = cast t -castTerm t@QuotIntegralTerm {} = cast t -castTerm t@RemIntegralTerm {} = cast t -castTerm t@DivBoundedIntegralTerm {} = cast t -castTerm t@ModBoundedIntegralTerm {} = cast t -castTerm t@QuotBoundedIntegralTerm {} = cast t -castTerm t@RemBoundedIntegralTerm {} = cast t -{-# INLINE castTerm #-} - -pformat :: forall t. (SupportedPrim t) => Term t -> String -pformat (ConTerm _ t) = pformatCon t -pformat (SymTerm _ sym) = pformatSym sym -pformat (UnaryTerm _ tag arg1) = pformatUnary tag arg1 -pformat (BinaryTerm _ tag arg1 arg2) = pformatBinary tag arg1 arg2 -pformat (TernaryTerm _ tag arg1 arg2 arg3) = pformatTernary tag arg1 arg2 arg3 -pformat (NotTerm _ arg) = "(! " ++ pformat arg ++ ")" -pformat (OrTerm _ arg1 arg2) = "(|| " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" -pformat (AndTerm _ arg1 arg2) = "(&& " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" -pformat (EqvTerm _ arg1 arg2) = "(= " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" -pformat (ITETerm _ cond arg1 arg2) = "(ite " ++ pformat cond ++ " " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" -pformat (AddNumTerm _ arg1 arg2) = "(+ " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" -pformat (UMinusNumTerm _ arg) = "(- " ++ pformat arg ++ ")" -pformat (TimesNumTerm _ arg1 arg2) = "(* " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" -pformat (AbsNumTerm _ arg) = "(abs " ++ pformat arg ++ ")" -pformat (SignumNumTerm _ arg) = "(signum " ++ pformat arg ++ ")" -pformat (LTNumTerm _ arg1 arg2) = "(< " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" -pformat (LENumTerm _ arg1 arg2) = "(<= " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" -pformat (AndBitsTerm _ arg1 arg2) = "(& " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" -pformat (OrBitsTerm _ arg1 arg2) = "(| " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" -pformat (XorBitsTerm _ arg1 arg2) = "(^ " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" -pformat (ComplementBitsTerm _ arg) = "(~ " ++ pformat arg ++ ")" -pformat (ShiftLeftTerm _ arg n) = "(shl " ++ pformat arg ++ " " ++ pformat n ++ ")" -pformat (ShiftRightTerm _ arg n) = "(shr " ++ pformat arg ++ " " ++ pformat n ++ ")" -pformat (RotateLeftTerm _ arg n) = "(rotl " ++ pformat arg ++ " " ++ pformat n ++ ")" -pformat (RotateRightTerm _ arg n) = "(rotr " ++ pformat arg ++ " " ++ pformat n ++ ")" -pformat (ToSignedTerm _ arg) = "(u2s " ++ pformat arg ++ " " ++ ")" -pformat (ToUnsignedTerm _ arg) = "(s2u " ++ pformat arg ++ " " ++ ")" -pformat (BVConcatTerm _ arg1 arg2) = "(bvconcat " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" -pformat (BVSelectTerm _ ix w arg) = "(bvselect " ++ show ix ++ " " ++ show w ++ " " ++ pformat arg ++ ")" -pformat (BVExtendTerm _ signed n arg) = - (if signed then "(bvsext " else "(bvzext ") ++ show n ++ " " ++ pformat arg ++ ")" -pformat (TabularFunApplyTerm _ func arg) = "(apply " ++ pformat func ++ " " ++ pformat arg ++ ")" -pformat (GeneralFunApplyTerm _ func arg) = "(apply " ++ pformat func ++ " " ++ pformat arg ++ ")" -pformat (DivIntegralTerm _ arg1 arg2) = "(div " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" -pformat (ModIntegralTerm _ arg1 arg2) = "(mod " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" -pformat (QuotIntegralTerm _ arg1 arg2) = "(quot " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" -pformat (RemIntegralTerm _ arg1 arg2) = "(rem " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" -pformat (DivBoundedIntegralTerm _ arg1 arg2) = "(div " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" -pformat (ModBoundedIntegralTerm _ arg1 arg2) = "(mod " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" -pformat (QuotBoundedIntegralTerm _ arg1 arg2) = "(quot " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" -pformat (RemBoundedIntegralTerm _ arg1 arg2) = "(rem " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" -{-# INLINE pformat #-} - -someTermsSize :: [SomeTerm] -> Int -someTermsSize terms = S.size $ execState (traverse goSome terms) S.empty - where - exists t = gets (S.member (SomeTerm t)) - add t = modify' (S.insert (SomeTerm t)) - goSome :: SomeTerm -> State (S.HashSet SomeTerm) () - goSome (SomeTerm b) = go b - go :: forall b. Term b -> State (S.HashSet SomeTerm) () - go t@ConTerm {} = add t - go t@SymTerm {} = add t - go t@(UnaryTerm _ _ arg) = goUnary t arg - go t@(BinaryTerm _ _ arg1 arg2) = goBinary t arg1 arg2 - go t@(TernaryTerm _ _ arg1 arg2 arg3) = goTernary t arg1 arg2 arg3 - go t@(NotTerm _ arg) = goUnary t arg - go t@(OrTerm _ arg1 arg2) = goBinary t arg1 arg2 - go t@(AndTerm _ arg1 arg2) = goBinary t arg1 arg2 - go t@(EqvTerm _ arg1 arg2) = goBinary t arg1 arg2 - go t@(ITETerm _ cond arg1 arg2) = goTernary t cond arg1 arg2 - go t@(AddNumTerm _ arg1 arg2) = goBinary t arg1 arg2 - go t@(UMinusNumTerm _ arg) = goUnary t arg - go t@(TimesNumTerm _ arg1 arg2) = goBinary t arg1 arg2 - go t@(AbsNumTerm _ arg) = goUnary t arg - go t@(SignumNumTerm _ arg) = goUnary t arg - go t@(LTNumTerm _ arg1 arg2) = goBinary t arg1 arg2 - go t@(LENumTerm _ arg1 arg2) = goBinary t arg1 arg2 - go t@(AndBitsTerm _ arg1 arg2) = goBinary t arg1 arg2 - go t@(OrBitsTerm _ arg1 arg2) = goBinary t arg1 arg2 - go t@(XorBitsTerm _ arg1 arg2) = goBinary t arg1 arg2 - go t@(ComplementBitsTerm _ arg) = goUnary t arg - go t@(ShiftLeftTerm _ arg n) = goBinary t arg n - go t@(ShiftRightTerm _ arg n) = goBinary t arg n - go t@(RotateLeftTerm _ arg n) = goBinary t arg n - go t@(RotateRightTerm _ arg n) = goBinary t arg n - go t@(ToSignedTerm _ arg) = goUnary t arg - go t@(ToUnsignedTerm _ arg) = goUnary t arg - go t@(BVConcatTerm _ arg1 arg2) = goBinary t arg1 arg2 - go t@(BVSelectTerm _ _ _ arg) = goUnary t arg - go t@(BVExtendTerm _ _ _ arg) = goUnary t arg - go t@(TabularFunApplyTerm _ func arg) = goBinary t func arg - go t@(GeneralFunApplyTerm _ func arg) = goBinary t func arg - go t@(DivIntegralTerm _ arg1 arg2) = goBinary t arg1 arg2 - go t@(ModIntegralTerm _ arg1 arg2) = goBinary t arg1 arg2 - go t@(QuotIntegralTerm _ arg1 arg2) = goBinary t arg1 arg2 - go t@(RemIntegralTerm _ arg1 arg2) = goBinary t arg1 arg2 - go t@(DivBoundedIntegralTerm _ arg1 arg2) = goBinary t arg1 arg2 - go t@(ModBoundedIntegralTerm _ arg1 arg2) = goBinary t arg1 arg2 - go t@(QuotBoundedIntegralTerm _ arg1 arg2) = goBinary t arg1 arg2 - go t@(RemBoundedIntegralTerm _ arg1 arg2) = goBinary t arg1 arg2 - goUnary :: forall a b. (SupportedPrim a) => Term a -> Term b -> State (S.HashSet SomeTerm) () - goUnary t arg = do - b <- exists t - if b - then return () - else do - add t - go arg - goBinary :: - forall a b c. - (SupportedPrim a, SupportedPrim b) => - Term a -> - Term b -> - Term c -> - State (S.HashSet SomeTerm) () - goBinary t arg1 arg2 = do - b <- exists t - if b - then return () - else do - add t - go arg1 - go arg2 - goTernary :: - forall a b c d. - (SupportedPrim a, SupportedPrim b, SupportedPrim c) => - Term a -> - Term b -> - Term c -> - Term d -> - State (S.HashSet SomeTerm) () - goTernary t arg1 arg2 arg3 = do - b <- exists t - if b - then return () - else do - add t - go arg1 - go arg2 - go arg3 -{-# INLINEABLE someTermsSize #-} - -someTermSize :: SomeTerm -> Int -someTermSize term = someTermsSize [term] -{-# INLINE someTermSize #-} - -termsSize :: [Term a] -> Int -termsSize terms = someTermsSize $ (\x -> introSupportedPrimConstraint x $ SomeTerm x) <$> terms -{-# INLINEABLE termsSize #-} - -termSize :: Term a -> Int -termSize term = termsSize [term] -{-# INLINE termSize #-} diff --git a/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/TermUtils.hs-boot b/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/TermUtils.hs-boot deleted file mode 100644 --- a/src/Grisette/IR/SymPrim/Data/Prim/InternedTerm/TermUtils.hs-boot +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE RankNTypes #-} - -module Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermUtils - ( identity, - identityWithTypeRep, - introSupportedPrimConstraint, - extractSymbolicsTerm, - castTerm, - pformat, - termSize, - termsSize, - ) -where - -import qualified Data.HashSet as S -import Data.Interned (Id) -import Data.Typeable (TypeRep, Typeable) -import {-# SOURCE #-} Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term - ( SomeTypedSymbol, - SupportedPrim, - Term, - ) - -identity :: Term t -> Id -identityWithTypeRep :: forall t. Term t -> (TypeRep, Id) -introSupportedPrimConstraint :: forall t a. Term t -> ((SupportedPrim t) => a) -> a -extractSymbolicsTerm :: (SupportedPrim a) => Term a -> S.HashSet SomeTypedSymbol -castTerm :: forall a b. (Typeable b) => Term a -> Maybe (Term b) -pformat :: forall t. (SupportedPrim t) => Term t -> String -termsSize :: [Term a] -> Int -termSize :: Term a -> Int diff --git a/src/Grisette/IR/SymPrim/Data/Prim/Model.hs b/src/Grisette/IR/SymPrim/Data/Prim/Model.hs deleted file mode 100644 --- a/src/Grisette/IR/SymPrim/Data/Prim/Model.hs +++ /dev/null @@ -1,805 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} - --- | --- Module : Grisette.IR.SymPrim.Data.Prim.Model --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.IR.SymPrim.Data.Prim.Model - ( SymbolSet (..), - Model (..), - ModelValuePair (..), - equation, - evaluateTerm, - ) -where - -import qualified Data.HashMap.Strict as M -import qualified Data.HashSet as S -import Data.Hashable (Hashable) -import Data.List (sort, sortOn) -import Data.Proxy (Proxy (Proxy)) -import GHC.Generics (Generic) -import Grisette.Core.Data.Class.ModelOps - ( ModelOps - ( emptyModel, - exceptFor, - exceptFor', - extendTo, - insertValue, - isEmptyModel, - modelContains, - restrictTo, - valueOf - ), - ModelRep (buildModel), - SymbolSetOps - ( containsSymbol, - differenceSet, - emptySet, - insertSymbol, - intersectionSet, - isEmptySet, - unionSet - ), - SymbolSetRep (buildSymbolSet), - ) -import Grisette.Core.Data.MemoUtils (htmemo) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors - ( conTerm, - symTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.SomeTerm - ( SomeTerm (SomeTerm), - ) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term - ( BinaryOp (partialEvalBinary), - SomeTypedSymbol (SomeTypedSymbol), - SupportedPrim (defaultValue, defaultValueDynamic), - Term - ( AbsNumTerm, - AddNumTerm, - AndBitsTerm, - AndTerm, - BVConcatTerm, - BVExtendTerm, - BVSelectTerm, - BinaryTerm, - ComplementBitsTerm, - ConTerm, - DivBoundedIntegralTerm, - DivIntegralTerm, - EqvTerm, - GeneralFunApplyTerm, - ITETerm, - LENumTerm, - LTNumTerm, - ModBoundedIntegralTerm, - ModIntegralTerm, - NotTerm, - OrBitsTerm, - OrTerm, - QuotBoundedIntegralTerm, - QuotIntegralTerm, - RemBoundedIntegralTerm, - RemIntegralTerm, - RotateLeftTerm, - RotateRightTerm, - ShiftLeftTerm, - ShiftRightTerm, - SignumNumTerm, - SymTerm, - TabularFunApplyTerm, - TernaryTerm, - TimesNumTerm, - ToSignedTerm, - ToUnsignedTerm, - UMinusNumTerm, - UnaryTerm, - XorBitsTerm - ), - TernaryOp (partialEvalTernary), - TypedSymbol, - UnaryOp (partialEvalUnary), - showUntyped, - someTypedSymbol, - withSymbolSupported, - type (-->) (GeneralFun), - ) -import Grisette.IR.SymPrim.Data.Prim.ModelValue - ( ModelValue, - toModelValue, - unsafeFromModelValue, - ) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.BV - ( pevalBVConcatTerm, - pevalBVExtendTerm, - pevalBVSelectTerm, - pevalToSignedTerm, - pevalToUnsignedTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bits - ( pevalAndBitsTerm, - pevalComplementBitsTerm, - pevalOrBitsTerm, - pevalRotateLeftTerm, - pevalRotateRightTerm, - pevalShiftLeftTerm, - pevalShiftRightTerm, - pevalXorBitsTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool - ( pevalAndTerm, - pevalEqvTerm, - pevalITETerm, - pevalNotTerm, - pevalOrTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.GeneralFun - ( pevalGeneralFunApplyTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.Integral - ( pevalDivBoundedIntegralTerm, - pevalDivIntegralTerm, - pevalModBoundedIntegralTerm, - pevalModIntegralTerm, - pevalQuotBoundedIntegralTerm, - pevalQuotIntegralTerm, - pevalRemBoundedIntegralTerm, - pevalRemIntegralTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.Num - ( pevalAbsNumTerm, - pevalAddNumTerm, - pevalLeNumTerm, - pevalLtNumTerm, - pevalSignumNumTerm, - pevalTimesNumTerm, - pevalUMinusNumTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.TabularFun - ( pevalTabularFunApplyTerm, - ) -import Type.Reflection - ( TypeRep, - eqTypeRep, - typeRep, - pattern App, - type (:~~:) (HRefl), - ) -import Unsafe.Coerce (unsafeCoerce) - --- $setup --- >>> import Grisette.Core --- >>> import Grisette.IR.SymPrim --- >>> :set -XFlexibleContexts - --- | Symbolic constant set. -newtype SymbolSet = SymbolSet {unSymbolSet :: S.HashSet SomeTypedSymbol} - deriving (Eq, Generic, Hashable, Semigroup, Monoid) - -instance Show SymbolSet where - showsPrec prec (SymbolSet s) = showParen (prec >= 10) $ \x -> - "SymbolSet {" - ++ go0 (sort $ show <$> S.toList s) - ++ "}" - ++ x - where - go0 [] = "" - go0 [x] = x - go0 (x : xs) = x ++ ", " ++ go0 xs - --- | Model returned by the solver. -newtype Model = Model {unModel :: M.HashMap SomeTypedSymbol ModelValue} deriving (Eq, Generic, Hashable, Semigroup, Monoid) - -instance Show Model where - showsPrec prec (Model m) = showParen (prec >= 10) $ \x -> - "Model {" - ++ go0 (sortOn (\(x, _) -> show x) $ M.toList m) - ++ "}" - ++ x - where - go0 [] = "" - go0 [(SomeTypedSymbol _ s, v)] = showUntyped s ++ " -> " ++ show v - go0 ((SomeTypedSymbol _ s, v) : xs) = showUntyped s ++ " -> " ++ show v ++ ", " ++ go0 xs - -equation :: TypedSymbol a -> Model -> Maybe (Term Bool) -equation tsym m = withSymbolSupported tsym $ - case valueOf tsym m of - Just v -> Just $ pevalEqvTerm (symTerm tsym) (conTerm v) - Nothing -> Nothing - -instance SymbolSetOps SymbolSet TypedSymbol where - emptySet = SymbolSet S.empty - isEmptySet (SymbolSet s) = S.null s - containsSymbol s = - S.member (someTypedSymbol s) . unSymbolSet - insertSymbol s = SymbolSet . S.insert (someTypedSymbol s) . unSymbolSet - intersectionSet (SymbolSet s1) (SymbolSet s2) = SymbolSet $ S.intersection s1 s2 - unionSet (SymbolSet s1) (SymbolSet s2) = SymbolSet $ S.union s1 s2 - differenceSet (SymbolSet s1) (SymbolSet s2) = SymbolSet $ S.difference s1 s2 - -instance SymbolSetRep (TypedSymbol t) SymbolSet TypedSymbol where - buildSymbolSet sym = insertSymbol sym emptySet - -instance - SymbolSetRep - ( TypedSymbol a, - TypedSymbol b - ) - SymbolSet - TypedSymbol - where - buildSymbolSet (sym1, sym2) = - insertSymbol sym2 - . insertSymbol sym1 - $ emptySet - -instance - SymbolSetRep - ( TypedSymbol a, - TypedSymbol b, - TypedSymbol c - ) - SymbolSet - TypedSymbol - where - buildSymbolSet (sym1, sym2, sym3) = - insertSymbol sym3 - . insertSymbol sym2 - . insertSymbol sym1 - $ emptySet - -instance - SymbolSetRep - ( TypedSymbol a, - TypedSymbol b, - TypedSymbol c, - TypedSymbol d - ) - SymbolSet - TypedSymbol - where - buildSymbolSet (sym1, sym2, sym3, sym4) = - insertSymbol sym4 - . insertSymbol sym3 - . insertSymbol sym2 - . insertSymbol sym1 - $ emptySet - -instance - SymbolSetRep - ( TypedSymbol a, - TypedSymbol b, - TypedSymbol c, - TypedSymbol d, - TypedSymbol e - ) - SymbolSet - TypedSymbol - where - buildSymbolSet (sym1, sym2, sym3, sym4, sym5) = - insertSymbol sym5 - . insertSymbol sym4 - . insertSymbol sym3 - . insertSymbol sym2 - . insertSymbol sym1 - $ emptySet - -instance - SymbolSetRep - ( TypedSymbol a, - TypedSymbol b, - TypedSymbol c, - TypedSymbol d, - TypedSymbol e, - TypedSymbol f - ) - SymbolSet - TypedSymbol - where - buildSymbolSet (sym1, sym2, sym3, sym4, sym5, sym6) = - insertSymbol sym6 - . insertSymbol sym5 - . insertSymbol sym4 - . insertSymbol sym3 - . insertSymbol sym2 - . insertSymbol sym1 - $ emptySet - -instance - SymbolSetRep - ( TypedSymbol a, - TypedSymbol b, - TypedSymbol c, - TypedSymbol d, - TypedSymbol e, - TypedSymbol f, - TypedSymbol g - ) - SymbolSet - TypedSymbol - where - buildSymbolSet (sym1, sym2, sym3, sym4, sym5, sym6, sym7) = - insertSymbol sym7 - . insertSymbol sym6 - . insertSymbol sym5 - . insertSymbol sym4 - . insertSymbol sym3 - . insertSymbol sym2 - . insertSymbol sym1 - $ emptySet - -instance - SymbolSetRep - ( TypedSymbol a, - TypedSymbol b, - TypedSymbol c, - TypedSymbol d, - TypedSymbol e, - TypedSymbol f, - TypedSymbol g, - TypedSymbol h - ) - SymbolSet - TypedSymbol - where - buildSymbolSet (sym1, sym2, sym3, sym4, sym5, sym6, sym7, sym8) = - insertSymbol sym8 - . insertSymbol sym7 - . insertSymbol sym6 - . insertSymbol sym5 - . insertSymbol sym4 - . insertSymbol sym3 - . insertSymbol sym2 - . insertSymbol sym1 - $ emptySet - -instance ModelOps Model SymbolSet TypedSymbol where - emptyModel = Model M.empty - isEmptyModel (Model m) = M.null m - valueOf :: forall t. TypedSymbol t -> Model -> Maybe t - valueOf sym (Model m) = - withSymbolSupported sym $ - (unsafeFromModelValue @t) - <$> M.lookup (someTypedSymbol sym) m - modelContains sym (Model m) = M.member (someTypedSymbol sym) m - exceptFor (SymbolSet s) (Model m) = Model $ S.foldl' (flip M.delete) m s - exceptFor' s (Model m) = Model $ M.delete (someTypedSymbol s) m - restrictTo (SymbolSet s) (Model m) = - Model $ - S.foldl' - ( \acc sym -> case M.lookup sym m of - Just v -> M.insert sym v acc - Nothing -> acc - ) - M.empty - s - extendTo (SymbolSet s) (Model m) = - Model $ - S.foldl' - ( \acc sym@(SomeTypedSymbol _ (tsym :: TypedSymbol t)) -> case M.lookup sym acc of - Just _ -> acc - Nothing -> withSymbolSupported tsym $ M.insert sym (defaultValueDynamic (Proxy @t)) acc - ) - m - s - insertValue sym (v :: t) (Model m) = - withSymbolSupported sym $ - Model $ - M.insert (someTypedSymbol sym) (toModelValue v) m - -evaluateSomeTerm :: Bool -> Model -> SomeTerm -> SomeTerm -evaluateSomeTerm fillDefault m@(Model ma) = gomemo - where - gomemo = htmemo go - gotyped :: (SupportedPrim a) => Term a -> Term a - gotyped a = case gomemo (SomeTerm a) of - SomeTerm v -> unsafeCoerce v - go c@(SomeTerm (ConTerm _ cv :: Term v)) = - case (typeRep :: TypeRep v) of - App (App gf _) _ -> - case eqTypeRep gf (typeRep @(-->)) of - Just HRefl -> case cv of - GeneralFun sym tm -> - if modelContains sym m -- someTypedSymbol sym1 == someTypedSymbol sym - then case evaluateSomeTerm fillDefault (exceptFor' sym m) (SomeTerm tm) of - SomeTerm tm' -> SomeTerm $ conTerm $ GeneralFun sym tm' -- stm - else SomeTerm $ conTerm $ GeneralFun sym (gotyped tm) - Nothing -> c - _ -> c - go c@(SomeTerm ((SymTerm _ sym) :: Term a)) = - case M.lookup (someTypedSymbol sym) ma of - Nothing -> if fillDefault then SomeTerm $ conTerm (defaultValue @a) else c - Just dy -> SomeTerm $ conTerm (unsafeFromModelValue @a dy) - go (SomeTerm (UnaryTerm _ tag (arg :: Term a))) = goUnary (partialEvalUnary tag) arg - go (SomeTerm (BinaryTerm _ tag (arg1 :: Term a1) (arg2 :: Term a2))) = - goBinary (partialEvalBinary tag) arg1 arg2 - go (SomeTerm (TernaryTerm _ tag (arg1 :: Term a1) (arg2 :: Term a2) (arg3 :: Term a3))) = do - goTernary (partialEvalTernary tag) arg1 arg2 arg3 - go (SomeTerm (NotTerm _ arg)) = goUnary pevalNotTerm arg - go (SomeTerm (OrTerm _ arg1 arg2)) = - goBinary pevalOrTerm arg1 arg2 - go (SomeTerm (AndTerm _ arg1 arg2)) = - goBinary pevalAndTerm arg1 arg2 - go (SomeTerm (EqvTerm _ arg1 arg2)) = - goBinary pevalEqvTerm arg1 arg2 - go (SomeTerm (ITETerm _ cond arg1 arg2)) = - goTernary pevalITETerm cond arg1 arg2 - go (SomeTerm (AddNumTerm _ arg1 arg2)) = - goBinary pevalAddNumTerm arg1 arg2 - go (SomeTerm (UMinusNumTerm _ arg)) = goUnary pevalUMinusNumTerm arg - go (SomeTerm (TimesNumTerm _ arg1 arg2)) = - goBinary pevalTimesNumTerm arg1 arg2 - go (SomeTerm (AbsNumTerm _ arg)) = goUnary pevalAbsNumTerm arg - go (SomeTerm (SignumNumTerm _ arg)) = goUnary pevalSignumNumTerm arg - go (SomeTerm (LTNumTerm _ arg1 arg2)) = - goBinary pevalLtNumTerm arg1 arg2 - go (SomeTerm (LENumTerm _ arg1 arg2)) = - goBinary pevalLeNumTerm arg1 arg2 - go (SomeTerm (AndBitsTerm _ arg1 arg2)) = - goBinary pevalAndBitsTerm arg1 arg2 - go (SomeTerm (OrBitsTerm _ arg1 arg2)) = - goBinary pevalOrBitsTerm arg1 arg2 - go (SomeTerm (XorBitsTerm _ arg1 arg2)) = - goBinary pevalXorBitsTerm arg1 arg2 - go (SomeTerm (ComplementBitsTerm _ arg)) = goUnary pevalComplementBitsTerm arg - go (SomeTerm (ShiftLeftTerm _ arg n)) = goBinary pevalShiftLeftTerm arg n - go (SomeTerm (RotateLeftTerm _ arg n)) = goBinary pevalRotateLeftTerm arg n - go (SomeTerm (ShiftRightTerm _ arg n)) = goBinary pevalShiftRightTerm arg n - go (SomeTerm (RotateRightTerm _ arg n)) = goBinary pevalRotateRightTerm arg n - go (SomeTerm (ToSignedTerm _ arg)) = - goUnary pevalToSignedTerm arg - go (SomeTerm (ToUnsignedTerm _ arg)) = - goUnary pevalToUnsignedTerm arg - go (SomeTerm (BVConcatTerm _ arg1 arg2)) = - goBinary pevalBVConcatTerm arg1 arg2 - go (SomeTerm (BVSelectTerm _ ix w arg)) = - goUnary (pevalBVSelectTerm ix w) arg - go (SomeTerm (BVExtendTerm _ n signed arg)) = - goUnary (pevalBVExtendTerm n signed) arg - go (SomeTerm (TabularFunApplyTerm _ f arg)) = - goBinary pevalTabularFunApplyTerm f arg - go (SomeTerm (GeneralFunApplyTerm _ f arg)) = - goBinary pevalGeneralFunApplyTerm f arg - go (SomeTerm (DivIntegralTerm _ arg1 arg2)) = - goBinary pevalDivIntegralTerm arg1 arg2 - go (SomeTerm (ModIntegralTerm _ arg1 arg2)) = - goBinary pevalModIntegralTerm arg1 arg2 - go (SomeTerm (QuotIntegralTerm _ arg1 arg2)) = - goBinary pevalQuotIntegralTerm arg1 arg2 - go (SomeTerm (RemIntegralTerm _ arg1 arg2)) = - goBinary pevalRemIntegralTerm arg1 arg2 - go (SomeTerm (DivBoundedIntegralTerm _ arg1 arg2)) = - goBinary pevalDivBoundedIntegralTerm arg1 arg2 - go (SomeTerm (ModBoundedIntegralTerm _ arg1 arg2)) = - goBinary pevalModBoundedIntegralTerm arg1 arg2 - go (SomeTerm (QuotBoundedIntegralTerm _ arg1 arg2)) = - goBinary pevalQuotBoundedIntegralTerm arg1 arg2 - go (SomeTerm (RemBoundedIntegralTerm _ arg1 arg2)) = - goBinary pevalRemBoundedIntegralTerm arg1 arg2 - goUnary :: (SupportedPrim a, SupportedPrim b) => (Term a -> Term b) -> Term a -> SomeTerm - goUnary f a = SomeTerm $ f (gotyped a) - goBinary :: - (SupportedPrim a, SupportedPrim b, SupportedPrim c) => - (Term a -> Term b -> Term c) -> - Term a -> - Term b -> - SomeTerm - goBinary f a b = SomeTerm $ f (gotyped a) (gotyped b) - goTernary :: - (SupportedPrim a, SupportedPrim b, SupportedPrim c, SupportedPrim d) => - (Term a -> Term b -> Term c -> Term d) -> - Term a -> - Term b -> - Term c -> - SomeTerm - goTernary f a b c = SomeTerm $ f (gotyped a) (gotyped b) (gotyped c) - -evaluateTerm :: forall a. (SupportedPrim a) => Bool -> Model -> Term a -> Term a -evaluateTerm fillDefault m t = case evaluateSomeTerm fillDefault m $ SomeTerm t of - SomeTerm (t1 :: Term b) -> unsafeCoerce @(Term b) @(Term a) t1 - --- | --- A type used for building a model by hand. --- --- >>> buildModel ("x" ::= (1 :: Integer), "y" ::= True) :: Model --- Model {x -> 1 :: Integer, y -> True :: Bool} -data ModelValuePair t = (TypedSymbol t) ::= t deriving (Show) - -instance ModelRep (ModelValuePair t) Model where - buildModel (sym ::= val) = insertValue sym val emptyModel - -instance (ModelRep a Model, ModelRep b Model) => ModelRep (a, b) Model where - buildModel (a, b) = buildModel a <> buildModel b - -instance - ( ModelRep a Model, - ModelRep b Model, - ModelRep c Model - ) => - ModelRep (a, b, c) Model - where - buildModel (a, b, c) = buildModel a <> buildModel b <> buildModel c - -instance - ( ModelRep a Model, - ModelRep b Model, - ModelRep c Model, - ModelRep d Model - ) => - ModelRep (a, b, c, d) Model - where - buildModel (a, b, c, d) = - buildModel a <> buildModel b <> buildModel c <> buildModel d - -instance - ( ModelRep a Model, - ModelRep b Model, - ModelRep c Model, - ModelRep d Model, - ModelRep e Model - ) => - ModelRep (a, b, c, d, e) Model - where - buildModel (a, b, c, d, e) = - buildModel a <> buildModel b <> buildModel c <> buildModel d <> buildModel e - -instance - ( ModelRep a Model, - ModelRep b Model, - ModelRep c Model, - ModelRep d Model, - ModelRep e Model, - ModelRep f Model - ) => - ModelRep (a, b, c, d, e, f) Model - where - buildModel (a, b, c, d, e, f) = - buildModel a - <> buildModel b - <> buildModel c - <> buildModel d - <> buildModel e - <> buildModel f - -instance - ( ModelRep a Model, - ModelRep b Model, - ModelRep c Model, - ModelRep d Model, - ModelRep e Model, - ModelRep f Model, - ModelRep g Model - ) => - ModelRep (a, b, c, d, e, f, g) Model - where - buildModel (a, b, c, d, e, f, g) = - buildModel a - <> buildModel b - <> buildModel c - <> buildModel d - <> buildModel e - <> buildModel f - <> buildModel g - -instance - ( ModelRep a Model, - ModelRep b Model, - ModelRep c Model, - ModelRep d Model, - ModelRep e Model, - ModelRep f Model, - ModelRep g Model, - ModelRep h Model - ) => - ModelRep (a, b, c, d, e, f, g, h) Model - where - buildModel (a, b, c, d, e, f, g, h) = - buildModel a - <> buildModel b - <> buildModel c - <> buildModel d - <> buildModel e - <> buildModel f - <> buildModel g - <> buildModel h - -{- -instance - ModelRep - ( ModelValuePair a, - ModelValuePair b - ) - Model - SymbolSet - TypedSymbol - where - buildModel - ( sym1 ::= val1, - sym2 ::= val2 - ) = - insertValue sym2 val2 - . insertValue sym1 val1 - $ emptyModel - -instance - ModelRep - ( ModelValuePair a, - ModelValuePair b, - ModelValuePair c - ) - Model - SymbolSet - TypedSymbol - where - buildModel - ( sym1 ::= val1, - sym2 ::= val2, - sym3 ::= val3 - ) = - insertValue sym3 val3 - . insertValue sym2 val2 - . insertValue sym1 val1 - $ emptyModel - -instance - ModelRep - ( ModelValuePair a, - ModelValuePair b, - ModelValuePair c, - ModelValuePair d - ) - Model - SymbolSet - TypedSymbol - where - buildModel - ( sym1 ::= val1, - sym2 ::= val2, - sym3 ::= val3, - sym4 ::= val4 - ) = - insertValue sym4 val4 - . insertValue sym3 val3 - . insertValue sym2 val2 - . insertValue sym1 val1 - $ emptyModel - -instance - ModelRep - ( ModelValuePair a, - ModelValuePair b, - ModelValuePair c, - ModelValuePair d, - ModelValuePair e - ) - Model - SymbolSet - TypedSymbol - where - buildModel - ( sym1 ::= val1, - sym2 ::= val2, - sym3 ::= val3, - sym4 ::= val4, - sym5 ::= val5 - ) = - insertValue sym5 val5 - . insertValue sym4 val4 - . insertValue sym3 val3 - . insertValue sym2 val2 - . insertValue sym1 val1 - $ emptyModel - -instance - ModelRep - ( ModelValuePair a, - ModelValuePair b, - ModelValuePair c, - ModelValuePair d, - ModelValuePair e, - ModelValuePair f - ) - Model - SymbolSet - TypedSymbol - where - buildModel - ( sym1 ::= val1, - sym2 ::= val2, - sym3 ::= val3, - sym4 ::= val4, - sym5 ::= val5, - sym6 ::= val6 - ) = - insertValue sym6 val6 - . insertValue sym5 val5 - . insertValue sym4 val4 - . insertValue sym3 val3 - . insertValue sym2 val2 - . insertValue sym1 val1 - $ emptyModel - -instance - ModelRep - ( ModelValuePair a, - ModelValuePair b, - ModelValuePair c, - ModelValuePair d, - ModelValuePair e, - ModelValuePair f, - ModelValuePair g - ) - Model - SymbolSet - TypedSymbol - where - buildModel - ( sym1 ::= val1, - sym2 ::= val2, - sym3 ::= val3, - sym4 ::= val4, - sym5 ::= val5, - sym6 ::= val6, - sym7 ::= val7 - ) = - insertValue sym7 val7 - . insertValue sym6 val6 - . insertValue sym5 val5 - . insertValue sym4 val4 - . insertValue sym3 val3 - . insertValue sym2 val2 - . insertValue sym1 val1 - $ emptyModel - -instance - ModelRep - ( ModelValuePair a, - ModelValuePair b, - ModelValuePair c, - ModelValuePair d, - ModelValuePair e, - ModelValuePair f, - ModelValuePair g, - ModelValuePair h - ) - Model - SymbolSet - TypedSymbol - where - buildModel - ( sym1 ::= val1, - sym2 ::= val2, - sym3 ::= val3, - sym4 ::= val4, - sym5 ::= val5, - sym6 ::= val6, - sym7 ::= val7, - sym8 ::= val8 - ) = - insertValue sym8 val8 - . insertValue sym7 val7 - . insertValue sym6 val6 - . insertValue sym5 val5 - . insertValue sym4 val4 - . insertValue sym3 val3 - . insertValue sym2 val2 - . insertValue sym1 val1 - $ emptyModel - --} diff --git a/src/Grisette/IR/SymPrim/Data/Prim/ModelValue.hs b/src/Grisette/IR/SymPrim/Data/Prim/ModelValue.hs deleted file mode 100644 --- a/src/Grisette/IR/SymPrim/Data/Prim/ModelValue.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# LANGUAGE ExplicitNamespaces #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - --- | --- Module : Grisette.IR.SymPrim.Data.Prim.ModelValue --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.IR.SymPrim.Data.Prim.ModelValue - ( ModelValue (..), - toModelValue, - unsafeFromModelValue, - ) -where - -import Data.Hashable (Hashable (hashWithSalt)) -import Type.Reflection - ( TypeRep, - Typeable, - eqTypeRep, - typeRep, - type (:~~:) (HRefl), - ) - -data ModelValue where - ModelValue :: forall v. (Show v, Eq v, Hashable v) => TypeRep v -> v -> ModelValue - -instance Show ModelValue where - show (ModelValue t v) = show v ++ " :: " ++ show t - -instance Eq ModelValue where - (ModelValue t1 v1) == (ModelValue t2 v2) = - case eqTypeRep t1 t2 of - Just HRefl -> v1 == v2 - _ -> False - -instance Hashable ModelValue where - s `hashWithSalt` (ModelValue t v) = s `hashWithSalt` t `hashWithSalt` v - -unsafeFromModelValue :: forall a. (Typeable a) => ModelValue -> a -unsafeFromModelValue (ModelValue t v) = case eqTypeRep t (typeRep @a) of - Just HRefl -> v - _ -> error $ "Bad model value type, expected type: " ++ show (typeRep @a) ++ ", but got: " ++ show t - -toModelValue :: forall a. (Show a, Eq a, Hashable a, Typeable a) => a -> ModelValue -toModelValue = ModelValue (typeRep @a) diff --git a/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/BV.hs b/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/BV.hs deleted file mode 100644 --- a/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/BV.hs +++ /dev/null @@ -1,237 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- Module : Grisette.IR.SymPrim.Data.Prim.PartialEval.BV --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.IR.SymPrim.Data.Prim.PartialEval.BV - ( pevalToSignedTerm, - pevalToUnsignedTerm, - pevalBVConcatTerm, - pevalBVSelectTerm, - pevalBVExtendTerm, - pevalBVZeroExtendTerm, - pevalBVSignExtendTerm, - ) -where - -import Data.Typeable (Typeable) -import GHC.TypeNats (KnownNat, type (+), type (<=)) -import Grisette.Core.Data.Class.BitVector - ( SizedBV (sizedBVConcat, sizedBVSelect, sizedBVSext, sizedBVZext), - ) -import Grisette.Core.Data.Class.SignConversion (SignConversion (toSigned, toUnsigned)) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors - ( bvconcatTerm, - bvextendTerm, - bvselectTerm, - conTerm, - toSignedTerm, - toUnsignedTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term - ( SupportedPrim, - Term (ConTerm, ToSignedTerm, ToUnsignedTerm), - ) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermUtils - ( castTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.Unfold - ( binaryUnfoldOnce, - unaryUnfoldOnce, - ) - --- ToSigned -pevalToSignedTerm :: - ( SupportedPrim u, - SupportedPrim s, - SignConversion u s - ) => - Term u -> - Term s -pevalToSignedTerm = unaryUnfoldOnce doPevalToSignedTerm toSignedTerm - -doPevalToSignedTerm :: - ( SupportedPrim u, - SupportedPrim s, - SignConversion u s - ) => - Term u -> - Maybe (Term s) -doPevalToSignedTerm (ConTerm _ b) = Just $ conTerm $ toSigned b -doPevalToSignedTerm (ToUnsignedTerm _ b) = Just b >>= castTerm -doPevalToSignedTerm _ = Nothing - --- ToUnsigned -pevalToUnsignedTerm :: - ( SupportedPrim u, - SupportedPrim s, - SignConversion u s - ) => - Term s -> - Term u -pevalToUnsignedTerm = unaryUnfoldOnce doPevalToUnsignedTerm toUnsignedTerm - -doPevalToUnsignedTerm :: - ( SupportedPrim u, - SupportedPrim s, - SignConversion u s - ) => - Term s -> - Maybe (Term u) -doPevalToUnsignedTerm (ConTerm _ b) = Just $ conTerm $ toUnsigned b -doPevalToUnsignedTerm (ToSignedTerm _ b) = Just b >>= castTerm -doPevalToUnsignedTerm _ = Nothing - --- select -pevalBVSelectTerm :: - forall bv n ix w p q. - ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n), - Typeable bv, - KnownNat n, - KnownNat ix, - KnownNat w, - 1 <= n, - 1 <= w, - ix + w <= n, - SizedBV bv - ) => - p ix -> - q w -> - Term (bv n) -> - Term (bv w) -pevalBVSelectTerm ix w = unaryUnfoldOnce (doPevalBVSelectTerm ix w) (bvselectTerm ix w) - -doPevalBVSelectTerm :: - forall bv n ix w p q. - ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n), - Typeable bv, - KnownNat n, - KnownNat ix, - KnownNat w, - 1 <= n, - 1 <= w, - ix + w <= n, - SizedBV bv - ) => - p ix -> - q w -> - Term (bv n) -> - Maybe (Term (bv w)) -doPevalBVSelectTerm ix w (ConTerm _ b) = Just $ conTerm $ sizedBVSelect ix w b -doPevalBVSelectTerm _ _ _ = Nothing - --- ext -pevalBVZeroExtendTerm :: - forall proxy l r bv. - ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n), - Typeable bv, - KnownNat l, - KnownNat r, - 1 <= l, - 1 <= r, - l <= r, - SizedBV bv - ) => - proxy r -> - Term (bv l) -> - Term (bv r) -pevalBVZeroExtendTerm = pevalBVExtendTerm False - -pevalBVSignExtendTerm :: - forall proxy l r bv. - ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n), - Typeable bv, - KnownNat l, - KnownNat r, - 1 <= l, - 1 <= r, - l <= r, - SizedBV bv - ) => - proxy r -> - Term (bv l) -> - Term (bv r) -pevalBVSignExtendTerm = pevalBVExtendTerm True - -pevalBVExtendTerm :: - forall proxy l r bv. - ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n), - Typeable bv, - KnownNat l, - KnownNat r, - 1 <= l, - 1 <= r, - l <= r, - SizedBV bv - ) => - Bool -> - proxy r -> - Term (bv l) -> - Term (bv r) -pevalBVExtendTerm signed p = unaryUnfoldOnce (doPevalBVExtendTerm signed p) (bvextendTerm signed p) - -doPevalBVExtendTerm :: - forall proxy l r bv. - ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n), - Typeable bv, - KnownNat l, - KnownNat r, - 1 <= l, - 1 <= r, - l <= r, - SizedBV bv - ) => - Bool -> - proxy r -> - Term (bv l) -> - Maybe (Term (bv r)) -doPevalBVExtendTerm signed p (ConTerm _ b) = Just $ conTerm $ if signed then sizedBVSext p b else sizedBVZext p b -doPevalBVExtendTerm _ _ _ = Nothing - -pevalBVConcatTerm :: - ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n), - Typeable bv, - KnownNat a, - KnownNat b, - KnownNat (a + b), - 1 <= a, - 1 <= b, - 1 <= a + b, - SizedBV bv - ) => - Term (bv a) -> - Term (bv b) -> - Term (bv (a + b)) -pevalBVConcatTerm = binaryUnfoldOnce doPevalBVConcatTerm bvconcatTerm - -doPevalBVConcatTerm :: - ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n), - Typeable bv, - KnownNat a, - KnownNat b, - KnownNat (a + b), - 1 <= a, - 1 <= b, - 1 <= (a + b), - SizedBV bv - ) => - Term (bv a) -> - Term (bv b) -> - Maybe (Term (bv (a + b))) -doPevalBVConcatTerm (ConTerm _ v) (ConTerm _ v') = Just $ conTerm $ sizedBVConcat v v' -doPevalBVConcatTerm _ _ = Nothing diff --git a/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/Bits.hs b/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/Bits.hs deleted file mode 100644 --- a/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/Bits.hs +++ /dev/null @@ -1,209 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ViewPatterns #-} - --- | --- Module : Grisette.IR.SymPrim.Data.Prim.PartialEval.Bits --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.IR.SymPrim.Data.Prim.PartialEval.Bits - ( pattern BitsConTerm, - pevalAndBitsTerm, - pevalOrBitsTerm, - pevalXorBitsTerm, - pevalComplementBitsTerm, - pevalShiftLeftTerm, - pevalShiftRightTerm, - pevalRotateLeftTerm, - pevalRotateRightTerm, - ) -where - -import Data.Bits - ( Bits - ( complement, - isSigned, - rotateR, - shiftR, - xor, - zeroBits, - (.&.), - (.|.) - ), - FiniteBits (finiteBitSize), - ) -import Data.Typeable (Typeable, cast) -import Grisette.Core.Data.Class.SymRotate (SymRotate (symRotate)) -import Grisette.Core.Data.Class.SymShift (SymShift (symShift)) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors - ( andBitsTerm, - complementBitsTerm, - conTerm, - orBitsTerm, - rotateLeftTerm, - rotateRightTerm, - shiftLeftTerm, - shiftRightTerm, - xorBitsTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term - ( SupportedPrim, - Term - ( ComplementBitsTerm, - ConTerm - ), - ) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.Unfold - ( binaryUnfoldOnce, - unaryUnfoldOnce, - ) - -bitsConTermView :: (Bits b, Typeable b) => Term a -> Maybe b -bitsConTermView (ConTerm _ b) = cast b -bitsConTermView _ = Nothing - -pattern BitsConTerm :: forall b a. (Bits b, Typeable b) => b -> Term a -pattern BitsConTerm b <- (bitsConTermView -> Just b) - --- bitand -pevalAndBitsTerm :: forall a. (Bits a, SupportedPrim a) => Term a -> Term a -> Term a -pevalAndBitsTerm = binaryUnfoldOnce doPevalAndBitsTerm andBitsTerm - -doPevalAndBitsTerm :: forall a. (Bits a, SupportedPrim a) => Term a -> Term a -> Maybe (Term a) -doPevalAndBitsTerm (ConTerm _ a) (ConTerm _ b) = Just $ conTerm (a .&. b) -doPevalAndBitsTerm (ConTerm _ a) b - | a == zeroBits = Just $ conTerm zeroBits - | a == complement zeroBits = Just b -doPevalAndBitsTerm a (ConTerm _ b) - | b == zeroBits = Just $ conTerm zeroBits - | b == complement zeroBits = Just a -doPevalAndBitsTerm a b | a == b = Just a -doPevalAndBitsTerm _ _ = Nothing - --- bitor -pevalOrBitsTerm :: forall a. (Bits a, SupportedPrim a) => Term a -> Term a -> Term a -pevalOrBitsTerm = binaryUnfoldOnce doPevalOrBitsTerm orBitsTerm - -doPevalOrBitsTerm :: forall a. (Bits a, SupportedPrim a) => Term a -> Term a -> Maybe (Term a) -doPevalOrBitsTerm (ConTerm _ a) (ConTerm _ b) = Just $ conTerm (a .|. b) -doPevalOrBitsTerm (ConTerm _ a) b - | a == zeroBits = Just b - | a == complement zeroBits = Just $ conTerm $ complement zeroBits -doPevalOrBitsTerm a (ConTerm _ b) - | b == zeroBits = Just a - | b == complement zeroBits = Just $ conTerm $ complement zeroBits -doPevalOrBitsTerm a b | a == b = Just a -doPevalOrBitsTerm _ _ = Nothing - --- bitxor -pevalXorBitsTerm :: forall a. (Bits a, SupportedPrim a) => Term a -> Term a -> Term a -pevalXorBitsTerm = binaryUnfoldOnce doPevalXorBitsTerm xorBitsTerm - -doPevalXorBitsTerm :: forall a. (Bits a, SupportedPrim a) => Term a -> Term a -> Maybe (Term a) -doPevalXorBitsTerm (ConTerm _ a) (ConTerm _ b) = Just $ conTerm (a `xor` b) -doPevalXorBitsTerm (ConTerm _ a) b - | a == zeroBits = Just b - | a == complement zeroBits = Just $ pevalComplementBitsTerm b -doPevalXorBitsTerm a (ConTerm _ b) - | b == zeroBits = Just a - | b == complement zeroBits = Just $ pevalComplementBitsTerm a -doPevalXorBitsTerm a b | a == b = Just $ conTerm zeroBits -doPevalXorBitsTerm (ComplementBitsTerm _ i) (ComplementBitsTerm _ j) = Just $ pevalXorBitsTerm i j -doPevalXorBitsTerm (ComplementBitsTerm _ i) j = Just $ pevalComplementBitsTerm $ pevalXorBitsTerm i j -doPevalXorBitsTerm i (ComplementBitsTerm _ j) = Just $ pevalComplementBitsTerm $ pevalXorBitsTerm i j -doPevalXorBitsTerm _ _ = Nothing - --- complement -pevalComplementBitsTerm :: forall a. (Bits a, SupportedPrim a) => Term a -> Term a -pevalComplementBitsTerm = unaryUnfoldOnce doPevalComplementBitsTerm complementBitsTerm - -doPevalComplementBitsTerm :: forall a. (Bits a, SupportedPrim a) => Term a -> Maybe (Term a) -doPevalComplementBitsTerm (ConTerm _ a) = Just $ conTerm $ complement a -doPevalComplementBitsTerm (ComplementBitsTerm _ a) = Just a -doPevalComplementBitsTerm _ = Nothing - --- shift -pevalShiftLeftTerm :: forall a. (Integral a, SymShift a, FiniteBits a, SupportedPrim a) => Term a -> Term a -> Term a -pevalShiftLeftTerm t n = unaryUnfoldOnce (`doPevalShiftLeftTerm` n) (`shiftLeftTerm` n) t - -doPevalShiftLeftTerm :: forall a. (Integral a, SymShift a, FiniteBits a, SupportedPrim a) => Term a -> Term a -> Maybe (Term a) -doPevalShiftLeftTerm (ConTerm _ a) (ConTerm _ n) - | n >= 0 = - if (fromIntegral n :: Integer) >= fromIntegral (finiteBitSize n) - then Just $ conTerm zeroBits - else Just $ conTerm $ symShift a n -doPevalShiftLeftTerm x (ConTerm _ 0) = Just x --- TODO: Need to handle the overflow case. --- doPevalShiftLeftTerm (ShiftLeftTerm _ x (ConTerm _ n)) (ConTerm _ n1) --- | n >= 0 && n1 >= 0 = Just $ pevalShiftLeftTerm x (conTerm $ n + n1) -doPevalShiftLeftTerm _ (ConTerm _ n) - | n >= 0 && (fromIntegral n :: Integer) >= fromIntegral (finiteBitSize n) = - Just $ conTerm zeroBits -doPevalShiftLeftTerm _ _ = Nothing - -pevalShiftRightTerm :: forall a. (Integral a, SymShift a, FiniteBits a, SupportedPrim a) => Term a -> Term a -> Term a -pevalShiftRightTerm t n = unaryUnfoldOnce (`doPevalShiftRightTerm` n) (`shiftRightTerm` n) t - -doPevalShiftRightTerm :: forall a. (Integral a, SymShift a, FiniteBits a, SupportedPrim a) => Term a -> Term a -> Maybe (Term a) -doPevalShiftRightTerm (ConTerm _ a) (ConTerm _ n) - | n >= 0 && not (isSigned a) = - if (fromIntegral n :: Integer) >= fromIntegral (finiteBitSize n) - then Just $ conTerm zeroBits - else Just $ conTerm $ shiftR a (fromIntegral n) -doPevalShiftRightTerm (ConTerm _ a) (ConTerm _ n) - | n >= 0 = Just $ conTerm $ symShift a (-n) -- if n >= 0 then -n must be in the range -doPevalShiftRightTerm x (ConTerm _ 0) = Just x --- doPevalShiftRightTerm (ShiftRightTerm _ x (ConTerm _ n)) (ConTerm _ n1) --- | n >= 0 && n1 >= 0 = Just $ pevalShiftRightTerm x (conTerm $ n + n1) -doPevalShiftRightTerm _ (ConTerm _ n) - | not (isSigned n) - && (fromIntegral n :: Integer) >= fromIntegral (finiteBitSize n) = - Just $ conTerm zeroBits -doPevalShiftRightTerm _ _ = Nothing - -pevalRotateLeftTerm :: forall a. (Integral a, SymRotate a, FiniteBits a, SupportedPrim a) => Term a -> Term a -> Term a -pevalRotateLeftTerm t n = unaryUnfoldOnce (`doPevalRotateLeftTerm` n) (`rotateLeftTerm` n) t - -doPevalRotateLeftTerm :: forall a. (Integral a, SymRotate a, FiniteBits a, SupportedPrim a) => Term a -> Term a -> Maybe (Term a) -doPevalRotateLeftTerm (ConTerm _ a) (ConTerm _ n) - | n >= 0 = Just $ conTerm $ symRotate a n -- Just $ conTerm $ rotateL a (fromIntegral n) -doPevalRotateLeftTerm x (ConTerm _ 0) = Just x --- doPevalRotateLeftTerm (RotateLeftTerm _ x (ConTerm _ n)) (ConTerm _ n1) --- | n >= 0 && n1 >= 0 = Just $ pevalRotateLeftTerm x (conTerm $ n + n1) -doPevalRotateLeftTerm x (ConTerm _ n) - | n >= 0 && (fromIntegral n :: Integer) >= fromIntegral bs = - Just $ pevalRotateLeftTerm x (conTerm $ n `mod` fromIntegral bs) - where - bs = finiteBitSize n -doPevalRotateLeftTerm _ _ = Nothing - -pevalRotateRightTerm :: forall a. (Integral a, SymRotate a, FiniteBits a, SupportedPrim a) => Term a -> Term a -> Term a -pevalRotateRightTerm t n = unaryUnfoldOnce (`doPevalRotateRightTerm` n) (`rotateRightTerm` n) t - -doPevalRotateRightTerm :: forall a. (Integral a, SymRotate a, FiniteBits a, SupportedPrim a) => Term a -> Term a -> Maybe (Term a) -doPevalRotateRightTerm (ConTerm _ a) (ConTerm _ n) - | n >= 0 = - Just . conTerm $ - rotateR - a - ( fromIntegral $ - (fromIntegral n :: Integer) - `mod` fromIntegral (finiteBitSize n) - ) -doPevalRotateRightTerm x (ConTerm _ 0) = Just x --- doPevalRotateRightTerm (RotateRightTerm _ x (ConTerm _ n)) (ConTerm _ n1) --- | n >= 0 && n1 >= 0 = Just $ pevalRotateRightTerm x (conTerm $ n + n1) -doPevalRotateRightTerm x (ConTerm _ n) - | n >= 0 && (fromIntegral n :: Integer) >= fromIntegral bs = - Just $ pevalRotateRightTerm x (conTerm $ n `mod` fromIntegral bs) - where - bs = finiteBitSize n -doPevalRotateRightTerm _ _ = Nothing diff --git a/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/Bool.hs b/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/Bool.hs deleted file mode 100644 --- a/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/Bool.hs +++ /dev/null @@ -1,453 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ExplicitNamespaces #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} - --- | --- Module : Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool - ( trueTerm, - falseTerm, - pattern BoolConTerm, - pattern TrueTerm, - pattern FalseTerm, - pattern BoolTerm, - pevalNotTerm, - pevalEqvTerm, - pevalNotEqvTerm, - pevalOrTerm, - pevalAndTerm, - pevalITETerm, - pevalImplyTerm, - pevalXorTerm, - ) -where - -import Control.Monad (msum) -import Data.Maybe (fromMaybe) -import Data.Typeable (cast, eqT, type (:~:) (Refl)) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors - ( andTerm, - conTerm, - eqvTerm, - iteTerm, - notTerm, - orTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term - ( SupportedPrim, - Term - ( AddNumTerm, - AndTerm, - ConTerm, - EqvTerm, - ITETerm, - NotTerm, - OrTerm - ), - ) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermUtils - ( castTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.Utils (pattern Dyn) -import Unsafe.Coerce (unsafeCoerce) - -trueTerm :: Term Bool -trueTerm = conTerm True -{-# INLINE trueTerm #-} - -falseTerm :: Term Bool -falseTerm = conTerm False -{-# INLINE falseTerm #-} - -boolConTermView :: forall a. Term a -> Maybe Bool -boolConTermView (ConTerm _ b) = cast b -boolConTermView _ = Nothing -{-# INLINE boolConTermView #-} - -pattern BoolConTerm :: Bool -> Term a -pattern BoolConTerm b <- (boolConTermView -> Just b) - -pattern TrueTerm :: Term a -pattern TrueTerm <- BoolConTerm True - -pattern FalseTerm :: Term a -pattern FalseTerm <- BoolConTerm False - -pattern BoolTerm :: Term Bool -> Term a -pattern BoolTerm b <- (castTerm -> Just b) - --- Not -pevalNotTerm :: Term Bool -> Term Bool -pevalNotTerm (NotTerm _ tm) = tm -pevalNotTerm (ConTerm _ a) = if a then falseTerm else trueTerm -pevalNotTerm (OrTerm _ (NotTerm _ n1) n2) = pevalAndTerm n1 (pevalNotTerm n2) -pevalNotTerm (OrTerm _ n1 (NotTerm _ n2)) = pevalAndTerm (pevalNotTerm n1) n2 -pevalNotTerm (AndTerm _ (NotTerm _ n1) n2) = pevalOrTerm n1 (pevalNotTerm n2) -pevalNotTerm (AndTerm _ n1 (NotTerm _ n2)) = pevalOrTerm (pevalNotTerm n1) n2 -pevalNotTerm tm = notTerm tm -{-# INLINEABLE pevalNotTerm #-} - --- Eqv -pevalEqvTerm :: forall a. (SupportedPrim a) => Term a -> Term a -> Term Bool -pevalEqvTerm l@ConTerm {} r@ConTerm {} = conTerm $ l == r -pevalEqvTerm l@ConTerm {} r = pevalEqvTerm r l -pevalEqvTerm l (BoolConTerm rv) = if rv then unsafeCoerce l else pevalNotTerm $ unsafeCoerce l -pevalEqvTerm (NotTerm _ lv) r - | lv == unsafeCoerce r = falseTerm -pevalEqvTerm l (NotTerm _ rv) - | unsafeCoerce l == rv = falseTerm -{- -pevalBinary _ (ConTerm l) (ConTerm r) = - if l == r then trueTerm else falseTerm - -} -pevalEqvTerm - ( AddNumTerm - _ - (ConTerm _ c :: Term a) - (Dyn (v :: Term a)) - ) - (Dyn (ConTerm _ c2 :: Term a)) = - pevalEqvTerm v (conTerm $ c2 - c) -pevalEqvTerm - (Dyn (ConTerm _ c2 :: Term a)) - ( AddNumTerm - _ - (Dyn (ConTerm _ c :: Term a)) - (Dyn (v :: Term a)) - ) = - pevalEqvTerm v (conTerm $ c2 - c) -pevalEqvTerm l (ITETerm _ c t f) - | l == t = pevalOrTerm c (pevalEqvTerm l f) - | l == f = pevalOrTerm (pevalNotTerm c) (pevalEqvTerm l t) -pevalEqvTerm (ITETerm _ c t f) r - | t == r = pevalOrTerm c (pevalEqvTerm f r) - | f == r = pevalOrTerm (pevalNotTerm c) (pevalEqvTerm t r) -pevalEqvTerm l r - | l == r = trueTerm - | otherwise = eqvTerm l r -{-# INLINEABLE pevalEqvTerm #-} - -pevalNotEqvTerm :: (SupportedPrim a) => Term a -> Term a -> Term Bool -pevalNotEqvTerm l r = pevalNotTerm $ pevalEqvTerm l r -{-# INLINE pevalNotEqvTerm #-} - -pevalImpliesTerm :: Term Bool -> Term Bool -> Bool -pevalImpliesTerm (ConTerm _ False) _ = True -pevalImpliesTerm _ (ConTerm _ True) = True -pevalImpliesTerm - (EqvTerm _ (e1 :: Term a) (ec1@(ConTerm _ _) :: Term b)) - (NotTerm _ (EqvTerm _ (Dyn (e2 :: Term a)) (Dyn (ec2@(ConTerm _ _) :: Term b)))) - | e1 == e2 && ec1 /= ec2 = True -pevalImpliesTerm a b - | a == b = True - | otherwise = False -{-# INLINE pevalImpliesTerm #-} - -orEqFirst :: Term Bool -> Term Bool -> Bool -orEqFirst _ (ConTerm _ False) = True -orEqFirst - (NotTerm _ (EqvTerm _ (e1 :: Term a) (ec1@(ConTerm _ _) :: Term b))) - (EqvTerm _ (Dyn (e2 :: Term a)) (Dyn (ec2@(ConTerm _ _) :: Term b))) - | e1 == e2 && ec1 /= ec2 = True -orEqFirst x y - | x == y = True - | otherwise = False -{-# INLINE orEqFirst #-} - -orEqTrue :: Term Bool -> Term Bool -> Bool -orEqTrue (ConTerm _ True) _ = True -orEqTrue _ (ConTerm _ True) = True --- orEqTrue (NotTerm _ e1) (NotTerm _ e2) = andEqFalse e1 e2 -orEqTrue - (NotTerm _ (EqvTerm _ (e1 :: Term a) (ec1@(ConTerm _ _) :: Term b))) - (NotTerm _ (EqvTerm _ (Dyn (e2 :: Term a)) (Dyn (ec2@(ConTerm _ _) :: Term b)))) - | e1 == e2 && ec1 /= ec2 = True -orEqTrue (NotTerm _ l) r | l == r = True -orEqTrue l (NotTerm _ r) | l == r = True -orEqTrue _ _ = False -{-# INLINE orEqTrue #-} - -andEqFirst :: Term Bool -> Term Bool -> Bool -andEqFirst _ (ConTerm _ True) = True --- andEqFirst x (NotTerm _ y) = andEqFalse x y -andEqFirst - (EqvTerm _ (e1 :: Term a) (ec1@(ConTerm _ _) :: Term b)) - (NotTerm _ (EqvTerm _ (Dyn (e2 :: Term a)) (Dyn (ec2@(ConTerm _ _) :: Term b)))) - | e1 == e2 && ec1 /= ec2 = True -andEqFirst x y - | x == y = True - | otherwise = False -{-# INLINE andEqFirst #-} - -andEqFalse :: Term Bool -> Term Bool -> Bool -andEqFalse (ConTerm _ False) _ = True -andEqFalse _ (ConTerm _ False) = True --- andEqFalse (NotTerm _ e1) (NotTerm _ e2) = orEqTrue e1 e2 -andEqFalse - (EqvTerm _ (e1 :: Term a) (ec1@(ConTerm _ _) :: Term b)) - (EqvTerm _ (Dyn (e2 :: Term a)) (Dyn (ec2@(ConTerm _ _) :: Term b))) - | e1 == e2 && ec1 /= ec2 = True -andEqFalse (NotTerm _ x) y | x == y = True -andEqFalse x (NotTerm _ y) | x == y = True -andEqFalse _ _ = False -{-# INLINE andEqFalse #-} - --- Or -pevalOrTerm :: Term Bool -> Term Bool -> Term Bool -pevalOrTerm l r - | orEqTrue l r = trueTerm - | orEqFirst l r = l - | orEqFirst r l = r -pevalOrTerm l r@(OrTerm _ r1 r2) - | orEqTrue l r1 = trueTerm - | orEqTrue l r2 = trueTerm - | orEqFirst r1 l = r - | orEqFirst r2 l = r - | orEqFirst l r1 = pevalOrTerm l r2 - | orEqFirst l r2 = pevalOrTerm l r1 -pevalOrTerm l@(OrTerm _ l1 l2) r - | orEqTrue l1 r = trueTerm - | orEqTrue l2 r = trueTerm - | orEqFirst l1 r = l - | orEqFirst l2 r = l - | orEqFirst r l1 = pevalOrTerm l2 r - | orEqFirst r l2 = pevalOrTerm l1 r -pevalOrTerm l (AndTerm _ r1 r2) - | orEqFirst l r1 = l - | orEqFirst l r2 = l - | orEqTrue l r1 = pevalOrTerm l r2 - | orEqTrue l r2 = pevalOrTerm l r1 -pevalOrTerm (AndTerm _ l1 l2) r - | orEqFirst r l1 = r - | orEqFirst r l2 = r - | orEqTrue l1 r = pevalOrTerm l2 r - | orEqTrue l2 r = pevalOrTerm l1 r -pevalOrTerm (NotTerm _ nl) (NotTerm _ nr) = pevalNotTerm $ pevalAndTerm nl nr -pevalOrTerm l r = orTerm l r -{-# INLINEABLE pevalOrTerm #-} - -pevalAndTerm :: Term Bool -> Term Bool -> Term Bool -pevalAndTerm l r - | andEqFalse l r = falseTerm - | andEqFirst l r = l - | andEqFirst r l = r -pevalAndTerm l r@(AndTerm _ r1 r2) - | andEqFalse l r1 = falseTerm - | andEqFalse l r2 = falseTerm - | andEqFirst r1 l = r - | andEqFirst r2 l = r - | andEqFirst l r1 = pevalAndTerm l r2 - | andEqFirst l r2 = pevalAndTerm l r1 -pevalAndTerm l@(AndTerm _ l1 l2) r - | andEqFalse l1 r = falseTerm - | andEqFalse l2 r = falseTerm - | andEqFirst l1 r = l - | andEqFirst l2 r = l - | andEqFirst r l1 = pevalAndTerm l2 r - | andEqFirst r l2 = pevalAndTerm l1 r -pevalAndTerm l (OrTerm _ r1 r2) - | andEqFirst l r1 = l - | andEqFirst l r2 = l - | andEqFalse l r1 = pevalAndTerm l r2 - | andEqFalse l r2 = pevalAndTerm l r1 -pevalAndTerm (OrTerm _ l1 l2) r - | andEqFirst r l1 = r - | andEqFirst r l2 = r - | andEqFalse l1 r = pevalAndTerm l2 r - | andEqFalse l2 r = pevalAndTerm l1 r -pevalAndTerm (NotTerm _ nl) (NotTerm _ nr) = pevalNotTerm $ pevalOrTerm nl nr -pevalAndTerm l r = andTerm l r -{-# INLINEABLE pevalAndTerm #-} - -pevalITEBoolLeftNot :: Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) -pevalITEBoolLeftNot cond nIfTrue ifFalse - | cond == nIfTrue = Just $ pevalAndTerm (pevalNotTerm cond) ifFalse -- need test - | otherwise = case nIfTrue of - AndTerm _ nt1 nt2 -> ra - where - ra - | pevalImpliesTerm cond nt1 = Just $ pevalITETerm cond (pevalNotTerm nt2) ifFalse - | pevalImpliesTerm cond nt2 = Just $ pevalITETerm cond (pevalNotTerm nt1) ifFalse - | pevalImpliesTerm cond (pevalNotTerm nt1) || pevalImpliesTerm cond (pevalNotTerm nt2) = - Just $ pevalOrTerm cond ifFalse - | otherwise = Nothing - OrTerm _ nt1 nt2 -> ra - where - ra - | pevalImpliesTerm cond nt1 || pevalImpliesTerm cond nt2 = Just $ pevalAndTerm (pevalNotTerm cond) ifFalse - | pevalImpliesTerm cond (pevalNotTerm nt1) = Just $ pevalITETerm cond (pevalNotTerm nt2) ifFalse - | pevalImpliesTerm cond (pevalNotTerm nt2) = Just $ pevalITETerm cond (pevalNotTerm nt1) ifFalse - | otherwise = Nothing - _ -> Nothing - -pevalITEBoolBothNot :: Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) -pevalITEBoolBothNot cond nIfTrue nIfFalse = Just $ pevalNotTerm $ pevalITETerm cond nIfTrue nIfFalse - -pevalITEBoolRightNot :: Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) -pevalITEBoolRightNot cond ifTrue nIfFalse - | cond == nIfFalse = Just $ pevalOrTerm (pevalNotTerm cond) ifTrue -- need test - | otherwise = Nothing -- need work - -pevalInferImplies :: Term Bool -> Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) -pevalInferImplies cond (NotTerm _ nt1) trueRes falseRes - | cond == nt1 = Just falseRes - | otherwise = case (cond, nt1) of - ( EqvTerm _ (e1 :: Term a) (ec1@(ConTerm _ _) :: Term b), - EqvTerm _ (Dyn (e2 :: Term a)) (Dyn (ec2@(ConTerm _ _) :: Term b)) - ) - | e1 == e2 && ec1 /= ec2 -> Just trueRes - _ -> Nothing -pevalInferImplies - (EqvTerm _ (e1 :: Term a) (ec1@(ConTerm _ _) :: Term b)) - (EqvTerm _ (Dyn (e2 :: Term a)) (Dyn (ec2@(ConTerm _ _) :: Term b))) - _ - falseRes - | e1 == e2 && ec1 /= ec2 = Just falseRes -pevalInferImplies _ _ _ _ = Nothing - -pevalITEBoolLeftAnd :: Term Bool -> Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) -pevalITEBoolLeftAnd cond t1 t2 ifFalse - | t1 == ifFalse = Just $ pevalAndTerm t1 $ pevalImplyTerm cond t2 - | t2 == ifFalse = Just $ pevalAndTerm t2 $ pevalImplyTerm cond t1 - | cond == t1 = Just $ pevalITETerm cond t2 ifFalse - | cond == t2 = Just $ pevalITETerm cond t1 ifFalse - | otherwise = - msum - [ pevalInferImplies cond t1 (pevalITETerm cond t2 ifFalse) (pevalAndTerm (pevalNotTerm cond) ifFalse), - pevalInferImplies cond t2 (pevalITETerm cond t1 ifFalse) (pevalAndTerm (pevalNotTerm cond) ifFalse) - ] - -pevalITEBoolBothAnd :: Term Bool -> Term Bool -> Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) -pevalITEBoolBothAnd cond t1 t2 f1 f2 - | t1 == f1 = Just $ pevalAndTerm t1 $ pevalITETerm cond t2 f2 - | t1 == f2 = Just $ pevalAndTerm t1 $ pevalITETerm cond t2 f1 - | t2 == f1 = Just $ pevalAndTerm t2 $ pevalITETerm cond t1 f2 - | t2 == f2 = Just $ pevalAndTerm t2 $ pevalITETerm cond t1 f1 - | otherwise = Nothing - -pevalITEBoolRightAnd :: Term Bool -> Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) -pevalITEBoolRightAnd cond ifTrue f1 f2 - | f1 == ifTrue = Just $ pevalAndTerm f1 $ pevalOrTerm cond f2 - | f2 == ifTrue = Just $ pevalAndTerm f2 $ pevalOrTerm cond f1 - | otherwise = Nothing - -pevalITEBoolLeftOr :: Term Bool -> Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) -pevalITEBoolLeftOr cond t1 t2 ifFalse - | t1 == ifFalse = Just $ pevalOrTerm t1 $ pevalAndTerm cond t2 - | t2 == ifFalse = Just $ pevalOrTerm t2 $ pevalAndTerm cond t1 - | cond == t1 = Just $ pevalOrTerm cond ifFalse - | cond == t2 = Just $ pevalOrTerm cond ifFalse - | otherwise = - msum - [ pevalInferImplies cond t1 (pevalOrTerm cond ifFalse) (pevalITETerm cond t2 ifFalse), - pevalInferImplies cond t2 (pevalOrTerm cond ifFalse) (pevalITETerm cond t1 ifFalse) - ] - -pevalITEBoolBothOr :: Term Bool -> Term Bool -> Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) -pevalITEBoolBothOr cond t1 t2 f1 f2 - | t1 == f1 = Just $ pevalOrTerm t1 $ pevalITETerm cond t2 f2 - | t1 == f2 = Just $ pevalOrTerm t1 $ pevalITETerm cond t2 f1 - | t2 == f1 = Just $ pevalOrTerm t2 $ pevalITETerm cond t1 f2 - | t2 == f2 = Just $ pevalOrTerm t2 $ pevalITETerm cond t1 f1 - | otherwise = Nothing - -pevalITEBoolRightOr :: Term Bool -> Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) -pevalITEBoolRightOr cond ifTrue f1 f2 - | f1 == ifTrue = Just $ pevalOrTerm f1 $ pevalAndTerm (pevalNotTerm cond) f2 - | f2 == ifTrue = Just $ pevalOrTerm f2 $ pevalAndTerm (pevalNotTerm cond) f1 - | otherwise = Nothing - -pevalITEBoolLeft :: Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) -pevalITEBoolLeft cond (AndTerm _ t1 t2) ifFalse = - msum - [ pevalITEBoolLeftAnd cond t1 t2 ifFalse, - case ifFalse of - AndTerm _ f1 f2 -> pevalITEBoolBothAnd cond t1 t2 f1 f2 - _ -> Nothing - ] -pevalITEBoolLeft cond (OrTerm _ t1 t2) ifFalse = - msum - [ pevalITEBoolLeftOr cond t1 t2 ifFalse, - case ifFalse of - OrTerm _ f1 f2 -> pevalITEBoolBothOr cond t1 t2 f1 f2 - _ -> Nothing - ] -pevalITEBoolLeft cond (NotTerm _ nIfTrue) ifFalse = - msum - [ pevalITEBoolLeftNot cond nIfTrue ifFalse, - case ifFalse of - NotTerm _ nIfFalse -> - pevalITEBoolBothNot cond nIfTrue nIfFalse - _ -> Nothing - ] -pevalITEBoolLeft _ _ _ = Nothing - -pevalITEBoolNoLeft :: Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) -pevalITEBoolNoLeft cond ifTrue (AndTerm _ f1 f2) = pevalITEBoolRightAnd cond ifTrue f1 f2 -pevalITEBoolNoLeft cond ifTrue (OrTerm _ f1 f2) = pevalITEBoolRightOr cond ifTrue f1 f2 -pevalITEBoolNoLeft cond ifTrue (NotTerm _ nIfFalse) = pevalITEBoolRightNot cond ifTrue nIfFalse -pevalITEBoolNoLeft _ _ _ = Nothing - -pevalITEBasic :: (SupportedPrim a) => Term Bool -> Term a -> Term a -> Maybe (Term a) -pevalITEBasic (ConTerm _ True) ifTrue _ = Just ifTrue -pevalITEBasic (ConTerm _ False) _ ifFalse = Just ifFalse -pevalITEBasic (NotTerm _ ncond) ifTrue ifFalse = Just $ pevalITETerm ncond ifFalse ifTrue -pevalITEBasic _ ifTrue ifFalse | ifTrue == ifFalse = Just ifTrue -pevalITEBasic (ITETerm _ cc ct cf) (ITETerm _ tc tt tf) (ITETerm _ fc ft ff) -- later - | cc == tc && cc == fc = Just $ pevalITETerm cc (pevalITETerm ct tt ft) (pevalITETerm cf tf ff) -pevalITEBasic cond (ITETerm _ tc tt tf) ifFalse -- later - | cond == tc = Just $ pevalITETerm cond tt ifFalse - | tt == ifFalse = Just $ pevalITETerm (pevalOrTerm (pevalNotTerm cond) tc) tt tf - | tf == ifFalse = Just $ pevalITETerm (pevalAndTerm cond tc) tt tf -pevalITEBasic cond ifTrue (ITETerm _ fc ft ff) -- later - | ifTrue == ft = Just $ pevalITETerm (pevalOrTerm cond fc) ifTrue ff - | ifTrue == ff = Just $ pevalITETerm (pevalOrTerm cond (pevalNotTerm fc)) ifTrue ft - | pevalImpliesTerm fc cond = Just $ pevalITETerm cond ifTrue ff -pevalITEBasic _ _ _ = Nothing - -pevalITEBoolBasic :: Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) -pevalITEBoolBasic cond ifTrue ifFalse - | cond == ifTrue = Just $ pevalOrTerm cond ifFalse - | cond == ifFalse = Just $ pevalAndTerm cond ifTrue -pevalITEBoolBasic cond (ConTerm _ v) ifFalse - | v = Just $ pevalOrTerm cond ifFalse - | otherwise = Just $ pevalAndTerm (pevalNotTerm cond) ifFalse -pevalITEBoolBasic cond ifTrue (ConTerm _ v) - | v = Just $ pevalOrTerm (pevalNotTerm cond) ifTrue - | otherwise = Just $ pevalAndTerm cond ifTrue -pevalITEBoolBasic _ _ _ = Nothing - -pevalITEBool :: Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) -pevalITEBool cond ifTrue ifFalse = - msum - [ pevalITEBasic cond ifTrue ifFalse, - pevalITEBoolBasic cond ifTrue ifFalse, - pevalITEBoolLeft cond ifTrue ifFalse, - pevalITEBoolNoLeft cond ifTrue ifFalse - ] - -pevalITETerm :: forall a. (SupportedPrim a) => Term Bool -> Term a -> Term a -> Term a -pevalITETerm cond ifTrue ifFalse = fromMaybe (iteTerm cond ifTrue ifFalse) $ - case eqT @a @Bool of - Nothing -> pevalITEBasic cond ifTrue ifFalse - Just Refl -> pevalITEBool cond ifTrue ifFalse - -pevalImplyTerm :: Term Bool -> Term Bool -> Term Bool -pevalImplyTerm l = pevalOrTerm (pevalNotTerm l) - -pevalXorTerm :: Term Bool -> Term Bool -> Term Bool -pevalXorTerm l r = pevalOrTerm (pevalAndTerm (pevalNotTerm l) r) (pevalAndTerm l (pevalNotTerm r)) diff --git a/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/GeneralFun.hs b/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/GeneralFun.hs deleted file mode 100644 --- a/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/GeneralFun.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeOperators #-} - --- | --- Module : Grisette.IR.SymPrim.Data.Prim.PartialEval.GeneralFun --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.IR.SymPrim.Data.Prim.PartialEval.GeneralFun - ( pevalGeneralFunApplyTerm, - ) -where - -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors - ( generalFunApplyTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term - ( SupportedPrim, - Term (ConTerm, ITETerm), - type (-->) (GeneralFun), - ) -import {-# SOURCE #-} Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermSubstitution - ( substTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool (pevalITETerm) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.PartialEval - ( totalize2, - ) - -pevalGeneralFunApplyTerm :: (SupportedPrim a, SupportedPrim b) => Term (a --> b) -> Term a -> Term b -pevalGeneralFunApplyTerm = totalize2 doPevalGeneralFunApplyTerm generalFunApplyTerm - -doPevalGeneralFunApplyTerm :: (SupportedPrim a, SupportedPrim b) => Term (a --> b) -> Term a -> Maybe (Term b) -doPevalGeneralFunApplyTerm (ConTerm _ (GeneralFun arg tm)) v = Just $ substTerm arg v tm -doPevalGeneralFunApplyTerm (ITETerm _ c l r) v = - return $ pevalITETerm c (pevalGeneralFunApplyTerm l v) (pevalGeneralFunApplyTerm r v) -doPevalGeneralFunApplyTerm _ _ = Nothing diff --git a/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/Integral.hs b/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/Integral.hs deleted file mode 100644 --- a/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/Integral.hs +++ /dev/null @@ -1,98 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - --- | --- Module : Grisette.IR.SymPrim.Data.Prim.PartialEval.Integral --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.IR.SymPrim.Data.Prim.PartialEval.Integral - ( pevalDivIntegralTerm, - pevalModIntegralTerm, - pevalQuotIntegralTerm, - pevalRemIntegralTerm, - pevalDivBoundedIntegralTerm, - pevalModBoundedIntegralTerm, - pevalQuotBoundedIntegralTerm, - pevalRemBoundedIntegralTerm, - ) -where - -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors - ( conTerm, - divBoundedIntegralTerm, - divIntegralTerm, - modIntegralTerm, - quotBoundedIntegralTerm, - quotIntegralTerm, - remIntegralTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term - ( SupportedPrim, - Term (ConTerm), - ) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.Unfold - ( binaryUnfoldOnce, - ) - --- div -pevalDivIntegralTerm :: (SupportedPrim a, Integral a) => Term a -> Term a -> Term a -pevalDivIntegralTerm = binaryUnfoldOnce doPevalDivIntegralTerm divIntegralTerm - -doPevalDivIntegralTerm :: (SupportedPrim a, Integral a) => Term a -> Term a -> Maybe (Term a) -doPevalDivIntegralTerm (ConTerm _ a) (ConTerm _ b) | b /= 0 = Just $ conTerm $ a `div` b -doPevalDivIntegralTerm a (ConTerm _ 1) = Just a -doPevalDivIntegralTerm _ _ = Nothing - -pevalDivBoundedIntegralTerm :: (SupportedPrim a, Bounded a, Integral a) => Term a -> Term a -> Term a -pevalDivBoundedIntegralTerm = binaryUnfoldOnce doPevalDivBoundedIntegralTerm divBoundedIntegralTerm - -doPevalDivBoundedIntegralTerm :: (SupportedPrim a, Bounded a, Integral a) => Term a -> Term a -> Maybe (Term a) -doPevalDivBoundedIntegralTerm (ConTerm _ a) (ConTerm _ b) | b /= 0 && (b /= -1 || a /= minBound) = Just $ conTerm $ a `div` b -doPevalDivBoundedIntegralTerm a (ConTerm _ 1) = Just a -doPevalDivBoundedIntegralTerm _ _ = Nothing - --- mod -pevalModIntegralTerm :: (SupportedPrim a, Integral a) => Term a -> Term a -> Term a -pevalModIntegralTerm = binaryUnfoldOnce doPevalModIntegralTerm modIntegralTerm - -doPevalModIntegralTerm :: (SupportedPrim a, Integral a) => Term a -> Term a -> Maybe (Term a) -doPevalModIntegralTerm (ConTerm _ a) (ConTerm _ b) | b /= 0 = Just $ conTerm $ a `mod` b -doPevalModIntegralTerm _ (ConTerm _ 1) = Just $ conTerm 0 -doPevalModIntegralTerm _ (ConTerm _ (-1)) = Just $ conTerm 0 -doPevalModIntegralTerm _ _ = Nothing - -pevalModBoundedIntegralTerm :: (SupportedPrim a, Integral a) => Term a -> Term a -> Term a -pevalModBoundedIntegralTerm = pevalModIntegralTerm - --- quot -pevalQuotIntegralTerm :: (SupportedPrim a, Integral a) => Term a -> Term a -> Term a -pevalQuotIntegralTerm = binaryUnfoldOnce doPevalQuotIntegralTerm quotIntegralTerm - -doPevalQuotIntegralTerm :: (SupportedPrim a, Integral a) => Term a -> Term a -> Maybe (Term a) -doPevalQuotIntegralTerm (ConTerm _ a) (ConTerm _ b) | b /= 0 = Just $ conTerm $ a `quot` b -doPevalQuotIntegralTerm a (ConTerm _ 1) = Just a -doPevalQuotIntegralTerm _ _ = Nothing - -pevalQuotBoundedIntegralTerm :: (SupportedPrim a, Bounded a, Integral a) => Term a -> Term a -> Term a -pevalQuotBoundedIntegralTerm = binaryUnfoldOnce doPevalQuotBoundedIntegralTerm quotBoundedIntegralTerm - -doPevalQuotBoundedIntegralTerm :: (SupportedPrim a, Bounded a, Integral a) => Term a -> Term a -> Maybe (Term a) -doPevalQuotBoundedIntegralTerm (ConTerm _ a) (ConTerm _ b) | b /= 0 && (b /= -1 || a /= minBound) = Just $ conTerm $ a `quot` b -doPevalQuotBoundedIntegralTerm a (ConTerm _ 1) = Just a -doPevalQuotBoundedIntegralTerm _ _ = Nothing - --- rem -pevalRemIntegralTerm :: (SupportedPrim a, Integral a) => Term a -> Term a -> Term a -pevalRemIntegralTerm = binaryUnfoldOnce doPevalRemIntegralTerm remIntegralTerm - -doPevalRemIntegralTerm :: (SupportedPrim a, Integral a) => Term a -> Term a -> Maybe (Term a) -doPevalRemIntegralTerm (ConTerm _ a) (ConTerm _ b) | b /= 0 = Just $ conTerm $ a `rem` b -doPevalRemIntegralTerm _ (ConTerm _ 1) = Just $ conTerm 0 -doPevalRemIntegralTerm _ (ConTerm _ (-1)) = Just $ conTerm 0 -doPevalRemIntegralTerm _ _ = Nothing - -pevalRemBoundedIntegralTerm :: (SupportedPrim a, Bounded a, Integral a) => Term a -> Term a -> Term a -pevalRemBoundedIntegralTerm = pevalRemIntegralTerm diff --git a/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/Num.hs b/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/Num.hs deleted file mode 100644 --- a/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/Num.hs +++ /dev/null @@ -1,235 +0,0 @@ -{-# LANGUAGE ExplicitNamespaces #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} - --- | --- Module : Grisette.IR.SymPrim.Data.Prim.PartialEval.Num --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.IR.SymPrim.Data.Prim.PartialEval.Num - ( pattern NumConTerm, - pattern NumOrdConTerm, - pevalAddNumTerm, - pevalMinusNumTerm, - pevalTimesNumTerm, - pevalUMinusNumTerm, - pevalAbsNumTerm, - pevalSignumNumTerm, - pevalLtNumTerm, - pevalLeNumTerm, - pevalGtNumTerm, - pevalGeNumTerm, - ) -where - -import Data.Typeable (Typeable, cast, eqT, type (:~:) (Refl)) -import Grisette.Core.Data.BV (WordN) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors - ( absNumTerm, - addNumTerm, - conTerm, - leNumTerm, - ltNumTerm, - signumNumTerm, - timesNumTerm, - uminusNumTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term - ( SupportedPrim, - Term - ( AbsNumTerm, - AddNumTerm, - ConTerm, - TimesNumTerm, - UMinusNumTerm - ), - ) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.Unfold - ( binaryUnfoldOnce, - unaryUnfoldOnce, - ) -import Grisette.IR.SymPrim.Data.Prim.Utils (pattern Dyn) -import qualified Type.Reflection as R -import Unsafe.Coerce (unsafeCoerce) - -numConTermView :: (Num b, Typeable b) => Term a -> Maybe b -numConTermView (ConTerm _ b) = cast b -numConTermView _ = Nothing - -pattern NumConTerm :: forall b a. (Num b, Typeable b) => b -> Term a -pattern NumConTerm b <- (numConTermView -> Just b) - -numOrdConTermView :: (Num b, Ord b, Typeable b) => Term a -> Maybe b -numOrdConTermView (ConTerm _ b) = cast b -numOrdConTermView _ = Nothing - -pattern NumOrdConTerm :: forall b a. (Num b, Ord b, Typeable b) => b -> Term a -pattern NumOrdConTerm b <- (numOrdConTermView -> Just b) - --- add -pevalAddNumTerm :: forall a. (Num a, SupportedPrim a) => Term a -> Term a -> Term a -pevalAddNumTerm = binaryUnfoldOnce doPevalAddNumTerm (\a b -> normalizeAddNum $ addNumTerm a b) - -doPevalAddNumTerm :: forall a. (Num a, SupportedPrim a) => Term a -> Term a -> Maybe (Term a) -doPevalAddNumTerm (ConTerm _ a) (ConTerm _ b) = Just $ conTerm $ a + b -doPevalAddNumTerm l@(ConTerm _ a) b = case (a, b) of - (0, k) -> Just k - (l1, AddNumTerm _ (ConTerm _ j) k) -> Just $ pevalAddNumTerm (conTerm $ l1 + j) k - _ -> doPevalAddNumTermNoConc l b -doPevalAddNumTerm a r@(ConTerm _ _) = doPevalAddNumTerm r a -doPevalAddNumTerm l r = doPevalAddNumTermNoConc l r - -doPevalAddNumTermNoConc :: forall a. (Num a, SupportedPrim a) => Term a -> Term a -> Maybe (Term a) -doPevalAddNumTermNoConc (AddNumTerm _ i@ConTerm {} j) k = Just $ pevalAddNumTerm i $ pevalAddNumTerm j k -doPevalAddNumTermNoConc i (AddNumTerm _ j@ConTerm {} k) = Just $ pevalAddNumTerm j $ pevalAddNumTerm i k -doPevalAddNumTermNoConc (UMinusNumTerm _ i) (UMinusNumTerm _ j) = Just $ pevalUMinusNumTerm $ pevalAddNumTerm i j -doPevalAddNumTermNoConc (TimesNumTerm _ (ConTerm _ i) j) (TimesNumTerm _ (ConTerm _ k) l) - | j == l = Just $ pevalTimesNumTerm (conTerm $ i + k) j -doPevalAddNumTermNoConc (TimesNumTerm _ i@ConTerm {} j) (TimesNumTerm _ k@(ConTerm _ _) l) - | i == k = Just $ pevalTimesNumTerm i (pevalAddNumTerm j l) -doPevalAddNumTermNoConc _ _ = Nothing - -normalizeAddNum :: forall a. (Num a, Typeable a) => Term a -> Term a -normalizeAddNum (AddNumTerm _ l r@(ConTerm _ _)) = addNumTerm r l -normalizeAddNum v = v - -pevalMinusNumTerm :: (Num a, SupportedPrim a) => Term a -> Term a -> Term a -pevalMinusNumTerm l r = pevalAddNumTerm l (pevalUMinusNumTerm r) - --- uminus -pevalUMinusNumTerm :: (Num a, SupportedPrim a) => Term a -> Term a -pevalUMinusNumTerm = unaryUnfoldOnce doPevalUMinusNumTerm uminusNumTerm - -doPevalUMinusNumTerm :: forall a. (Num a, SupportedPrim a) => Term a -> Maybe (Term a) -doPevalUMinusNumTerm (ConTerm _ a) = Just $ conTerm $ -a -doPevalUMinusNumTerm (UMinusNumTerm _ v) = Just v -doPevalUMinusNumTerm (AddNumTerm _ (NumConTerm l) r) = Just $ pevalMinusNumTerm (conTerm $ -l) r -doPevalUMinusNumTerm (AddNumTerm _ (UMinusNumTerm _ l) r) = Just $ pevalAddNumTerm l (pevalUMinusNumTerm r) -doPevalUMinusNumTerm (AddNumTerm _ l (UMinusNumTerm _ r)) = Just $ pevalAddNumTerm (pevalUMinusNumTerm l) r -doPevalUMinusNumTerm (TimesNumTerm _ (NumConTerm l) r) = Just $ pevalTimesNumTerm (conTerm $ -l) r -doPevalUMinusNumTerm (TimesNumTerm _ (UMinusNumTerm _ _ :: Term a) (_ :: Term a)) = error "Should not happen" -doPevalUMinusNumTerm (TimesNumTerm _ (_ :: Term a) (UMinusNumTerm _ (_ :: Term a))) = error "Should not happen" -doPevalUMinusNumTerm (AddNumTerm _ (_ :: Term a) ConTerm {}) = error "Should not happen" -doPevalUMinusNumTerm _ = Nothing - --- times -pevalTimesNumTerm :: forall a. (Num a, SupportedPrim a) => Term a -> Term a -> Term a -pevalTimesNumTerm = binaryUnfoldOnce doPevalTimesNumTerm (\a b -> normalizeTimesNum $ timesNumTerm a b) - -normalizeTimesNum :: forall a. (Num a, Typeable a) => Term a -> Term a -normalizeTimesNum (TimesNumTerm _ l r@(ConTerm _ _)) = timesNumTerm r l -normalizeTimesNum v = v - -doPevalTimesNumTerm :: forall a. (Num a, SupportedPrim a) => Term a -> Term a -> Maybe (Term a) -doPevalTimesNumTerm (ConTerm _ a) (ConTerm _ b) = Just $ conTerm $ a * b -doPevalTimesNumTerm l@(ConTerm _ a) b = case (a, b) of - (0, _) -> Just $ conTerm 0 - (1, k) -> Just k - (-1, k) -> Just $ pevalUMinusNumTerm k - (l1, TimesNumTerm _ (NumConTerm j) k) -> Just $ pevalTimesNumTerm (conTerm $ l1 * j) k - (l1, AddNumTerm _ (NumConTerm j) k) -> Just $ pevalAddNumTerm (conTerm $ l1 * j) (pevalTimesNumTerm (conTerm l1) k) - (l1, UMinusNumTerm _ j) -> Just (pevalTimesNumTerm (conTerm $ -l1) j) - (_, TimesNumTerm _ (_ :: Term a) ConTerm {}) -> error "Should not happen" - (_, AddNumTerm _ (_ :: Term a) ConTerm {}) -> error "Should not happen" - _ -> doPevalTimesNumTermNoConc l b -doPevalTimesNumTerm a r@(ConTerm _ _) = doPevalTimesNumTerm r a -doPevalTimesNumTerm l r = doPevalTimesNumTermNoConc l r - -doPevalTimesNumTermNoConc :: forall a. (Num a, SupportedPrim a) => Term a -> Term a -> Maybe (Term a) -doPevalTimesNumTermNoConc (TimesNumTerm _ i@ConTerm {} j) k = Just $ pevalTimesNumTerm i $ pevalTimesNumTerm j k -doPevalTimesNumTermNoConc i (TimesNumTerm _ j@ConTerm {} k) = Just $ pevalTimesNumTerm j $ pevalTimesNumTerm i k -doPevalTimesNumTermNoConc (UMinusNumTerm _ i) j = Just $ pevalUMinusNumTerm $ pevalTimesNumTerm i j -doPevalTimesNumTermNoConc i (UMinusNumTerm _ j) = Just $ pevalUMinusNumTerm $ pevalTimesNumTerm i j -doPevalTimesNumTermNoConc i j@ConTerm {} = Just $ pevalTimesNumTerm j i -doPevalTimesNumTermNoConc (TimesNumTerm _ (_ :: Term a) ConTerm {}) _ = error "Should not happen" -doPevalTimesNumTermNoConc _ (TimesNumTerm _ (_ :: Term a) ConTerm {}) = error "Should not happen" -doPevalTimesNumTermNoConc _ _ = Nothing - --- abs -pevalAbsNumTerm :: (SupportedPrim a, Num a) => Term a -> Term a -pevalAbsNumTerm = unaryUnfoldOnce doPevalAbsNumTerm absNumTerm - -isUnsignedBV :: R.TypeRep a -> Bool -isUnsignedBV (R.App s _) = - case R.eqTypeRep s $ R.typeRep @WordN of - Just R.HRefl -> True - _ -> False -isUnsignedBV _ = False - -doPevalAbsNumTerm :: forall a. (Num a, SupportedPrim a) => Term a -> Maybe (Term a) -doPevalAbsNumTerm x | isUnsignedBV (R.typeRep @a) = Just x -doPevalAbsNumTerm (ConTerm _ a) = Just $ conTerm $ abs a -doPevalAbsNumTerm (UMinusNumTerm _ v) = Just $ pevalAbsNumTerm v -doPevalAbsNumTerm t@(AbsNumTerm _ (_ :: Term a)) = Just t -doPevalAbsNumTerm (TimesNumTerm _ (Dyn (l :: Term Integer)) r) = - Just $ pevalTimesNumTerm (pevalAbsNumTerm $ unsafeCoerce l :: Term a) $ pevalAbsNumTerm (unsafeCoerce r) -doPevalAbsNumTerm _ = Nothing - --- signum -pevalSignumNumTerm :: (Num a, SupportedPrim a) => Term a -> Term a -pevalSignumNumTerm = unaryUnfoldOnce doPevalSignumNumTerm signumNumTerm - -doPevalSignumNumTerm :: forall a. (Num a, SupportedPrim a) => Term a -> Maybe (Term a) -doPevalSignumNumTerm (ConTerm _ a) = Just $ conTerm $ signum a -doPevalSignumNumTerm (UMinusNumTerm _ (Dyn (v :: Term Integer))) = Just $ pevalUMinusNumTerm $ pevalSignumNumTerm $ unsafeCoerce v -doPevalSignumNumTerm (TimesNumTerm _ (Dyn (l :: Term Integer)) r) = - Just $ pevalTimesNumTerm (pevalSignumNumTerm $ unsafeCoerce l :: Term a) $ pevalSignumNumTerm (unsafeCoerce r) -doPevalSignumNumTerm _ = Nothing - --- lt -pevalLtNumTerm :: (Num a, Ord a, SupportedPrim a) => Term a -> Term a -> Term Bool -pevalLtNumTerm = binaryUnfoldOnce doPevalLtNumTerm ltNumTerm - -doPevalLtNumTerm :: forall a. (Num a, Ord a, SupportedPrim a) => Term a -> Term a -> Maybe (Term Bool) -doPevalLtNumTerm (ConTerm _ a) (ConTerm _ b) = Just $ conTerm $ a < b -doPevalLtNumTerm (ConTerm _ l) (AddNumTerm _ (ConTerm _ (Dyn (j :: Integer))) k) = - Just $ pevalLtNumTerm (conTerm $ unsafeCoerce l - j) (unsafeCoerce k) -doPevalLtNumTerm (AddNumTerm _ (ConTerm _ (Dyn (i :: Integer))) j) (ConTerm _ k) = - Just $ pevalLtNumTerm (unsafeCoerce j) (conTerm $ unsafeCoerce k - i) -doPevalLtNumTerm (AddNumTerm _ (ConTerm _ (Dyn (j :: Integer))) k) l = - Just $ pevalLtNumTerm (conTerm j) (pevalMinusNumTerm (unsafeCoerce l) (unsafeCoerce k)) -doPevalLtNumTerm j (AddNumTerm _ (ConTerm _ (Dyn (k :: Integer))) l) = - Just $ pevalLtNumTerm (conTerm $ -k) (pevalMinusNumTerm (unsafeCoerce l) (unsafeCoerce j)) -doPevalLtNumTerm l (ConTerm _ r) = - case eqT @a @Integer of - Just Refl -> - Just $ pevalLtNumTerm (conTerm $ -r) (pevalUMinusNumTerm l) - _ -> Nothing -doPevalLtNumTerm _ _ = Nothing - --- le -pevalLeNumTerm :: (Num a, Ord a, SupportedPrim a) => Term a -> Term a -> Term Bool -pevalLeNumTerm = binaryUnfoldOnce doPevalLeNumTerm leNumTerm - -doPevalLeNumTerm :: forall a. (Num a, Ord a, SupportedPrim a) => Term a -> Term a -> Maybe (Term Bool) -doPevalLeNumTerm (ConTerm _ a) (ConTerm _ b) = Just $ conTerm $ a <= b -doPevalLeNumTerm (ConTerm _ l) (AddNumTerm _ (ConTerm _ (Dyn (j :: Integer))) k) = - Just $ pevalLeNumTerm (conTerm $ unsafeCoerce l - j) (unsafeCoerce k) -doPevalLeNumTerm (AddNumTerm _ (ConTerm _ (Dyn (i :: Integer))) j) (ConTerm _ k) = - Just $ pevalLeNumTerm (unsafeCoerce j) (conTerm $ unsafeCoerce k - i) -doPevalLeNumTerm (AddNumTerm _ (ConTerm _ (Dyn (j :: Integer))) k) l = - Just $ pevalLeNumTerm (conTerm j) (pevalMinusNumTerm (unsafeCoerce l) (unsafeCoerce k)) -doPevalLeNumTerm j (AddNumTerm _ (ConTerm _ (Dyn (k :: Integer))) l) = - Just $ pevalLeNumTerm (conTerm $ -k) (pevalMinusNumTerm (unsafeCoerce l) (unsafeCoerce j)) -doPevalLeNumTerm l (ConTerm _ r) = - case eqT @a @Integer of - Just Refl -> - Just $ pevalLeNumTerm (conTerm $ -r) (pevalUMinusNumTerm l) - _ -> Nothing -doPevalLeNumTerm _ _ = Nothing - -pevalGtNumTerm :: (Num a, Ord a, SupportedPrim a) => Term a -> Term a -> Term Bool -pevalGtNumTerm = flip pevalLtNumTerm - -pevalGeNumTerm :: (Num a, Ord a, SupportedPrim a) => Term a -> Term a -> Term Bool -pevalGeNumTerm = flip pevalLeNumTerm diff --git a/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/PartialEval.hs b/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/PartialEval.hs deleted file mode 100644 --- a/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/PartialEval.hs +++ /dev/null @@ -1,94 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} - --- | --- Module : Grisette.IR.SymPrim.Data.Prim.PartialEval.PartialEval --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.IR.SymPrim.Data.Prim.PartialEval.PartialEval - ( PartialFun, - PartialRuleUnary, - TotalRuleUnary, - PartialRuleBinary, - TotalRuleBinary, - totalize, - totalize2, - UnaryPartialStrategy (..), - unaryPartial, - BinaryCommPartialStrategy (..), - BinaryPartialStrategy (..), - binaryPartial, - ) -where - -import Control.Monad.Except (MonadError (catchError)) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term (Term) - -type PartialFun a b = a -> Maybe b - -type PartialRuleUnary a b = PartialFun (Term a) (Term b) - -type TotalRuleUnary a b = Term a -> Term b - -type PartialRuleBinary a b c = Term a -> PartialFun (Term b) (Term c) - -type TotalRuleBinary a b c = Term a -> Term b -> Term c - -totalize :: PartialFun a b -> (a -> b) -> a -> b -totalize partial fallback a = - case partial a of - Just b -> b - Nothing -> fallback a - -totalize2 :: (a -> PartialFun b c) -> (a -> b -> c) -> a -> b -> c -totalize2 partial fallback a b = - case partial a b of - Just c -> c - Nothing -> fallback a b - -class UnaryPartialStrategy tag a b | tag a -> b where - extractor :: tag -> Term a -> Maybe a - constantHandler :: tag -> a -> Maybe (Term b) - nonConstantHandler :: tag -> Term a -> Maybe (Term b) - -unaryPartial :: forall tag a b. (UnaryPartialStrategy tag a b) => tag -> PartialRuleUnary a b -unaryPartial tag a = case extractor tag a of - Nothing -> nonConstantHandler tag a - Just a' -> constantHandler tag a' - -class BinaryCommPartialStrategy tag a c | tag a -> c where - singleConstantHandler :: tag -> a -> Term a -> Maybe (Term c) - -class BinaryPartialStrategy tag a b c | tag a b -> c where - extractora :: tag -> Term a -> Maybe a - extractorb :: tag -> Term b -> Maybe b - allConstantHandler :: tag -> a -> b -> Maybe (Term c) - leftConstantHandler :: tag -> a -> Term b -> Maybe (Term c) - default leftConstantHandler :: (a ~ b, BinaryCommPartialStrategy tag a c) => tag -> a -> Term b -> Maybe (Term c) - leftConstantHandler = singleConstantHandler @tag @a - rightConstantHandler :: tag -> Term a -> b -> Maybe (Term c) - default rightConstantHandler :: (a ~ b, BinaryCommPartialStrategy tag a c) => tag -> Term a -> b -> Maybe (Term c) - rightConstantHandler tag = flip $ singleConstantHandler @tag @a tag - nonBinaryConstantHandler :: tag -> Term a -> Term b -> Maybe (Term c) - -binaryPartial :: forall tag a b c. (BinaryPartialStrategy tag a b c) => tag -> PartialRuleBinary a b c -binaryPartial tag a b = case (extractora @tag @a @b @c tag a, extractorb @tag @a @b @c tag b) of - (Nothing, Nothing) -> nonBinaryConstantHandler @tag @a @b @c tag a b - (Just a', Nothing) -> - leftConstantHandler @tag @a @b @c tag a' b - `catchError` \_ -> nonBinaryConstantHandler @tag @a @b @c tag a b - (Nothing, Just b') -> - rightConstantHandler @tag @a @b @c tag a b' - `catchError` \_ -> nonBinaryConstantHandler @tag @a @b @c tag a b - (Just a', Just b') -> - allConstantHandler @tag @a @b @c tag a' b' diff --git a/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/TabularFun.hs b/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/TabularFun.hs deleted file mode 100644 --- a/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/TabularFun.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeOperators #-} - --- | --- Module : Grisette.IR.SymPrim.Data.Prim.PartialEval.TabularFun --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.IR.SymPrim.Data.Prim.PartialEval.TabularFun - ( pevalTabularFunApplyTerm, - ) -where - -import Grisette.Core.Data.Class.Function (Function ((#))) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors - ( conTerm, - tabularFunApplyTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term - ( SupportedPrim, - Term (ConTerm), - ) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool - ( pevalEqvTerm, - pevalITETerm, - ) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.PartialEval - ( totalize2, - ) -import Grisette.IR.SymPrim.Data.TabularFun - ( type (=->) (TabularFun), - ) - -pevalTabularFunApplyTerm :: (SupportedPrim a, SupportedPrim b) => Term (a =-> b) -> Term a -> Term b -pevalTabularFunApplyTerm = totalize2 doPevalTabularFunApplyTerm tabularFunApplyTerm - -doPevalTabularFunApplyTerm :: (SupportedPrim a, SupportedPrim b) => Term (a =-> b) -> Term a -> Maybe (Term b) -doPevalTabularFunApplyTerm (ConTerm _ f) (ConTerm _ a) = Just $ conTerm $ f # a -doPevalTabularFunApplyTerm (ConTerm _ (TabularFun f d)) a = Just $ go f - where - go [] = conTerm d - go ((x, y) : xs) = pevalITETerm (pevalEqvTerm a (conTerm x)) (conTerm y) (go xs) -doPevalTabularFunApplyTerm _ _ = Nothing diff --git a/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/Unfold.hs b/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/Unfold.hs deleted file mode 100644 --- a/src/Grisette/IR/SymPrim/Data/Prim/PartialEval/Unfold.hs +++ /dev/null @@ -1,118 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - --- | --- Module : Grisette.IR.SymPrim.Data.Prim.PartialEval.Unfold --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.IR.SymPrim.Data.Prim.PartialEval.Unfold - ( unaryUnfoldOnce, - binaryUnfoldOnce, - ) -where - -import Control.Monad.Except (MonadError (catchError)) -import Data.Typeable (Typeable) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term - ( SupportedPrim, - Term (ITETerm), - ) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool - ( pevalITETerm, - ) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.PartialEval - ( PartialRuleBinary, - PartialRuleUnary, - TotalRuleBinary, - TotalRuleUnary, - totalize, - totalize2, - ) - -unaryPartialUnfoldOnce :: - forall a b. - (Typeable a, SupportedPrim b) => - PartialRuleUnary a b -> - TotalRuleUnary a b -> - PartialRuleUnary a b -unaryPartialUnfoldOnce partial fallback = ret - where - oneLevel :: TotalRuleUnary a b -> PartialRuleUnary a b - oneLevel fallback' x = case (x, partial x) of - (ITETerm _ cond vt vf, pr) -> - let pt = partial vt - pf = partial vf - in case (pt, pf) of - (Nothing, Nothing) -> pr - (mt, mf) -> - pevalITETerm cond - <$> catchError mt (\_ -> Just $ totalize (oneLevel fallback') fallback' vt) - <*> catchError mf (\_ -> Just $ totalize (oneLevel fallback') fallback vf) - (_, pr) -> pr - ret :: PartialRuleUnary a b - ret = oneLevel (totalize @(Term a) @(Term b) partial fallback) - -unaryUnfoldOnce :: - forall a b. - (Typeable a, SupportedPrim b) => - PartialRuleUnary a b -> - TotalRuleUnary a b -> - TotalRuleUnary a b -unaryUnfoldOnce partial fallback = totalize (unaryPartialUnfoldOnce partial fallback) fallback - -binaryPartialUnfoldOnce :: - forall a b c. - (Typeable a, Typeable b, SupportedPrim c) => - PartialRuleBinary a b c -> - TotalRuleBinary a b c -> - PartialRuleBinary a b c -binaryPartialUnfoldOnce partial fallback = ret - where - oneLevel :: (Typeable x, Typeable y) => PartialRuleBinary x y c -> TotalRuleBinary x y c -> PartialRuleBinary x y c - oneLevel partial' fallback' x y = - catchError - (partial' x y) - ( \_ -> - catchError - ( case x of - ITETerm _ cond vt vf -> left cond vt vf y partial' fallback' - _ -> Nothing - ) - ( \_ -> case y of - ITETerm _ cond vt vf -> left cond vt vf x (flip partial') (flip fallback') - _ -> Nothing - ) - ) - left :: - (Typeable x, Typeable y) => - Term Bool -> - Term x -> - Term x -> - Term y -> - PartialRuleBinary x y c -> - TotalRuleBinary x y c -> - Maybe (Term c) - left cond vt vf y partial' fallback' = - let pt = partial' vt y - pf = partial' vf y - in case (pt, pf) of - (Nothing, Nothing) -> Nothing - (mt, mf) -> - pevalITETerm cond - <$> catchError mt (\_ -> Just $ totalize2 (oneLevel partial' fallback') fallback' vt y) - <*> catchError mf (\_ -> Just $ totalize2 (oneLevel partial' fallback') fallback' vf y) - ret :: PartialRuleBinary a b c - ret = oneLevel partial (totalize2 @(Term a) @(Term b) @(Term c) partial fallback) - -binaryUnfoldOnce :: - forall a b c. - (Typeable a, Typeable b, SupportedPrim c) => - PartialRuleBinary a b c -> - TotalRuleBinary a b c -> - TotalRuleBinary a b c -binaryUnfoldOnce partial fallback = totalize2 (binaryPartialUnfoldOnce partial fallback) fallback diff --git a/src/Grisette/IR/SymPrim/Data/Prim/Utils.hs b/src/Grisette/IR/SymPrim/Data/Prim/Utils.hs deleted file mode 100644 --- a/src/Grisette/IR/SymPrim/Data/Prim/Utils.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# LANGUAGE ExplicitNamespaces #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} - --- | --- Module : Grisette.IR.SymPrim.Data.Prim.Utils --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.IR.SymPrim.Data.Prim.Utils - ( pattern Dyn, - cmpHetero, - eqHetero, - cmpHeteroRep, - eqHeteroRep, - eqTypeRepBool, - ) -where - -import Data.Typeable (cast) -import Type.Reflection - ( TypeRep, - Typeable, - eqTypeRep, - typeRep, - type (:~~:) (HRefl), - ) - -pattern Dyn :: (Typeable a, Typeable b) => a -> b -pattern Dyn x <- (cast -> Just x) - -cmpHeteroRep :: forall a b. TypeRep a -> TypeRep b -> (a -> a -> Bool) -> a -> b -> Bool -cmpHeteroRep ta tb f a b = case eqTypeRep ta tb of - Just HRefl -> f a b - _ -> False -{-# INLINE cmpHeteroRep #-} - -cmpHetero :: forall a b. (Typeable a, Typeable b) => (a -> a -> Bool) -> a -> b -> Bool -cmpHetero = cmpHeteroRep (typeRep @a) (typeRep @b) -{-# INLINE cmpHetero #-} - -eqHetero :: forall a b. (Typeable a, Typeable b, Eq a) => a -> b -> Bool -eqHetero = cmpHetero (==) -{-# INLINE eqHetero #-} - -eqHeteroRep :: forall a b. (Eq a) => TypeRep a -> TypeRep b -> a -> b -> Bool -eqHeteroRep ta tb = cmpHeteroRep ta tb (==) -{-# INLINE eqHeteroRep #-} - -eqTypeRepBool :: forall ka kb (a :: ka) (b :: kb). TypeRep a -> TypeRep b -> Bool -eqTypeRepBool a b = case eqTypeRep a b of - Just HRefl -> True - _ -> False -{-# INLINE eqTypeRepBool #-} diff --git a/src/Grisette/IR/SymPrim/Data/SymPrim.hs b/src/Grisette/IR/SymPrim/Data/SymPrim.hs deleted file mode 100644 --- a/src/Grisette/IR/SymPrim/Data/SymPrim.hs +++ /dev/null @@ -1,1349 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- Module : Grisette.IR.SymPrim.Data.SymPrim --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.IR.SymPrim.Data.SymPrim - ( SymBool (..), - SymInteger (..), - SymWordN (..), - SymIntN (..), - SomeSymWordN (..), - SomeSymIntN (..), - type (=~>) (..), - type (-~>) (..), - (-->), - ModelSymPair (..), - symSize, - symsSize, - SomeSym (..), - AllSyms (..), - allSymsSize, - unarySomeSymIntN, - unarySomeSymIntNR1, - binSomeSymIntN, - binSomeSymIntNR1, - binSomeSymIntNR2, - unarySomeSymWordN, - unarySomeSymWordNR1, - binSomeSymWordN, - binSomeSymWordNR1, - binSomeSymWordNR2, - ) -where - -import Control.DeepSeq (NFData (rnf)) -import Control.Monad.Except (ExceptT (ExceptT)) -import Control.Monad.Identity - ( Identity (Identity), - IdentityT (IdentityT), - ) -import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) -import qualified Control.Monad.Writer.Lazy as WriterLazy -import qualified Control.Monad.Writer.Strict as WriterStrict -import Data.Bits - ( Bits - ( bit, - bitSize, - bitSizeMaybe, - clearBit, - complement, - complementBit, - isSigned, - popCount, - rotate, - rotateL, - rotateR, - setBit, - shift, - shiftL, - shiftR, - testBit, - unsafeShiftL, - unsafeShiftR, - xor, - zeroBits, - (.&.), - (.|.) - ), - FiniteBits (finiteBitSize), - ) -import qualified Data.ByteString as B -import Data.Functor.Sum (Sum) -import Data.Hashable (Hashable (hashWithSalt)) -import Data.Int (Int16, Int32, Int64, Int8) -import Data.Proxy (Proxy (Proxy)) -import Data.String (IsString (fromString)) -import qualified Data.Text as T -import Data.Typeable (typeRep, type (:~:) (Refl)) -import Data.Word (Word16, Word32, Word64, Word8) -import GHC.Generics - ( Generic (Rep, from), - K1 (K1), - M1 (M1), - U1, - type (:*:) ((:*:)), - type (:+:) (L1, R1), - ) -import GHC.TypeNats - ( KnownNat, - Nat, - natVal, - sameNat, - type (+), - type (<=), - ) -import Generics.Deriving (Default (Default, unDefault)) -import Grisette.Core.Control.Exception - ( AssertionError, - VerificationConditions, - ) -import Grisette.Core.Data.BV - ( IntN, - WordN, - ) -import Grisette.Core.Data.Class.BitVector - ( BV (bvConcat, bvExt, bvSelect, bvSext, bvZext), - SizedBV (sizedBVConcat, sizedBVExt, sizedBVSelect, sizedBVSext, sizedBVZext), - ) -import Grisette.Core.Data.Class.Function (Apply (FunType, apply), Function (Arg, Ret, (#))) -import Grisette.Core.Data.Class.ModelOps - ( ModelOps (emptyModel, insertValue), - ModelRep (buildModel), - ) -import Grisette.Core.Data.Class.SignConversion (SignConversion (toSigned, toUnsigned)) -import Grisette.Core.Data.Class.Solvable - ( Solvable (con, conView, iinfosym, isym, sinfosym, ssym), - pattern Con, - ) -import Grisette.Core.Data.Class.SymRotate (SymRotate (symRotate)) -import Grisette.Core.Data.Class.SymShift (SymShift (symShift)) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors (conTerm, iinfosymTerm, isymTerm, sinfosymTerm, ssymTerm, symTerm) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.SomeTerm - ( SomeTerm (SomeTerm), - ) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term - ( ConRep (ConType), - LinkedRep (underlyingTerm, wrapTerm), - SupportedPrim, - SymRep (SymType), - Term (ConTerm, SymTerm), - TypedSymbol (WithInfo), - type (-->) (GeneralFun), - ) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermSubstitution - ( substTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermUtils - ( pformat, - someTermsSize, - termSize, - termsSize, - ) -import Grisette.IR.SymPrim.Data.Prim.Model - ( Model, - ) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.BV - ( pevalBVConcatTerm, - pevalBVExtendTerm, - pevalBVSelectTerm, - pevalToSignedTerm, - pevalToUnsignedTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bits - ( pevalAndBitsTerm, - pevalComplementBitsTerm, - pevalOrBitsTerm, - pevalRotateLeftTerm, - pevalRotateRightTerm, - pevalShiftLeftTerm, - pevalShiftRightTerm, - pevalXorBitsTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool - ( pevalEqvTerm, - pevalITETerm, - pevalOrTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.GeneralFun - ( pevalGeneralFunApplyTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.Integral (pevalModBoundedIntegralTerm) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.Num - ( pevalAbsNumTerm, - pevalAddNumTerm, - pevalGeNumTerm, - pevalLeNumTerm, - pevalMinusNumTerm, - pevalSignumNumTerm, - pevalTimesNumTerm, - pevalUMinusNumTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.TabularFun - ( pevalTabularFunApplyTerm, - ) -import Grisette.IR.SymPrim.Data.TabularFun (type (=->)) -import Grisette.Utils.Parameterized - ( KnownProof (KnownProof), - LeqProof (LeqProof), - knownAdd, - leqAddPos, - leqTrans, - unsafeKnownProof, - unsafeLeqProof, - ) -import Language.Haskell.TH.Syntax (Lift) - --- $setup --- >>> import Grisette.Core --- >>> import Grisette.IR.SymPrim --- >>> import Grisette.Backend.SBV --- >>> import Data.Proxy - --- | Symbolic Boolean type. --- --- >>> :set -XOverloadedStrings --- >>> "a" :: SymBool --- a --- >>> "a" .&& "b" :: SymBool --- (&& a b) --- --- More symbolic operations are available. Please refer to the documentation --- for the type class instances. -newtype SymBool = SymBool {underlyingBoolTerm :: Term Bool} - deriving (Lift, NFData, Generic) - --- | Symbolic (unbounded, mathematical) integer type. --- --- >>> "a" + 1 :: SymInteger --- (+ 1 a) --- --- More symbolic operations are available. Please refer to the documentation --- for the type class instances. -newtype SymInteger = SymInteger {underlyingIntegerTerm :: Term Integer} - deriving (Lift, NFData, Generic) - -#define QUOTE() ' -#define QID(a) a -#define QRIGHT(a) QID(a)' - --- | Symbolic signed bit vector type. Indexed with the bit width. --- Signedness affects the semantics of the operations, including --- comparison/extension, etc. --- --- >>> :set -XOverloadedStrings -XDataKinds -XBinaryLiterals --- >>> "a" + 5 :: SymIntN 5 --- (+ 0b00101 a) --- >>> sizedBVConcat (con 0b101 :: SymIntN 3) (con 0b110 :: SymIntN 3) --- 0b101110 --- >>> sizedBVExt (Proxy @6) (con 0b101 :: SymIntN 3) --- 0b111101 --- >>> (8 :: SymIntN 4) .< (7 :: SymIntN 4) --- true --- --- More symbolic operations are available. Please refer to the documentation --- for the type class instances. -newtype SymIntN (n :: Nat) = SymIntN {underlyingIntNTerm :: Term (IntN n)} - deriving (Lift, NFData, Generic) - --- | Symbolic signed bit vector type. Not indexed, but the bit width is --- fixed at the creation time. --- --- A 'SomeSymIntN' must be created by wrapping a 'SymIntN' with the --- 'SomeSymIntN' constructor to fix the bit width: --- --- >>> (SomeSymIntN ("a" :: SymIntN 5)) --- a --- --- >>> :set -XOverloadedStrings -XDataKinds -XBinaryLiterals --- >>> (SomeSymIntN ("a" :: SymIntN 5)) + (SomeSymIntN (5 :: SymIntN 5)) --- (+ 0b00101 a) --- >>> bvConcat (SomeSymIntN (con 0b101 :: SymIntN 3)) (SomeSymIntN (con 0b110 :: SymIntN 3)) --- 0b101110 --- --- More symbolic operations are available. Please refer to the documentation --- for the type class instances. -data SomeSymIntN where - SomeSymIntN :: (KnownNat n, 1 <= n) => SymIntN n -> SomeSymIntN - -unarySomeSymIntN :: (forall n. (KnownNat n, 1 <= n) => SymIntN n -> r) -> String -> SomeSymIntN -> r -unarySomeSymIntN op _ (SomeSymIntN (w :: SymIntN w)) = op w -{-# INLINE unarySomeSymIntN #-} - -unarySomeSymIntNR1 :: (forall n. (KnownNat n, 1 <= n) => SymIntN n -> SymIntN n) -> String -> SomeSymIntN -> SomeSymIntN -unarySomeSymIntNR1 op _ (SomeSymIntN (w :: SymIntN w)) = SomeSymIntN $ op w -{-# INLINE unarySomeSymIntNR1 #-} - -binSomeSymIntN :: (forall n. (KnownNat n, 1 <= n) => SymIntN n -> SymIntN n -> r) -> String -> SomeSymIntN -> SomeSymIntN -> r -binSomeSymIntN op str (SomeSymIntN (l :: SymIntN l)) (SomeSymIntN (r :: SymIntN r)) = - case sameNat (Proxy @l) (Proxy @r) of - Just Refl -> op l r - Nothing -> error $ "Operation " ++ str ++ " on SymIntN with different bitwidth" -{-# INLINE binSomeSymIntN #-} - -binSomeSymIntNR1 :: (forall n. (KnownNat n, 1 <= n) => SymIntN n -> SymIntN n -> SymIntN n) -> String -> SomeSymIntN -> SomeSymIntN -> SomeSymIntN -binSomeSymIntNR1 op str (SomeSymIntN (l :: SymIntN l)) (SomeSymIntN (r :: SymIntN r)) = - case sameNat (Proxy @l) (Proxy @r) of - Just Refl -> SomeSymIntN $ op l r - Nothing -> error $ "Operation " ++ str ++ " on SymIntN with different bitwidth" -{-# INLINE binSomeSymIntNR1 #-} - -binSomeSymIntNR2 :: (forall n. (KnownNat n, 1 <= n) => SymIntN n -> SymIntN n -> (SymIntN n, SymIntN n)) -> String -> SomeSymIntN -> SomeSymIntN -> (SomeSymIntN, SomeSymIntN) -binSomeSymIntNR2 op str (SomeSymIntN (l :: SymIntN l)) (SomeSymIntN (r :: SymIntN r)) = - case sameNat (Proxy @l) (Proxy @r) of - Just Refl -> - case op l r of - (a, b) -> (SomeSymIntN a, SomeSymIntN b) - Nothing -> error $ "Operation " ++ str ++ " on SymIntN with different bitwidth" -{-# INLINE binSomeSymIntNR2 #-} - --- | Symbolic unsigned bit vector type. Indexed with the bit width. --- Signedness affects the semantics of the operations, including --- comparison/extension, etc. --- --- >>> :set -XOverloadedStrings -XDataKinds -XBinaryLiterals --- >>> "a" + 5 :: SymWordN 5 --- (+ 0b00101 a) --- >>> sizedBVConcat (con 0b101 :: SymWordN 3) (con 0b110 :: SymWordN 3) --- 0b101110 --- >>> sizedBVExt (Proxy @6) (con 0b101 :: SymWordN 3) --- 0b000101 --- >>> (8 :: SymWordN 4) .< (7 :: SymWordN 4) --- false --- --- More symbolic operations are available. Please refer to the documentation --- for the type class instances. -newtype SymWordN (n :: Nat) = SymWordN {underlyingWordNTerm :: Term (WordN n)} - deriving (Lift, NFData, Generic) - --- | Symbolic unsigned bit vector type. Not indexed, but the bit width is --- fixed at the creation time. --- --- A 'SomeSymWordN' must be created by wrapping a 'SymWordN' with the --- 'SomeSymWordN' constructor to fix the bit width: --- --- >>> (SomeSymWordN ("a" :: SymWordN 5)) --- a --- --- >>> :set -XOverloadedStrings -XDataKinds -XBinaryLiterals --- >>> (SomeSymWordN ("a" :: SymWordN 5)) + (SomeSymWordN (5 :: SymWordN 5)) --- (+ 0b00101 a) --- >>> bvConcat (SomeSymWordN (con 0b101 :: SymWordN 3)) (SomeSymWordN (con 0b110 :: SymWordN 3)) --- 0b101110 --- --- More symbolic operations are available. Please refer to the documentation --- for the type class instances. -data SomeSymWordN where - SomeSymWordN :: (KnownNat n, 1 <= n) => SymWordN n -> SomeSymWordN - -unarySomeSymWordN :: (forall n. (KnownNat n, 1 <= n) => SymWordN n -> r) -> String -> SomeSymWordN -> r -unarySomeSymWordN op _ (SomeSymWordN (w :: SymWordN w)) = op w -{-# INLINE unarySomeSymWordN #-} - -unarySomeSymWordNR1 :: (forall n. (KnownNat n, 1 <= n) => SymWordN n -> SymWordN n) -> String -> SomeSymWordN -> SomeSymWordN -unarySomeSymWordNR1 op _ (SomeSymWordN (w :: SymWordN w)) = SomeSymWordN $ op w -{-# INLINE unarySomeSymWordNR1 #-} - -binSomeSymWordN :: (forall n. (KnownNat n, 1 <= n) => SymWordN n -> SymWordN n -> r) -> String -> SomeSymWordN -> SomeSymWordN -> r -binSomeSymWordN op str (SomeSymWordN (l :: SymWordN l)) (SomeSymWordN (r :: SymWordN r)) = - case sameNat (Proxy @l) (Proxy @r) of - Just Refl -> op l r - Nothing -> error $ "Operation " ++ str ++ " on SymWordN with different bitwidth" -{-# INLINE binSomeSymWordN #-} - -binSomeSymWordNR1 :: (forall n. (KnownNat n, 1 <= n) => SymWordN n -> SymWordN n -> SymWordN n) -> String -> SomeSymWordN -> SomeSymWordN -> SomeSymWordN -binSomeSymWordNR1 op str (SomeSymWordN (l :: SymWordN l)) (SomeSymWordN (r :: SymWordN r)) = - case sameNat (Proxy @l) (Proxy @r) of - Just Refl -> SomeSymWordN $ op l r - Nothing -> error $ "Operation " ++ str ++ " on SymWordN with different bitwidth" -{-# INLINE binSomeSymWordNR1 #-} - -binSomeSymWordNR2 :: (forall n. (KnownNat n, 1 <= n) => SymWordN n -> SymWordN n -> (SymWordN n, SymWordN n)) -> String -> SomeSymWordN -> SomeSymWordN -> (SomeSymWordN, SomeSymWordN) -binSomeSymWordNR2 op str (SomeSymWordN (l :: SymWordN l)) (SomeSymWordN (r :: SymWordN r)) = - case sameNat (Proxy @l) (Proxy @r) of - Just Refl -> - case op l r of - (a, b) -> (SomeSymWordN a, SomeSymWordN b) - Nothing -> error $ "Operation " ++ str ++ " on SymWordN with different bitwidth" -{-# INLINE binSomeSymWordNR2 #-} - -instance ConRep SymBool where - type ConType SymBool = Bool - -instance SymRep Bool where - type SymType Bool = SymBool - -instance LinkedRep Bool SymBool where - underlyingTerm (SymBool a) = a - wrapTerm = SymBool - -instance ConRep SymInteger where - type ConType SymInteger = Integer - -instance SymRep Integer where - type SymType Integer = SymInteger - -instance LinkedRep Integer SymInteger where - underlyingTerm (SymInteger a) = a - wrapTerm = SymInteger - -instance (KnownNat n, 1 <= n) => ConRep (SymIntN n) where - type ConType (SymIntN n) = IntN n - -instance (KnownNat n, 1 <= n) => SymRep (IntN n) where - type SymType (IntN n) = SymIntN n - -instance (KnownNat n, 1 <= n) => LinkedRep (IntN n) (SymIntN n) where - underlyingTerm (SymIntN a) = a - wrapTerm = SymIntN - -instance (KnownNat n, 1 <= n) => ConRep (SymWordN n) where - type ConType (SymWordN n) = WordN n - -instance (KnownNat n, 1 <= n) => SymRep (WordN n) where - type SymType (WordN n) = SymWordN n - -instance (KnownNat n, 1 <= n) => LinkedRep (WordN n) (SymWordN n) where - underlyingTerm (SymWordN a) = a - wrapTerm = SymWordN - --- | Symbolic tabular function type. --- --- >>> :set -XTypeOperators -XOverloadedStrings --- >>> f' = "f" :: SymInteger =~> SymInteger --- >>> f = (f' #) --- >>> f 1 --- (apply f 1) --- --- >>> f' = con (TabularFun [(1, 2), (2, 3)] 4) :: SymInteger =~> SymInteger --- >>> f = (f' #) --- >>> f 1 --- 2 --- >>> f 2 --- 3 --- >>> f 3 --- 4 --- >>> f "b" --- (ite (= b 1) 2 (ite (= b 2) 3 4)) -data sa =~> sb where - SymTabularFun :: (LinkedRep ca sa, LinkedRep cb sb) => Term (ca =-> cb) -> sa =~> sb - -infixr 0 =~> - -instance (ConRep a, ConRep b) => ConRep (a =~> b) where - type ConType (a =~> b) = ConType a =-> ConType b - -instance (SymRep a, SymRep b) => SymRep (a =-> b) where - type SymType (a =-> b) = SymType a =~> SymType b - -instance (LinkedRep ca sa, LinkedRep cb sb) => LinkedRep (ca =-> cb) (sa =~> sb) where - underlyingTerm (SymTabularFun a) = a - wrapTerm = SymTabularFun - -instance (SupportedPrim ca, SupportedPrim cb, LinkedRep ca sa, LinkedRep cb sb) => Function (sa =~> sb) where - type Arg (sa =~> sb) = sa - type Ret (sa =~> sb) = sb - (SymTabularFun f) # t = wrapTerm $ pevalTabularFunApplyTerm f (underlyingTerm t) - -instance (LinkedRep ca sa, LinkedRep ct st, Apply st) => Apply (sa =~> st) where - type FunType (sa =~> st) = sa -> FunType st - apply uf a = apply (uf # a) - --- | --- Symbolic general function type. --- --- >>> :set -XTypeOperators -XOverloadedStrings --- >>> f' = "f" :: SymInteger -~> SymInteger --- >>> f = (f' #) --- >>> f 1 --- (apply f 1) --- --- >>> f' = con ("a" --> "a" + 1) :: SymInteger -~> SymInteger --- >>> f' --- \(a:ARG :: Integer) -> (+ 1 a:ARG) --- >>> f = (f' #) --- >>> f 1 --- 2 --- >>> f 2 --- 3 --- >>> f 3 --- 4 --- >>> f "b" --- (+ 1 b) -data sa -~> sb where - SymGeneralFun :: (LinkedRep ca sa, LinkedRep cb sb) => Term (ca --> cb) -> sa -~> sb - -infixr 0 -~> - -instance (ConRep a, ConRep b) => ConRep (a -~> b) where - type ConType (a -~> b) = ConType a --> ConType b - -instance (SymRep ca, SymRep cb) => SymRep (ca --> cb) where - type SymType (ca --> cb) = SymType ca -~> SymType cb - -instance (LinkedRep ca sa, LinkedRep cb sb) => LinkedRep (ca --> cb) (sa -~> sb) where - underlyingTerm (SymGeneralFun a) = a - wrapTerm = SymGeneralFun - -instance (SupportedPrim ca, SupportedPrim cb, LinkedRep ca sa, LinkedRep cb sb) => Function (sa -~> sb) where - type Arg (sa -~> sb) = sa - type Ret (sa -~> sb) = sb - (SymGeneralFun f) # t = wrapTerm $ pevalGeneralFunApplyTerm f (underlyingTerm t) - -instance (LinkedRep ca sa, LinkedRep ct st, Apply st) => Apply (sa -~> st) where - type FunType (sa -~> st) = sa -> FunType st - apply uf a = apply (uf # a) - --- | Construction of general symbolic functions. --- --- >>> f = "a" --> "a" + 1 :: Integer --> Integer --- >>> f --- \(a:ARG :: Integer) -> (+ 1 a:ARG) --- --- This general symbolic function needs to be applied to symbolic values: --- >>> f # ("a" :: SymInteger) --- (+ 1 a) -(-->) :: (SupportedPrim ca, SupportedPrim cb, LinkedRep cb sb) => TypedSymbol ca -> sb -> ca --> cb -(-->) arg v = GeneralFun newarg (substTerm arg (symTerm newarg) (underlyingTerm v)) - where - newarg = WithInfo arg ARG - -infixr 0 --> - -data ARG = ARG - deriving (Eq, Ord, Lift, Show, Generic) - -instance NFData ARG where - rnf ARG = () - -instance Hashable ARG where - hashWithSalt s ARG = s `hashWithSalt` (0 :: Int) - --- Aggregate instances - -instance Apply SymBool where - type FunType SymBool = SymBool - apply = id - -instance Apply SymInteger where - type FunType SymInteger = SymInteger - apply = id - -instance (KnownNat n, 1 <= n) => Apply (SymIntN n) where - type FunType (SymIntN n) = SymIntN n - apply = id - -instance (KnownNat n, 1 <= n) => Apply (SymWordN n) where - type FunType (SymWordN n) = SymWordN n - apply = id - -#define SOLVABLE_SIMPLE(contype, symtype) \ -instance Solvable contype symtype where \ - con = symtype . conTerm; \ - ssym = symtype . ssymTerm; \ - isym str i = symtype $ isymTerm str i; \ - sinfosym str info = symtype $ sinfosymTerm str info; \ - iinfosym str i info = symtype $ iinfosymTerm str i info; \ - conView (symtype (ConTerm _ t)) = Just t; \ - conView _ = Nothing - -#define SOLVABLE_BV(contype, symtype) \ -instance (KnownNat n, 1 <= n) => Solvable (contype n) (symtype n) where \ - con = symtype . conTerm; \ - ssym = symtype . ssymTerm; \ - isym str i = symtype $ isymTerm str i; \ - sinfosym str info = symtype $ sinfosymTerm str info; \ - iinfosym str i info = symtype $ iinfosymTerm str i info; \ - conView (symtype (ConTerm _ t)) = Just t; \ - conView _ = Nothing - -#define SOLVABLE_FUN(symop, conop, symcons) \ -instance \ - (SupportedPrim ca, SupportedPrim cb, LinkedRep ca sa, LinkedRep cb sb) => \ - Solvable (conop ca cb) (symop sa sb) where \ - con = symcons . conTerm; \ - ssym = symcons . ssymTerm; \ - isym str i = symcons $ isymTerm str i; \ - sinfosym str info = symcons $ sinfosymTerm str info; \ - iinfosym str i info = symcons $ iinfosymTerm str i info; \ - conView (symcons (ConTerm _ t)) = Just t; \ - conView _ = Nothing - -#if 1 -SOLVABLE_SIMPLE(Bool, SymBool) -SOLVABLE_SIMPLE(Integer, SymInteger) -SOLVABLE_BV(IntN, SymIntN) -SOLVABLE_BV(WordN, SymWordN) -SOLVABLE_FUN((=~>), (=->), SymTabularFun) -SOLVABLE_FUN((-~>), (-->), SymGeneralFun) -#endif - --- Num - -#define NUM_BV(symtype) \ -instance (KnownNat n, 1 <= n) => Num (symtype n) where \ - (symtype l) + (symtype r) = symtype $ pevalAddNumTerm l r; \ - (symtype l) - (symtype r) = symtype $ pevalMinusNumTerm l r; \ - (symtype l) * (symtype r) = symtype $ pevalTimesNumTerm l r; \ - negate (symtype v) = symtype $ pevalUMinusNumTerm v; \ - abs (symtype v) = symtype $ pevalAbsNumTerm v; \ - signum (symtype v) = symtype $ pevalSignumNumTerm v; \ - fromInteger i = con $ fromInteger i - -#define NUM_SOME_BV(somety, br1, ur1) \ -instance Num somety where \ - (+) = br1 (+) "+"; \ - {-# INLINE (+) #-}; \ - (-) = br1 (-) "-"; \ - {-# INLINE (-) #-}; \ - (*) = br1 (*) "*"; \ - {-# INLINE (*) #-}; \ - negate = ur1 negate "negate"; \ - {-# INLINE negate #-}; \ - abs = ur1 abs "abs"; \ - {-# INLINE abs #-}; \ - signum = ur1 signum "signum"; \ - {-# INLINE signum #-}; \ - fromInteger = error "fromInteger is not defined for SomeSymWordN as no bitwidth is known"; \ - {-# INLINE fromInteger #-} - -#if 1 -NUM_BV(SymIntN) -NUM_BV(SymWordN) -NUM_SOME_BV(SomeSymWordN, binSomeSymWordNR1, unarySomeSymWordNR1) -NUM_SOME_BV(SomeSymIntN, binSomeSymIntNR1, unarySomeSymIntNR1) -#endif - -instance Num SymInteger where - (SymInteger l) + (SymInteger r) = SymInteger $ pevalAddNumTerm l r - (SymInteger l) - (SymInteger r) = SymInteger $ pevalMinusNumTerm l r - (SymInteger l) * (SymInteger r) = SymInteger $ pevalTimesNumTerm l r - negate (SymInteger v) = SymInteger $ pevalUMinusNumTerm v - abs (SymInteger v) = SymInteger $ pevalAbsNumTerm v - signum (SymInteger v) = SymInteger $ pevalSignumNumTerm v - fromInteger = con - --- Bits - -#define BITS_BV(symtype, signed) \ -instance (KnownNat n, 1 <= n) => Bits (symtype n) where \ - symtype l .&. symtype r = symtype $ pevalAndBitsTerm l r; \ - {-# INLINE (.&.) #-}; \ - symtype l .|. symtype r = symtype $ pevalOrBitsTerm l r; \ - {-# INLINE (.|.) #-}; \ - symtype l `xor` symtype r = symtype $ pevalXorBitsTerm l r; \ - {-# INLINE xor #-}; \ - complement (symtype n) = symtype $ pevalComplementBitsTerm n; \ - {-# INLINE complement #-}; \ - shift (symtype n) i | i > 0 = symtype $ pevalShiftLeftTerm n (conTerm $ fromIntegral i); \ - shift (symtype n) i | i < 0 = symtype $ pevalShiftRightTerm n (conTerm $ fromIntegral (-i)); \ - shift (symtype n) _ = symtype n; \ - {-# INLINE shift #-}; \ - rotate (symtype n) i | i > 0 = symtype $ pevalRotateLeftTerm n (conTerm $ fromIntegral i); \ - rotate (symtype n) i | i < 0 = symtype $ pevalRotateRightTerm n (conTerm $ fromIntegral (-i)); \ - rotate (symtype n) _ = symtype n; \ - {-# INLINE rotate #-}; \ - bitSize = finiteBitSize; \ - {-# INLINE bitSize #-}; \ - bitSizeMaybe = Just . finiteBitSize; \ - {-# INLINE bitSizeMaybe #-}; \ - isSigned _ = signed; \ - {-# INLINE isSigned #-}; \ - testBit (Con n) = testBit n; \ - testBit _ = error "You cannot call testBit on symbolic variables"; \ - {-# INLINE testBit #-}; \ - bit = con . bit; \ - {-# INLINE bit #-}; \ - popCount (Con n) = popCount n; \ - popCount _ = error "You cannot call popCount on symbolic variables"; \ - {-# INLINE popCount #-} - -#define BITS_BV_SOME(somety, origty, br1, uf, ur1) \ -instance Bits somety where \ - (.&.) = br1 (.&.) ".&."; \ - {-# INLINE (.&.) #-}; \ - (.|.) = br1 (.|.) ".|."; \ - {-# INLINE (.|.) #-}; \ - xor = br1 xor "xor"; \ - {-# INLINE xor #-}; \ - complement = ur1 complement "complement"; \ - {-# INLINE complement #-}; \ - shift s i = ur1 (`shift` i) "shift" s; \ - {-# INLINE shift #-}; \ - rotate s i = ur1 (`rotate` i) "rotate" s; \ - {-# INLINE rotate #-}; \ - zeroBits = error ("zeroBits is not defined for " ++ show (typeRep (Proxy @somety)) ++ " as no bitwidth is known"); \ - {-# INLINE zeroBits #-}; \ - bit = error ("bit is not defined for " ++ show (typeRep (Proxy @somety)) ++ " as no bitwidth is known"); \ - {-# INLINE bit #-}; \ - setBit s i = ur1 (`setBit` i) "setBit" s; \ - {-# INLINE setBit #-}; \ - clearBit s i = ur1 (`clearBit` i) "clearBit" s; \ - {-# INLINE clearBit #-}; \ - complementBit s i = ur1 (`complementBit` i) "complementBit" s; \ - {-# INLINE complementBit #-}; \ - testBit s i = uf (`testBit` i) "testBit" s; \ - {-# INLINE testBit #-}; \ - bitSizeMaybe = Just . finiteBitSize; \ - {-# INLINE bitSizeMaybe #-}; \ - bitSize = finiteBitSize; \ - {-# INLINE bitSize #-}; \ - isSigned _ = False; \ - {-# INLINE isSigned #-}; \ - shiftL s i = ur1 (`shiftL` i) "shiftL" s; \ - {-# INLINE shiftL #-}; \ - unsafeShiftL s i = ur1 (`unsafeShiftL` i) "unsafeShiftL" s; \ - {-# INLINE unsafeShiftL #-}; \ - shiftR s i = ur1 (`shiftR` i) "shiftR" s; \ - {-# INLINE shiftR #-}; \ - unsafeShiftR s i = ur1 (`unsafeShiftR` i) "unsafeShiftR" s; \ - {-# INLINE unsafeShiftR #-}; \ - rotateL s i = ur1 (`rotateL` i) "rotateL" s; \ - {-# INLINE rotateL #-}; \ - rotateR s i = ur1 (`rotateR` i) "rotateR" s; \ - {-# INLINE rotateR #-}; \ - popCount = uf popCount "popCount"; \ - {-# INLINE popCount #-} - -#if 1 -BITS_BV(SymIntN, True) -BITS_BV(SymWordN, False) -BITS_BV_SOME(SomeSymIntN, SymIntN, binSomeSymIntNR1, unarySomeSymIntN, unarySomeSymIntNR1) -BITS_BV_SOME(SomeSymWordN, SymWordN, binSomeSymWordNR1, unarySomeSymWordN, unarySomeSymWordNR1) -#endif - --- FiniteBits - -#define FINITE_BITS_BV(symtype) \ -instance (KnownNat n, 1 <= n) => FiniteBits (symtype n) where \ - finiteBitSize _ = fromIntegral $ natVal (Proxy @n); \ - {-# INLINE finiteBitSize #-}; \ - -#define FINITE_BITS_BV_SOME(somety, origty) \ -instance FiniteBits somety where \ - finiteBitSize (somety (n :: origty n)) = fromIntegral $ natVal n; \ - {-# INLINE finiteBitSize #-} - -#if 1 -FINITE_BITS_BV(SymIntN) -FINITE_BITS_BV(SymWordN) -FINITE_BITS_BV_SOME(SomeSymIntN, SymIntN) -FINITE_BITS_BV_SOME(SomeSymWordN, SymWordN) -#endif - --- Show - -#define SHOW_SIMPLE(symtype) \ -instance Show symtype where \ - show (symtype t) = pformat t - -#define SHOW_BV(symtype) \ -instance (KnownNat n, 1 <= n) => Show (symtype n) where \ - show (symtype t) = pformat t - -#define SHOW_FUN(op, cons) \ -instance (SupportedPrim ca, SupportedPrim cb, LinkedRep ca sa, LinkedRep cb sb) => Show (sa op sb) where \ - show (cons t) = pformat t - -#define SHOW_BV_SOME(somety) \ -instance Show somety where \ - show (somety t) = show t - -#if 1 -SHOW_SIMPLE(SymBool) -SHOW_SIMPLE(SymInteger) -SHOW_BV(SymIntN) -SHOW_BV(SymWordN) -SHOW_FUN(=~>, SymTabularFun) -SHOW_FUN(-~>, SymGeneralFun) -SHOW_BV_SOME(SomeSymIntN) -SHOW_BV_SOME(SomeSymWordN) -#endif - --- Hashable - -#define HASHABLE_SIMPLE(symtype) \ -instance Hashable symtype where \ - hashWithSalt s (symtype v) = s `hashWithSalt` v - -#define HASHABLE_BV(symtype) \ -instance (KnownNat n, 1 <= n) => Hashable (symtype n) where \ - hashWithSalt s (symtype v) = s `hashWithSalt` v - -#define HASHABLE_FUN(op, cons) \ -instance (SupportedPrim ca, SupportedPrim cb, LinkedRep ca sa, LinkedRep cb sb) => Hashable (sa op sb) where \ - hashWithSalt s (cons v) = s `hashWithSalt` v - -#define HASHABLE_BV_SOME(somety, origty) \ -instance Hashable somety where \ - s `hashWithSalt` (somety (w :: origty n)) = s `hashWithSalt` natVal (Proxy @n) `hashWithSalt` w - -#if 1 -HASHABLE_SIMPLE(SymBool) -HASHABLE_SIMPLE(SymInteger) -HASHABLE_BV(SymIntN) -HASHABLE_BV(SymWordN) -HASHABLE_FUN(=~>, SymTabularFun) -HASHABLE_FUN(-~>, SymGeneralFun) -HASHABLE_BV_SOME(SomeSymIntN, SymIntN) -HASHABLE_BV_SOME(SomeSymWordN, SymWordN) -#endif - --- Eq - -#define EQ_SIMPLE(symtype) \ -instance Eq symtype where \ - (symtype l) == (symtype r) = l == r - -#define EQ_BV(symtype) \ -instance (KnownNat n, 1 <= n) => Eq (symtype n) where \ - (symtype l) == (symtype r) = l == r - -#define EQ_BV_SOME(symtype, bf) \ -instance Eq symtype where; \ - (==) = bf (==) "=="; \ - {-# INLINE (==) #-}; \ - (/=) = bf (/=) "/="; \ - {-# INLINE (/=) #-} - -#define EQ_FUN(op, cons) \ -instance (SupportedPrim ca, SupportedPrim cb, LinkedRep ca sa, LinkedRep cb sb) => Eq (sa op sb) where \ - (cons l) == (cons r) = l == r - -#if 1 -EQ_SIMPLE(SymBool) -EQ_SIMPLE(SymInteger) -EQ_BV(SymIntN) -EQ_BV(SymWordN) -EQ_FUN(=~>, SymTabularFun) -EQ_FUN(-~>, SymGeneralFun) -EQ_BV_SOME(SomeSymIntN, binSomeSymIntN) -EQ_BV_SOME(SomeSymWordN, binSomeSymWordN) -#endif - --- IsString - -#define IS_STRING_SIMPLE(symtype) \ -instance IsString symtype where \ - fromString = ssym . fromString - -#define IS_STRING_BV(symtype) \ -instance (KnownNat n, 1 <= n) => IsString (symtype n) where \ - fromString = ssym . fromString - -#define IS_STRING_FUN(op, cons) \ -instance (SupportedPrim ca, SupportedPrim cb, LinkedRep ca sa, LinkedRep cb sb) => IsString (sa op sb) where \ - fromString = ssym . fromString - -#if 1 -IS_STRING_SIMPLE(SymBool) -IS_STRING_SIMPLE(SymInteger) -IS_STRING_BV(SymIntN) -IS_STRING_BV(SymWordN) -IS_STRING_FUN(=~>, SymTabularFunc) -IS_STRING_FUN(-~>, SymGeneralFun) -#endif - --- SizedBV - -#define BVCONCAT_SIZED(symtype) \ -sizedBVConcat :: forall l r. (KnownNat l, KnownNat r, 1 <= l, 1 <= r) => symtype l -> symtype r -> symtype (l + r); \ -sizedBVConcat (symtype l) (symtype r) = \ - case (leqAddPos pl pr, knownAdd (KnownProof @l) (KnownProof @r)) of \ - (LeqProof, KnownProof) -> \ - symtype (pevalBVConcatTerm l r); \ - where; \ - pl = Proxy :: Proxy l; \ - pr = Proxy :: Proxy r - -#define BVZEXT_SIZED(symtype) \ -sizedBVZext :: forall l r proxy. (KnownNat l, KnownNat r, 1 <= l, KnownNat r, l <= r) => proxy r -> symtype l -> symtype r; \ -sizedBVZext _ (symtype v) = \ - case leqTrans (LeqProof @1 @l) (LeqProof @l @r) of \ - LeqProof -> symtype $ pevalBVExtendTerm False (Proxy @r) v - -#define BVSEXT_SIZED(symtype) \ -sizedBVSext :: forall l r proxy. (KnownNat l, KnownNat r, 1 <= l, KnownNat r, l <= r) => proxy r -> symtype l -> symtype r; \ -sizedBVSext _ (symtype v) = \ - case leqTrans (LeqProof @1 @l) (LeqProof @l @r) of \ - LeqProof -> symtype $ pevalBVExtendTerm True (Proxy @r) v - -#define BVSELECT_SIZED(symtype) \ -sizedBVSelect :: forall n ix w p q. (KnownNat n, KnownNat ix, KnownNat w, 1 <= n, 1 <= w, ix + w <= n) => \ - p ix -> q w -> symtype n -> symtype w; \ -sizedBVSelect pix pw (symtype v) = symtype $ pevalBVSelectTerm pix pw v - -#if 1 -instance SizedBV SymIntN where - BVCONCAT_SIZED(SymIntN) - BVZEXT_SIZED(SymIntN) - BVSEXT_SIZED(SymIntN) - sizedBVExt = sizedBVSext - BVSELECT_SIZED(SymIntN) - -instance SizedBV SymWordN where - BVCONCAT_SIZED(SymWordN) - BVZEXT_SIZED(SymWordN) - BVSEXT_SIZED(SymWordN) - sizedBVExt = sizedBVZext - BVSELECT_SIZED(SymWordN) -#endif - --- BV - -#define BVCONCAT(somety, origty) \ -bvConcat (somety (a :: origty l)) (somety (b :: origty r)) = \ - case (leqAddPos (Proxy @l) (Proxy @r), knownAdd @l @r KnownProof KnownProof) of \ - (LeqProof, KnownProof) -> \ - somety $ sizedBVConcat a b - -#define BVZEXT(somety, origty) \ -bvZext l (somety (a :: origty n)) \ - | l < n = error "bvZext: trying to zero extend a value to a smaller size" \ - | otherwise = res (Proxy @n) \ - where \ - n = fromIntegral $ natVal (Proxy @n); \ - res :: forall (l :: Nat). Proxy l -> somety; \ - res p = \ - case (unsafeKnownProof @l (fromIntegral l), unsafeLeqProof @1 @l, unsafeLeqProof @n @l) of \ - (KnownProof, LeqProof, LeqProof) -> somety $ sizedBVZext p a - -#define BVSEXT(somety, origty) \ -bvSext l (somety (a :: origty n)) \ - | l < n = error "bvZext: trying to zero extend a value to a smaller size" \ - | otherwise = res (Proxy @n) \ - where \ - n = fromIntegral $ natVal (Proxy @n); \ - res :: forall (l :: Nat). Proxy l -> somety; \ - res p = \ - case (unsafeKnownProof @l (fromIntegral l), unsafeLeqProof @1 @l, unsafeLeqProof @n @l) of \ - (KnownProof, LeqProof, LeqProof) -> somety $ sizedBVSext p a - -#define BVSELECT(somety, origty) \ -bvSelect ix w (somety (a :: origty n)) \ - | ix + w > n = error "bvSelect: trying to select a bitvector outside the bounds of the input" \ - | w == 0 = error "bvSelect: trying to select a bitvector of size 0" \ - | otherwise = res (Proxy @n) (Proxy @n) \ - where \ - n = fromIntegral $ natVal (Proxy @n); \ - res :: forall (w :: Nat) (ix :: Nat). Proxy w -> Proxy ix -> somety; \ - res _ _ = \ - case ( unsafeKnownProof @ix (fromIntegral ix), \ - unsafeKnownProof @w (fromIntegral w), \ - unsafeLeqProof @1 @w, \ - unsafeLeqProof @(ix + w) @n \ - ) of \ - (KnownProof, KnownProof, LeqProof, LeqProof) -> \ - somety $ sizedBVSelect (Proxy @ix) (Proxy @w) a - -#if 1 -instance BV SomeSymIntN where - BVCONCAT(SomeSymIntN, SymIntN) - {-# INLINE bvConcat #-} - BVZEXT(SomeSymIntN, SymIntN) - {-# INLINE bvZext #-} - BVSEXT(SomeSymIntN, SymIntN) - {-# INLINE bvSext #-} - bvExt = bvSext - {-# INLINE bvExt #-} - BVSELECT(SomeSymIntN, SymIntN) - {-# INLINE bvSelect #-} - -instance BV SomeSymWordN where - BVCONCAT(SomeSymWordN, SymWordN) - {-# INLINE bvConcat #-} - BVZEXT(SomeSymWordN, SymWordN) - {-# INLINE bvZext #-} - BVSEXT(SomeSymWordN, SymWordN) - {-# INLINE bvSext #-} - bvExt = bvZext - {-# INLINE bvExt #-} - BVSELECT(SomeSymWordN, SymWordN) - {-# INLINE bvSelect #-} -#endif - --- BVSignConversion - -instance (KnownNat n, 1 <= n) => SignConversion (SymWordN n) (SymIntN n) where - toSigned (SymWordN n) = SymIntN $ pevalToSignedTerm n - toUnsigned (SymIntN n) = SymWordN $ pevalToUnsignedTerm n - -instance SignConversion SomeSymWordN SomeSymIntN where - toSigned (SomeSymWordN n) = SomeSymIntN $ toSigned n - toUnsigned (SomeSymIntN n) = SomeSymWordN $ toUnsigned n - --- SymShift -instance (KnownNat n, 1 <= n) => SymShift (SymWordN n) where - symShift (SymWordN a) (SymWordN s) = SymWordN $ pevalShiftLeftTerm a s - -instance (KnownNat n, 1 <= n) => SymShift (SymIntN n) where - symShift a _ | finiteBitSize a == 1 = a - symShift as@(SymIntN a) (SymIntN s) - | finiteBitSize as == 2 = - SymIntN $ - pevalITETerm - (pevalGeNumTerm s (conTerm 0)) - (pevalShiftLeftTerm a s) - ( pevalITETerm - (pevalEqvTerm s (conTerm (-2))) - ( pevalITETerm - (pevalGeNumTerm a (conTerm 0)) - (conTerm 0) - (conTerm (-1)) - ) - (pevalShiftRightTerm a (pevalUMinusNumTerm s)) - ) - symShift (SymIntN a) (SymIntN s) = - SymIntN $ - pevalITETerm - (pevalGeNumTerm s (conTerm 0)) - (pevalShiftLeftTerm a s) - ( pevalITETerm - (pevalLeNumTerm s (conTerm (-bs))) - (pevalShiftRightTerm a (conTerm bs)) - (pevalShiftRightTerm a (pevalUMinusNumTerm s)) - ) - where - bs = fromIntegral (finiteBitSize (0 :: IntN n)) :: IntN n - --- SymRotate -instance (KnownNat n, 1 <= n) => SymRotate (SymWordN n) where - symRotate (SymWordN a) (SymWordN s) = SymWordN (pevalRotateLeftTerm a s) - -instance (KnownNat n, 1 <= n) => SymRotate (SymIntN n) where - symRotate a _ | finiteBitSize a == 1 = a - symRotate as@(SymIntN a) (SymIntN s) - | finiteBitSize as == 2 = - SymIntN $ - pevalITETerm - ( pevalOrTerm - (pevalEqvTerm s (conTerm 0)) - (pevalEqvTerm s (conTerm (-2))) - ) - a - (pevalRotateLeftTerm a (conTerm 1)) - symRotate as@(SymIntN a) (SymIntN s) = - SymIntN $ - pevalRotateLeftTerm - a - ( pevalModBoundedIntegralTerm - s - (conTerm (fromIntegral $ finiteBitSize as)) - ) - --- ModelRep - --- | A pair of a symbolic constant and its value. --- This is used to build a model from a list of symbolic constants and their values. --- --- >>> buildModel ("a" := (1 :: Integer), "b" := True) :: Model --- Model {a -> 1 :: Integer, b -> True :: Bool} -data ModelSymPair ct st where - (:=) :: (LinkedRep ct st) => st -> ct -> ModelSymPair ct st - -instance ModelRep (ModelSymPair ct st) Model where - buildModel (sym := val) = - case underlyingTerm sym of - SymTerm _ symbol -> insertValue symbol val emptyModel - _ -> error "buildModel: should only use symbolic constants" - --- | Get the sum of the sizes of a list of symbolic terms. --- Duplicate sub-terms are counted for only once. --- --- >>> symsSize [1, "a" :: SymInteger, "a" + 1 :: SymInteger] --- 3 -symsSize :: forall con sym. (LinkedRep con sym) => [sym] -> Int -symsSize = termsSize . fmap (underlyingTerm @con) -{-# INLINE symsSize #-} - --- | Get the size of a symbolic term. --- Duplicate sub-terms are counted for only once. --- --- >>> symSize (1 :: SymInteger) --- 1 --- >>> symSize ("a" :: SymInteger) --- 1 --- >>> symSize ("a" + 1 :: SymInteger) --- 3 --- >>> symSize (("a" + 1) * ("a" + 1) :: SymInteger) --- 4 -symSize :: forall con sym. (LinkedRep con sym) => sym -> Int -symSize = termSize . underlyingTerm @con -{-# INLINE symSize #-} - --- | Some symbolic value with 'LinkedRep' constraint. -data SomeSym where - SomeSym :: (LinkedRep con sym) => sym -> SomeSym - -someUnderlyingTerm :: SomeSym -> SomeTerm -someUnderlyingTerm (SomeSym s) = SomeTerm $ underlyingTerm s - -someSymsSize :: [SomeSym] -> Int -someSymsSize = someTermsSize . fmap someUnderlyingTerm -{-# INLINE someSymsSize #-} - --- | Extract all symbolic primitive values that are represented as SMT terms. --- --- __Note:__ This type class can be derived for algebraic data types. You may --- need the @DerivingVia@ and @DerivingStrategies@ extenstions. --- --- > data X = ... deriving Generic deriving AllSyms via (Default X) -class AllSyms a where - -- | Convert a value to a list of symbolic primitive values. It should - -- prepend to an existing list of symbolic primitive values. - allSymsS :: a -> [SomeSym] -> [SomeSym] - allSymsS a l = allSyms a ++ l - - -- | Specialized 'allSymsS' that prepends to an empty list. - allSyms :: a -> [SomeSym] - allSyms a = allSymsS a [] - - {-# MINIMAL allSymsS | allSyms #-} - --- | Get the total size of symbolic terms in a value. --- Duplicate sub-terms are counted for only once. --- --- >>> allSymsSize ("a" :: SymInteger, "a" + "b" :: SymInteger, ("a" + "b") * "c" :: SymInteger) --- 5 -allSymsSize :: (AllSyms a) => a -> Int -allSymsSize = someSymsSize . allSyms - -class AllSyms' a where - allSymsS' :: a c -> [SomeSym] -> [SomeSym] - -instance (Generic a, AllSyms' (Rep a)) => AllSyms (Default a) where - allSymsS = allSymsS' . from . unDefault - -instance AllSyms' U1 where - allSymsS' _ = id - -instance (AllSyms c) => AllSyms' (K1 i c) where - allSymsS' (K1 v) = allSymsS v - -instance (AllSyms' a) => AllSyms' (M1 i c a) where - allSymsS' (M1 v) = allSymsS' v - -instance (AllSyms' a, AllSyms' b) => AllSyms' (a :+: b) where - allSymsS' (L1 l) = allSymsS' l - allSymsS' (R1 r) = allSymsS' r - -instance (AllSyms' a, AllSyms' b) => AllSyms' (a :*: b) where - allSymsS' (a :*: b) = allSymsS' a . allSymsS' b - -#define CONCRETE_ALLSYMS(type) \ -instance AllSyms type where \ - allSymsS _ = id - -#define ALLSYMS_SIMPLE(t) \ -instance AllSyms t where \ - allSymsS v = (SomeSym v :) - -#define ALLSYMS_BV(t) \ -instance (KnownNat n, 1 <= n) => AllSyms (t n) where \ - allSymsS v = (SomeSym v :) - -#define ALLSYMS_SOME_BV(t) \ -instance AllSyms t where \ - allSymsS (t v) = (SomeSym v :) - -#define ALLSYMS_FUN(op) \ -instance (SupportedPrim ca, SupportedPrim cb, LinkedRep ca sa, LinkedRep cb sb) => AllSyms (sa op sb) where \ - allSymsS v = (SomeSym v :) - -#if 1 -CONCRETE_ALLSYMS(Bool) -CONCRETE_ALLSYMS(Integer) -CONCRETE_ALLSYMS(Char) -CONCRETE_ALLSYMS(Int) -CONCRETE_ALLSYMS(Int8) -CONCRETE_ALLSYMS(Int16) -CONCRETE_ALLSYMS(Int32) -CONCRETE_ALLSYMS(Int64) -CONCRETE_ALLSYMS(Word) -CONCRETE_ALLSYMS(Word8) -CONCRETE_ALLSYMS(Word16) -CONCRETE_ALLSYMS(Word32) -CONCRETE_ALLSYMS(Word64) -CONCRETE_ALLSYMS(B.ByteString) -CONCRETE_ALLSYMS(T.Text) -ALLSYMS_SIMPLE(SymBool) -ALLSYMS_SIMPLE(SymInteger) -ALLSYMS_BV(SymIntN) -ALLSYMS_BV(SymWordN) -ALLSYMS_SOME_BV(SomeSymIntN) -ALLSYMS_SOME_BV(SomeSymWordN) -ALLSYMS_FUN(=~>) -ALLSYMS_FUN(-~>) -#endif - -instance AllSyms () where - allSymsS _ = id - --- Either -deriving via - (Default (Either a b)) - instance - ( AllSyms a, - AllSyms b - ) => - AllSyms (Either a b) - --- Maybe -deriving via (Default (Maybe a)) instance (AllSyms a) => AllSyms (Maybe a) - --- List -deriving via (Default [a]) instance (AllSyms a) => AllSyms [a] - --- (,) -deriving via - (Default (a, b)) - instance - (AllSyms a, AllSyms b) => - AllSyms (a, b) - --- (,,) -deriving via - (Default (a, b, c)) - instance - ( AllSyms a, - AllSyms b, - AllSyms c - ) => - AllSyms (a, b, c) - --- (,,,) -deriving via - (Default (a, b, c, d)) - instance - ( AllSyms a, - AllSyms b, - AllSyms c, - AllSyms d - ) => - AllSyms (a, b, c, d) - --- (,,,,) -deriving via - (Default (a, b, c, d, e)) - instance - ( AllSyms a, - AllSyms b, - AllSyms c, - AllSyms d, - AllSyms e - ) => - AllSyms (a, b, c, d, e) - --- (,,,,,) -deriving via - (Default (a, b, c, d, e, f)) - instance - ( AllSyms a, - AllSyms b, - AllSyms c, - AllSyms d, - AllSyms e, - AllSyms f - ) => - AllSyms (a, b, c, d, e, f) - --- (,,,,,,) -deriving via - (Default (a, b, c, d, e, f, g)) - instance - ( AllSyms a, - AllSyms b, - AllSyms c, - AllSyms d, - AllSyms e, - AllSyms f, - AllSyms g - ) => - AllSyms (a, b, c, d, e, f, g) - --- (,,,,,,,) -deriving via - (Default (a, b, c, d, e, f, g, h)) - instance - ( AllSyms a, - AllSyms b, - AllSyms c, - AllSyms d, - AllSyms e, - AllSyms f, - AllSyms g, - AllSyms h - ) => - AllSyms ((,,,,,,,) a b c d e f g h) - --- MaybeT -instance - (AllSyms (m (Maybe a))) => - AllSyms (MaybeT m a) - where - allSymsS (MaybeT v) = allSymsS v - --- ExceptT -instance - (AllSyms (m (Either e a))) => - AllSyms (ExceptT e m a) - where - allSymsS (ExceptT v) = allSymsS v - --- Sum -deriving via - (Default (Sum f g a)) - instance - (AllSyms (f a), AllSyms (g a)) => - AllSyms (Sum f g a) - --- WriterT -instance - (AllSyms (m (a, s))) => - AllSyms (WriterLazy.WriterT s m a) - where - allSymsS (WriterLazy.WriterT v) = allSymsS v - -instance - (AllSyms (m (a, s))) => - AllSyms (WriterStrict.WriterT s m a) - where - allSymsS (WriterStrict.WriterT v) = allSymsS v - --- Identity -instance (AllSyms a) => AllSyms (Identity a) where - allSymsS (Identity a) = allSymsS a - --- IdentityT -instance (AllSyms (m a)) => AllSyms (IdentityT m a) where - allSymsS (IdentityT a) = allSymsS a - --- VerificationConditions -deriving via (Default VerificationConditions) instance AllSyms VerificationConditions - --- AssertionError -deriving via (Default AssertionError) instance AllSyms AssertionError diff --git a/src/Grisette/IR/SymPrim/Data/TabularFun.hs b/src/Grisette/IR/SymPrim/Data/TabularFun.hs deleted file mode 100644 --- a/src/Grisette/IR/SymPrim/Data/TabularFun.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - --- | --- Module : Grisette.IR.SymPrim.Data.TabularFun --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.IR.SymPrim.Data.TabularFun - ( type (=->) (..), - ) -where - -import Control.DeepSeq (NFData, NFData1) -import Data.Hashable (Hashable) -import GHC.Generics (Generic, Generic1) -import Grisette.Core.Data.Class.Function (Function (Arg, Ret, (#))) -import Language.Haskell.TH.Syntax (Lift) - --- $setup --- >>> import Grisette.Core --- >>> import Grisette.IR.SymPrim - --- | --- Functions as a table. Use the `#` operator to apply the function. --- --- >>> :set -XTypeOperators --- >>> let f = TabularFun [(1, 2), (3, 4)] 0 :: Int =-> Int --- >>> f # 1 --- 2 --- >>> f # 2 --- 0 --- >>> f # 3 --- 4 -data (=->) a b = TabularFun {funcTable :: [(a, b)], defaultFuncValue :: b} - deriving (Show, Eq, Generic, Generic1, Lift, NFData, NFData1) - -infixr 0 =-> - -instance (Eq a) => Function (a =-> b) where - type Arg (a =-> b) = a - type Ret (a =-> b) = b - (TabularFun table d) # a = go table - where - go [] = d - go ((av, bv) : s) - | a == av = bv - | otherwise = go s - -instance (Hashable a, Hashable b) => Hashable (a =-> b) diff --git a/src/Grisette/Internal/Backend/SBV.hs b/src/Grisette/Internal/Backend/SBV.hs deleted file mode 100644 --- a/src/Grisette/Internal/Backend/SBV.hs +++ /dev/null @@ -1,20 +0,0 @@ --- | --- Module : Grisette.Internal.Backend.SBV --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Internal.Backend.SBV - ( lowerSinglePrim, - parseModel, - TermTy, - ) -where - -import Grisette.Backend.SBV.Data.SMT.Lowering - ( lowerSinglePrim, - parseModel, - ) -import Grisette.Backend.SBV.Data.SMT.Solving (TermTy) diff --git a/src/Grisette/Internal/Backend/Solving.hs b/src/Grisette/Internal/Backend/Solving.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Backend/Solving.hs @@ -0,0 +1,708 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Backend.Solving +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Backend.Solving + ( -- * SBV backend configuration + ApproximationConfig (..), + ExtraConfig (..), + precise, + approx, + withTimeout, + clearTimeout, + withApprox, + clearApprox, + GrisetteSMTConfig (..), + + -- * SBV monadic solver interface + SBVIncrementalT, + SBVIncremental, + runSBVIncrementalT, + runSBVIncremental, + + -- * SBV solver handle + SBVSolverHandle, + + -- * Internal lowering functions + lowerSinglePrimCached, + lowerSinglePrim, + parseModel, + ) +where + +import Control.Concurrent.Async (Async (asyncThreadId), async, wait) +import Control.Concurrent.STM + ( TMVar, + atomically, + newTMVarIO, + putTMVar, + takeTMVar, + tryReadTMVar, + tryTakeTMVar, + ) +import Control.Concurrent.STM.TChan (TChan, newTChan, readTChan, writeTChan) +import Control.Exception (handle, throwTo) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Reader + ( MonadReader (ask), + MonadTrans (lift), + ReaderT (runReaderT), + ) +import Control.Monad.STM (STM) +import Control.Monad.State (MonadState (get, put), StateT, evalStateT) +import Data.Dynamic (fromDyn, toDyn) +import Data.Proxy (Proxy (Proxy)) +import qualified Data.SBV as SBV +import qualified Data.SBV.Control as SBVC +import qualified Data.SBV.Dynamic as SBVD +import qualified Data.SBV.Internals as SBVI +import qualified Data.SBV.Trans as SBVT +import qualified Data.SBV.Trans.Control as SBVTC +import GHC.IO.Exception (ExitCode (ExitSuccess)) +import GHC.Stack (HasCallStack) +import GHC.TypeNats (KnownNat, Nat) +import Grisette.Internal.Backend.SymBiMap + ( SymBiMap, + addBiMap, + addBiMapIntermediate, + emptySymBiMap, + findStringToSymbol, + lookupTerm, + sizeBiMap, + ) +import Grisette.Internal.Core.Data.Class.ModelOps (ModelOps (emptyModel, insertValue)) +import Grisette.Internal.Core.Data.Class.Solver + ( ConfigurableSolver (newSolver), + MonadicSolver + ( monadicSolverPop, + monadicSolverPush, + monadicSolverSolve + ), + Solver + ( solverForceTerminate, + solverRunCommand, + solverSolve, + solverTerminate + ), + SolverCommand (SolverPop, SolverPush, SolverSolve, SolverTerminate), + SolvingFailure (SolvingError, Terminated, Unk, Unsat), + ) +import Grisette.Internal.SymPrim.Prim.Internal.IsZero (KnownIsZero) +import Grisette.Internal.SymPrim.Prim.Internal.Term + ( PEvalApplyTerm (sbvApplyTerm), + PEvalBVSignConversionTerm (sbvToSigned, sbvToUnsigned), + PEvalBVTerm (sbvBVConcatTerm, sbvBVExtendTerm, sbvBVSelectTerm), + PEvalBitwiseTerm + ( sbvAndBitsTerm, + sbvComplementBitsTerm, + sbvOrBitsTerm, + sbvXorBitsTerm + ), + PEvalDivModIntegralTerm + ( sbvDivIntegralTerm, + sbvModIntegralTerm, + sbvQuotIntegralTerm, + sbvRemIntegralTerm + ), + PEvalNumTerm + ( sbvAbsNumTerm, + sbvAddNumTerm, + sbvMulNumTerm, + sbvNegNumTerm, + sbvSignumNumTerm + ), + PEvalOrdTerm (sbvLeOrdTerm, sbvLtOrdTerm), + PEvalRotateTerm (sbvRotateLeftTerm, sbvRotateRightTerm), + PEvalShiftTerm (sbvShiftLeftTerm, sbvShiftRightTerm), + SBVFreshMonad, + SBVRep (SBVType), + SomeTypedSymbol (SomeTypedSymbol), + SupportedPrim + ( conSBVTerm, + parseSMTModelResult, + sbvEq, + sbvIte, + symSBVName, + symSBVTerm, + withPrim + ), + Term + ( AbsNumTerm, + AddNumTerm, + AndBitsTerm, + AndTerm, + ApplyTerm, + BVConcatTerm, + BVExtendTerm, + BVSelectTerm, + ComplementBitsTerm, + ConTerm, + DivIntegralTerm, + EqTerm, + ITETerm, + LeOrdTerm, + LtOrdTerm, + ModIntegralTerm, + MulNumTerm, + NegNumTerm, + NotTerm, + OrBitsTerm, + OrTerm, + QuotIntegralTerm, + RemIntegralTerm, + RotateLeftTerm, + RotateRightTerm, + ShiftLeftTerm, + ShiftRightTerm, + SignumNumTerm, + SymTerm, + ToSignedTerm, + ToUnsignedTerm, + XorBitsTerm + ), + introSupportedPrimConstraint, + someTypedSymbol, + withSymbolSupported, + ) +import Grisette.Internal.SymPrim.Prim.Model as PM + ( Model, + ) +import Grisette.Internal.SymPrim.Prim.SomeTerm (SomeTerm (SomeTerm)) +import Grisette.Internal.SymPrim.SymBool (SymBool (SymBool)) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim +-- >>> import Grisette.Backend +-- >>> import Data.Proxy + +-- | Configures how to approximate unbounded values. +-- +-- For example, if we use @'Approx' ('Data.Proxy' :: 'Data.Proxy' 4)@ to +-- approximate the following unbounded integer: +-- +-- > (+ a 9) +-- +-- We will get +-- +-- > (bvadd a #x9) +-- +-- Here the value 9 will be approximated to a 4-bit bit vector, and the +-- operation `bvadd` will be used instead of `+`. +-- +-- Note that this approximation may not be sound. See 'GrisetteSMTConfig' for +-- more details. +data ApproximationConfig (n :: Nat) where + NoApprox :: ApproximationConfig 0 + Approx :: + (KnownNat n, SBV.BVIsNonZero n, KnownIsZero n) => + p n -> + ApproximationConfig n + +-- | Grisette specific extra configurations for the SBV backend. +data ExtraConfig (i :: Nat) = ExtraConfig + { -- | Timeout in milliseconds for each solver call. CEGIS may call the + -- solver multiple times and each call has its own timeout. + timeout :: Maybe Int, + -- | Configures how to approximate unbounded integer values. + integerApprox :: ApproximationConfig i + } + +preciseExtraConfig :: ExtraConfig 0 +preciseExtraConfig = + ExtraConfig + { timeout = Nothing, + integerApprox = NoApprox + } + +approximateExtraConfig :: + (KnownNat n, SBV.BVIsNonZero n, KnownIsZero n) => + p n -> + ExtraConfig n +approximateExtraConfig p = + ExtraConfig + { timeout = Nothing, + integerApprox = Approx p + } + +-- | Solver configuration for the Grisette SBV backend. +-- A Grisette solver configuration consists of a SBV solver configuration and +-- the reasoning precision. +-- +-- Integers can be unbounded (mathematical integer) or bounded (machine +-- integer/bit vector). The two types of integers have their own use cases, +-- and should be used to model different systems. +-- However, the solvers are known to have bad performance on some unbounded +-- integer operations, for example, when reason about non-linear integer +-- algebraic (e.g., multiplication or division), +-- the solver may not be able to get a result in a reasonable time. +-- In contrast, reasoning about bounded integers is usually more efficient. +-- +-- To bridge the performance gap between the two types of integers, Grisette +-- allows to model the system with unbounded integers, and evaluate them with +-- infinite precision during the symbolic evaluation, but when solving the +-- queries, they are translated to bit vectors for better performance. +-- +-- For example, the Grisette term @5 * "a" :: 'SymInteger'@ should be translated +-- to the following SMT with the unbounded reasoning configuration (the term +-- is @t1@): +-- +-- > (declare-fun a () Int) ; declare symbolic constant a +-- > (define-fun c1 () Int 5) ; define the concrete value 5 +-- > (define-fun t1 () Int (* c1 a)) ; define the term +-- +-- While with reasoning precision 4, it would be translated to the following +-- SMT (the term is @t1@): +-- +-- > ; declare symbolic constant a, the type is a bit vector with bit width 4 +-- > (declare-fun a () (_ BitVec 4)) +-- > ; define the concrete value 1, translated to the bit vector #x1 +-- > (define-fun c1 () (_ BitVec 4) #x5) +-- > ; define the term, using bit vector addition rather than integer addition +-- > (define-fun t1 () (_ BitVec 4) (bvmul c1 a)) +-- +-- This bounded translation can usually be solved faster than the unbounded +-- one, and should work well when no overflow is possible, in which case the +-- performance can be improved with almost no cost. +-- +-- We must note that the bounded translation is an approximation and is +-- __/not sound/__. As the approximation happens only during the final +-- translation, the symbolic evaluation may aggressively optimize the term based +-- on the properties of mathematical integer arithmetic. This may cause the +-- solver yield results that is incorrect under both unbounded or bounded +-- semantics. +-- +-- The following is an example that is correct under bounded semantics, while is +-- incorrect under the unbounded semantics: +-- +-- >>> :set -XTypeApplications -XOverloadedStrings -XDataKinds +-- >>> let a = "a" :: SymInteger +-- >>> solve (precise z3) $ a .> 7 .&& a .< 9 +-- Right (Model {a -> 8 :: Integer}) +-- >>> solve (approx (Proxy @4) z3) $ a .> 7 .&& a .< 9 +-- Left Unsat +-- +-- This may be avoided by setting an large enough reasoning precision to prevent +-- overflows. +data GrisetteSMTConfig (i :: Nat) = GrisetteSMTConfig + { sbvConfig :: SBV.SMTConfig, + extraConfig :: ExtraConfig i + } + +-- | A precise reasoning configuration with the given SBV solver configuration. +precise :: SBV.SMTConfig -> GrisetteSMTConfig 0 +precise config = GrisetteSMTConfig config preciseExtraConfig + +-- | An approximate reasoning configuration with the given SBV solver +-- configuration. +approx :: + forall p n. + (KnownNat n, SBV.BVIsNonZero n, KnownIsZero n) => + p n -> + SBV.SMTConfig -> + GrisetteSMTConfig n +approx p config = GrisetteSMTConfig config (approximateExtraConfig p) + +-- | Set the timeout for the solver configuration. +withTimeout :: Int -> GrisetteSMTConfig i -> GrisetteSMTConfig i +withTimeout t config = + config {extraConfig = (extraConfig config) {timeout = Just t}} + +-- | Clear the timeout for the solver configuration. +clearTimeout :: GrisetteSMTConfig i -> GrisetteSMTConfig i +clearTimeout config = + config {extraConfig = (extraConfig config) {timeout = Nothing}} + +-- | Set the reasoning precision for the solver configuration. +withApprox :: + (KnownNat n, SBV.BVIsNonZero n, KnownIsZero n) => + p n -> + GrisetteSMTConfig i -> + GrisetteSMTConfig n +withApprox p config = + config {extraConfig = (extraConfig config) {integerApprox = Approx p}} + +-- | Clear the reasoning precision and perform precise reasoning with the +-- solver configuration. +clearApprox :: GrisetteSMTConfig i -> GrisetteSMTConfig 0 +clearApprox config = + config {extraConfig = (extraConfig config) {integerApprox = NoApprox}} + +sbvCheckSatResult :: SBVC.CheckSatResult -> SolvingFailure +sbvCheckSatResult SBVC.Sat = error "Should not happen" +sbvCheckSatResult (SBVC.DSat _) = error "DSat is currently not supported" +sbvCheckSatResult SBVC.Unsat = Unsat +sbvCheckSatResult SBVC.Unk = Unk + +-- | Apply the timeout to the configuration. +applyTimeout :: + (MonadIO m, SBVTC.MonadQuery m) => GrisetteSMTConfig i -> m a -> m a +applyTimeout config q = case timeout (extraConfig config) of + Nothing -> q + Just t -> SBVTC.timeout t q + +-- | Incremental solver monad transformer with the SBV backend. +type SBVIncrementalT n m = + ReaderT (GrisetteSMTConfig n) (StateT SymBiMap (SBVTC.QueryT m)) + +-- | Incremental solver monad with the SBV backend. +type SBVIncremental n = SBVIncrementalT n IO + +-- | Run the incremental solver monad with a given configuration. +runSBVIncremental :: GrisetteSMTConfig n -> SBVIncremental n a -> IO a +runSBVIncremental = runSBVIncrementalT + +-- | Run the incremental solver monad transformer with a given configuration. +runSBVIncrementalT :: + (SBVTC.ExtractIO m) => + GrisetteSMTConfig n -> + SBVIncrementalT n m a -> + m a +runSBVIncrementalT config sbvIncrementalT = + SBVT.runSMTWith (sbvConfig config) $ + SBVTC.query $ + applyTimeout config $ + flip evalStateT emptySymBiMap $ + runReaderT sbvIncrementalT config + +instance (MonadIO m) => MonadicSolver (SBVIncrementalT n m) where + monadicSolverSolve (SymBool formula) = do + symBiMap <- get + config <- ask + (newSymBiMap, lowered) <- lowerSinglePrimCached config formula symBiMap + lift $ lift $ SBV.constrain lowered + put newSymBiMap + checkSatResult <- SBVTC.checkSat + case checkSatResult of + SBVC.Sat -> do + sbvModel <- SBVTC.getModel + let model = parseModel config sbvModel newSymBiMap + return $ Right model + r -> return $ Left $ sbvCheckSatResult r + monadicSolverPush = SBVTC.push + monadicSolverPop = SBVTC.pop + +data SBVSolverStatus = SBVSolverNormal | SBVSolverTerminated + +-- | The handle type for the SBV solver. +-- +-- See 'ConfigurableSolver' and 'Solver' for the interfaces. +data SBVSolverHandle = SBVSolverHandle + { sbvSolverHandleMonad :: Async (), + sbvSolverHandleStatus :: TMVar SBVSolverStatus, + sbvSolverHandleInChan :: TChan SolverCommand, + sbvSolverHandleOutChan :: TChan (Either SolvingFailure Model) + } + +setTerminated :: TMVar SBVSolverStatus -> STM () +setTerminated status = do + _ <- tryTakeTMVar status + putTMVar status SBVSolverTerminated + +instance ConfigurableSolver (GrisetteSMTConfig n) SBVSolverHandle where + newSolver config = do + sbvSolverHandleInChan <- atomically newTChan + sbvSolverHandleOutChan <- atomically newTChan + sbvSolverHandleStatus <- newTMVarIO SBVSolverNormal + sbvSolverHandleMonad <- async $ do + let handler e = + liftIO $ + atomically $ do + setTerminated sbvSolverHandleStatus + writeTChan sbvSolverHandleOutChan (Left (SolvingError e)) + handle handler $ runSBVIncremental config $ do + let loop = do + nextFormula <- liftIO $ atomically $ readTChan sbvSolverHandleInChan + case nextFormula of + SolverPush n -> monadicSolverPush n >> loop + SolverPop n -> monadicSolverPop n >> loop + SolverTerminate -> return () + SolverSolve formula -> do + r <- monadicSolverSolve formula + liftIO $ atomically $ writeTChan sbvSolverHandleOutChan r + loop + loop + liftIO $ atomically $ do + setTerminated sbvSolverHandleStatus + writeTChan sbvSolverHandleOutChan $ Left Terminated + return $ SBVSolverHandle {..} + +instance Solver SBVSolverHandle where + solverRunCommand f handle@(SBVSolverHandle _ status inChan _) command = do + st <- liftIO $ atomically $ takeTMVar status + case st of + SBVSolverNormal -> do + liftIO $ atomically $ writeTChan inChan command + r <- f handle + liftIO $ atomically $ do + currStatus <- tryReadTMVar status + case currStatus of + Nothing -> putTMVar status SBVSolverNormal + Just _ -> return () + return r + SBVSolverTerminated -> do + liftIO $ atomically $ setTerminated status + return $ Left Terminated + solverSolve handle nextFormula = + solverRunCommand + ( \(SBVSolverHandle _ _ _ outChan) -> + liftIO $ atomically $ readTChan outChan + ) + handle + $ SolverSolve nextFormula + solverTerminate (SBVSolverHandle thread status inChan _) = do + liftIO $ atomically $ do + setTerminated status + writeTChan inChan SolverTerminate + wait thread + solverForceTerminate (SBVSolverHandle thread status _ outChan) = do + liftIO $ atomically $ do + setTerminated status + writeTChan outChan (Left Terminated) + throwTo (asyncThreadId thread) ExitSuccess + wait thread + +configIntroKnownIsZero :: GrisetteSMTConfig n -> ((KnownIsZero n) => r) -> r +configIntroKnownIsZero (GrisetteSMTConfig _ (ExtraConfig _ (Approx _))) r = r +configIntroKnownIsZero (GrisetteSMTConfig _ (ExtraConfig _ NoApprox)) r = r + +lowerSinglePrimCached :: + forall integerBitWidth a m. + (HasCallStack, SBVFreshMonad m) => + GrisetteSMTConfig integerBitWidth -> + Term a -> + SymBiMap -> + m (SymBiMap, SBVType integerBitWidth a) +lowerSinglePrimCached config t m = + introSupportedPrimConstraint t $ + configIntroKnownIsZero config $ + case lookupTerm (SomeTerm t) m of + Just x -> + return + ( m, + withPrim @a (Proxy @integerBitWidth) $ fromDyn x undefined + ) + Nothing -> lowerSinglePrimImpl config t m + +lowerSinglePrim :: + forall integerBitWidth a m. + (HasCallStack, SBVFreshMonad m) => + GrisetteSMTConfig integerBitWidth -> + Term a -> + m (SymBiMap, SBVType integerBitWidth a) +lowerSinglePrim config t = lowerSinglePrimCached config t emptySymBiMap + +lowerSinglePrimImpl :: + forall integerBitWidth a m. + (HasCallStack, SBVFreshMonad m, KnownIsZero integerBitWidth) => + GrisetteSMTConfig integerBitWidth -> + Term a -> + SymBiMap -> + m (SymBiMap, SBVType integerBitWidth a) +lowerSinglePrimImpl config (ConTerm _ v) m = + return (m, conSBVTerm config v) +lowerSinglePrimImpl config t@(SymTerm _ ts) m = + withPrim @a config $ do + let name = symSBVName ts (sizeBiMap m) + g <- symSBVTerm @a config name + return (addBiMap (SomeTerm t) (toDyn g) name (someTypedSymbol ts) m, g) +lowerSinglePrimImpl config t m = + introSupportedPrimConstraint t $ + withPrim @a config $ do + (m, r) <- lowerSinglePrimIntermediate config t m + return (addBiMapIntermediate (SomeTerm t) (toDyn r) m, r) + +lowerSinglePrimIntermediate :: + forall integerBitWidth a m. + (HasCallStack, SBVFreshMonad m, KnownIsZero integerBitWidth) => + GrisetteSMTConfig integerBitWidth -> + Term a -> + SymBiMap -> + m (SymBiMap, SBVType integerBitWidth a) +lowerSinglePrimIntermediate config (NotTerm _ a) m = do + (m1, a') <- lowerSinglePrimCached config a m + return (m1, SBV.sNot a') +lowerSinglePrimIntermediate config (OrTerm _ a b) m = do + (m1, a') <- lowerSinglePrimCached config a m + (m2, b') <- lowerSinglePrimCached config b m1 + return (m2, a' SBV..|| b') +lowerSinglePrimIntermediate config (AndTerm _ a b) m = do + (m1, a') <- lowerSinglePrimCached config a m + (m2, b') <- lowerSinglePrimCached config b m1 + return (m2, a' SBV..&& b') +lowerSinglePrimIntermediate config (EqTerm _ (a :: Term v) b) m = do + (m1, a') <- lowerSinglePrimCached config a m + (m2, b') <- lowerSinglePrimCached config b m1 + return (m2, sbvEq @v config a' b') +lowerSinglePrimIntermediate config (ITETerm _ c a b) m = do + (m1, c') <- lowerSinglePrimCached config c m + (m2, a') <- lowerSinglePrimCached config a m1 + (m3, b') <- lowerSinglePrimCached config b m2 + return (m3, sbvIte @a config c' a' b') +lowerSinglePrimIntermediate config (AddNumTerm _ a b) m = do + (m1, a') <- lowerSinglePrimCached config a m + (m2, b') <- lowerSinglePrimCached config b m1 + return (m2, sbvAddNumTerm @a config a' b') +lowerSinglePrimIntermediate config (NegNumTerm _ a) m = do + (m1, a') <- lowerSinglePrimCached config a m + return (m1, sbvNegNumTerm @a config a') +lowerSinglePrimIntermediate config (MulNumTerm _ a b) m = do + (m1, a') <- lowerSinglePrimCached config a m + (m2, b') <- lowerSinglePrimCached config b m1 + return (m2, sbvMulNumTerm @a config a' b') +lowerSinglePrimIntermediate config (AbsNumTerm _ a) m = do + (m1, a') <- lowerSinglePrimCached config a m + return (m1, sbvAbsNumTerm @a config a') +lowerSinglePrimIntermediate config (SignumNumTerm _ a) m = do + (m1, a') <- lowerSinglePrimCached config a m + return (m1, sbvSignumNumTerm @a config a') +lowerSinglePrimIntermediate config (LtOrdTerm _ (a :: Term v) b) m = do + (m1, a') <- lowerSinglePrimCached config a m + (m2, b') <- lowerSinglePrimCached config b m1 + return (m2, sbvLtOrdTerm @v config a' b') +lowerSinglePrimIntermediate config (LeOrdTerm _ (a :: Term v) b) m = do + (m1, a') <- lowerSinglePrimCached config a m + (m2, b') <- lowerSinglePrimCached config b m1 + return (m2, sbvLeOrdTerm @v config a' b') +lowerSinglePrimIntermediate config (AndBitsTerm _ a b) m = do + (m1, a') <- lowerSinglePrimCached config a m + (m2, b') <- lowerSinglePrimCached config b m1 + return (m2, sbvAndBitsTerm @a config a' b') +lowerSinglePrimIntermediate config (OrBitsTerm _ a b) m = do + (m1, a') <- lowerSinglePrimCached config a m + (m2, b') <- lowerSinglePrimCached config b m1 + return (m2, sbvOrBitsTerm @a config a' b') +lowerSinglePrimIntermediate config (XorBitsTerm _ a b) m = do + (m1, a') <- lowerSinglePrimCached config a m + (m2, b') <- lowerSinglePrimCached config b m1 + return (m2, sbvXorBitsTerm @a config a' b') +lowerSinglePrimIntermediate config (ComplementBitsTerm _ a) m = do + (m1, a') <- lowerSinglePrimCached config a m + return (m1, sbvComplementBitsTerm @a config a') +lowerSinglePrimIntermediate config (ShiftLeftTerm _ a b) m = do + (m1, a') <- lowerSinglePrimCached config a m + (m2, b') <- lowerSinglePrimCached config b m1 + return (m2, sbvShiftLeftTerm @a config a' b') +lowerSinglePrimIntermediate config (ShiftRightTerm _ a b) m = do + (m1, a') <- lowerSinglePrimCached config a m + (m2, b') <- lowerSinglePrimCached config b m1 + return (m2, sbvShiftRightTerm @a config a' b') +lowerSinglePrimIntermediate config (RotateLeftTerm _ a b) m = do + (m1, a') <- lowerSinglePrimCached config a m + (m2, b') <- lowerSinglePrimCached config b m1 + return (m2, sbvRotateLeftTerm @a config a' b') +lowerSinglePrimIntermediate config (RotateRightTerm _ a b) m = do + (m1, a') <- lowerSinglePrimCached config a m + (m2, b') <- lowerSinglePrimCached config b m1 + return (m2, sbvRotateRightTerm @a config a' b') +lowerSinglePrimIntermediate config (ApplyTerm _ (f :: Term f) a) m = do + (m1, l1) <- lowerSinglePrimCached config f m + (m2, l2) <- lowerSinglePrimCached config a m1 + return (m2, sbvApplyTerm @f config l1 l2) +lowerSinglePrimIntermediate config (ToSignedTerm _ (a :: Term (u n))) m = do + (m1, a') <- lowerSinglePrimCached config a m + return (m1, sbvToSigned (Proxy @u) (Proxy @n) config a') +lowerSinglePrimIntermediate config (ToUnsignedTerm _ (a :: Term (s n))) m = do + (m1, a') <- lowerSinglePrimCached config a m + return (m1, sbvToUnsigned (Proxy @s) (Proxy @n) config a') +lowerSinglePrimIntermediate + config + (BVConcatTerm _ (a :: Term (bv l)) (b :: Term (bv r))) + m = do + (m1, a') <- lowerSinglePrimCached config a m + (m2, b') <- lowerSinglePrimCached config b m1 + return (m2, sbvBVConcatTerm @bv config (Proxy @l) (Proxy @r) a' b') +lowerSinglePrimIntermediate + config + (BVExtendTerm _ signed (pr :: p r) (a :: Term (bv l))) + m = do + (m1, a') <- lowerSinglePrimCached config a m + return (m1, sbvBVExtendTerm @bv config (Proxy @l) pr signed a') +lowerSinglePrimIntermediate + config + (BVSelectTerm _ (pix :: p ix) (pw :: q w) (a :: Term (bv n))) + m = do + (m1, a') <- lowerSinglePrimCached config a m + return (m1, sbvBVSelectTerm @bv config pix pw (Proxy @n) a') +lowerSinglePrimIntermediate config (DivIntegralTerm _ a b) m = do + (m1, a') <- lowerSinglePrimCached config a m + (m2, b') <- lowerSinglePrimCached config b m1 + return (m2, sbvDivIntegralTerm @a config a' b') +lowerSinglePrimIntermediate config (ModIntegralTerm _ a b) m = do + (m1, a') <- lowerSinglePrimCached config a m + (m2, b') <- lowerSinglePrimCached config b m1 + return (m2, sbvModIntegralTerm @a config a' b') +lowerSinglePrimIntermediate config (QuotIntegralTerm _ a b) m = do + (m1, a') <- lowerSinglePrimCached config a m + (m2, b') <- lowerSinglePrimCached config b m1 + return (m2, sbvQuotIntegralTerm @a config a' b') +lowerSinglePrimIntermediate config (RemIntegralTerm _ a b) m = do + (m1, a') <- lowerSinglePrimCached config a m + (m2, b') <- lowerSinglePrimCached config b m1 + return (m2, sbvRemIntegralTerm @a config a' b') +lowerSinglePrimIntermediate _ _ _ = undefined + +#if MIN_VERSION_sbv(10,3,0) +preprocessUIFuncs :: + [(String, (Bool, ty, Either String ([([SBVD.CV], SBVD.CV)], SBVD.CV)))] -> + Maybe [(String, ([([SBVD.CV], SBVD.CV)], SBVD.CV))] +preprocessUIFuncs = + traverse + (\v -> case v of + (a, (_, _, Right c)) -> Just (a, c) + _ -> Nothing) +#elif MIN_VERSION_sbv(10,0,0) +preprocessUIFuncs :: + [(String, (ty, Either String ([([SBVD.CV], SBVD.CV)], SBVD.CV)))] -> + Maybe [(String, ([([SBVD.CV], SBVD.CV)], SBVD.CV))] +preprocessUIFuncs = + traverse + (\v -> case v of + (a, (_, Right c)) -> Just (a, c) + _ -> Nothing) +#else +preprocessUIFuncs :: + [(String, (ty, ([([SBVD.CV], SBVD.CV)], SBVD.CV)))] -> + Maybe [(String, ([([SBVD.CV], SBVD.CV)], SBVD.CV))] +preprocessUIFuncs = Just . fmap (\(a, (_, c)) -> (a, c)) +#endif + +parseModel :: + forall integerBitWidth. + GrisetteSMTConfig integerBitWidth -> + SBVI.SMTModel -> + SymBiMap -> + PM.Model +parseModel _ (SBVI.SMTModel _ _ assoc origFuncs) mp = + case preprocessUIFuncs origFuncs of + Just funcs -> foldr goSingle emptyModel $ funcs ++ assocFuncs + _ -> error "SBV Failed to parse model" + where + assocFuncs = (\(s, v) -> (s, ([([], v)], 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) -> + 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." diff --git a/src/Grisette/Internal/Backend/SymBiMap.hs b/src/Grisette/Internal/Backend/SymBiMap.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Backend/SymBiMap.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module : Grisette.Internal.Backend.SymBiMap +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Backend.SymBiMap + ( SymBiMap (..), + emptySymBiMap, + sizeBiMap, + addBiMap, + addBiMapIntermediate, + findStringToSymbol, + lookupTerm, + ) +where + +import Data.Dynamic (Dynamic) +import qualified Data.HashMap.Strict as M +import GHC.Stack (HasCallStack) +import Grisette.Internal.SymPrim.Prim.SomeTerm + ( SomeTerm, + ) +import Grisette.Internal.SymPrim.Prim.Term + ( SomeTypedSymbol, + ) + +data SymBiMap = SymBiMap + { biMapToSBV :: M.HashMap SomeTerm Dynamic, + biMapFromSBV :: M.HashMap String SomeTypedSymbol + } + deriving (Show) + +emptySymBiMap :: SymBiMap +emptySymBiMap = SymBiMap M.empty M.empty + +sizeBiMap :: SymBiMap -> Int +sizeBiMap = M.size . biMapToSBV + +addBiMap :: (HasCallStack) => SomeTerm -> Dynamic -> String -> SomeTypedSymbol -> SymBiMap -> SymBiMap +addBiMap s d n sb (SymBiMap t f) = SymBiMap (M.insert s d t) (M.insert n sb f) + +addBiMapIntermediate :: (HasCallStack) => SomeTerm -> Dynamic -> SymBiMap -> SymBiMap +addBiMapIntermediate s d (SymBiMap t f) = SymBiMap (M.insert s d t) f + +findStringToSymbol :: String -> SymBiMap -> Maybe SomeTypedSymbol +findStringToSymbol s (SymBiMap _ f) = M.lookup s f + +lookupTerm :: (HasCallStack) => SomeTerm -> SymBiMap -> Maybe Dynamic +lookupTerm t m = M.lookup t (biMapToSBV m) diff --git a/src/Grisette/Internal/Core.hs b/src/Grisette/Internal/Core.hs deleted file mode 100644 --- a/src/Grisette/Internal/Core.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE Trustworthy #-} --- Disable this warning because we are re-exporting things. -{-# OPTIONS_GHC -Wno-missing-import-lists #-} - --- | --- Module : Grisette.Internal.Core --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Internal.Core - ( -- * The UnionBase type - Union (..), - ifWithLeftMost, - ifWithStrategy, - fullReconstruct, - - -- * The UnionMBase type - UnionM (..), - underlyingUnion, - isMerged, - ) -where - -import Grisette.Core.Control.Monad.UnionM - ( UnionM (..), - isMerged, - underlyingUnion, - ) -import Grisette.Core.Data.Union - ( Union (..), - fullReconstruct, - ifWithLeftMost, - ifWithStrategy, - ) diff --git a/src/Grisette/Internal/Core/Control/Exception.hs b/src/Grisette/Internal/Core/Control/Exception.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Core/Control/Exception.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Trustworthy #-} + +-- | +-- Module : Grisette.Internal.Core.Control.Exception +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Core.Control.Exception + ( -- * Predefined exceptions + AssertionError (..), + VerificationConditions (..), + ) +where + +import Control.DeepSeq (NFData) +import GHC.Generics (Generic) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.Lib.Base +-- >>> import Grisette.SymPrim +-- >>> import Control.Monad.Trans.Except + +-- | Assertion error. +data AssertionError = AssertionError + deriving (Show, Eq, Ord, Generic, NFData) + +-- | Verification conditions. +-- A crashed program path can terminate with either assertion violation errors or assumption violation errors. +data VerificationConditions + = AssertionViolation + | AssumptionViolation + deriving (Show, Eq, Ord, Generic, NFData) diff --git a/src/Grisette/Internal/Core/Control/Monad/CBMCExcept.hs b/src/Grisette/Internal/Core/Control/Monad/CBMCExcept.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Core/Control/Monad/CBMCExcept.hs @@ -0,0 +1,481 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Core.Control.Monad.CBMCExcept +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Core.Control.Monad.CBMCExcept + ( -- * CBMC-like error handling + CBMCEither (..), + CBMCExceptT (..), + cbmcExcept, + mapCBMCExceptT, + withCBMCExceptT, + OrigExcept.MonadError (..), + ) +where + +#if MIN_VERSION_base(4,18,0) +import Control.Applicative + ( Alternative (empty, (<|>)), + ) +#else +import Control.Applicative + ( Alternative (empty, (<|>)), + Applicative (liftA2), + ) +#endif +import Control.DeepSeq (NFData) +import Control.Monad (MonadPlus (mplus, mzero)) +import qualified Control.Monad.Except as OrigExcept +import qualified Control.Monad.Fail as Fail +import Control.Monad.Fix (MonadFix (mfix)) +import Control.Monad.Trans (MonadIO (liftIO), MonadTrans (lift)) +import Control.Monad.Zip (MonadZip (mzipWith)) +import Data.Functor.Classes + ( Eq1 (liftEq), + Ord1 (liftCompare), + Read1 (liftReadList, liftReadsPrec), + Show1 (liftShowList, liftShowsPrec), + compare1, + eq1, + readsData, + readsPrec1, + readsUnaryWith, + showsPrec1, + showsUnaryWith, + ) +import Data.Functor.Contravariant (Contravariant (contramap)) +import Data.Hashable (Hashable) +import GHC.Generics (Generic, Generic1) +import Grisette.Internal.Core.Control.Monad.UnionM (UnionM) +import Grisette.Internal.Core.Data.Class.EvaluateSym (EvaluateSym (evaluateSym)) +import Grisette.Internal.Core.Data.Class.ExtractSymbolics + ( ExtractSymbolics (extractSymbolics), + ) +import Grisette.Internal.Core.Data.Class.GenSym + ( GenSym (fresh), + GenSymSimple (simpleFresh), + derivedNoSpecFresh, + derivedSameShapeSimpleFresh, + ) +import Grisette.Internal.Core.Data.Class.Mergeable + ( Mergeable (rootStrategy), + Mergeable1 (liftRootStrategy), + MergingStrategy (NoStrategy, SimpleStrategy, SortedStrategy), + rootStrategy1, + wrapStrategy, + ) +import Grisette.Internal.Core.Data.Class.SEq (SEq ((.==))) +import Grisette.Internal.Core.Data.Class.SOrd (SOrd (symCompare, (.<), (.<=), (.>), (.>=))) +import Grisette.Internal.Core.Data.Class.SimpleMergeable + ( SimpleMergeable (mrgIte), + SimpleMergeable1 (liftMrgIte), + UnionMergeable1 (mrgIfPropagatedStrategy, mrgIfWithStrategy), + mrgIf, + ) +import Grisette.Internal.Core.Data.Class.Solver (UnionWithExcept (extractUnionExcept)) +import Grisette.Internal.Core.Data.Class.ToCon (ToCon (toCon)) +import Grisette.Internal.Core.Data.Class.ToSym (ToSym (toSym)) +import Grisette.Internal.Core.Data.Class.TryMerge + ( TryMerge (tryMergeWithStrategy), + tryMerge, + ) +import Language.Haskell.TH.Syntax (Lift) +import Unsafe.Coerce (unsafeCoerce) + +-- | A wrapper type for 'Either'. Uses different merging strategies. +newtype CBMCEither a b = CBMCEither {runCBMCEither :: Either a b} + deriving newtype (Eq, Eq1, Ord, Ord1, Read, Read1, Show, Show1, Functor, Applicative, Monad, Hashable, NFData) + deriving stock (Generic, Lift) + +deriving newtype instance (SEq e, SEq a) => SEq (CBMCEither e a) + +deriving newtype instance (EvaluateSym a, EvaluateSym b) => EvaluateSym (CBMCEither a b) + +deriving newtype instance + (ExtractSymbolics a, ExtractSymbolics b) => + ExtractSymbolics (CBMCEither a b) + +instance + ( GenSymSimple a a, + Mergeable a, + GenSymSimple b b, + Mergeable b + ) => + GenSym (CBMCEither a b) (CBMCEither a b) + +instance + ( GenSymSimple a a, + GenSymSimple b b + ) => + GenSymSimple (CBMCEither a b) (CBMCEither a b) + where + simpleFresh = derivedSameShapeSimpleFresh + +instance + (GenSym () a, Mergeable a, GenSym () b, Mergeable b) => + GenSym () (CBMCEither a b) + where + fresh = derivedNoSpecFresh + +deriving newtype instance (SOrd a, SOrd b) => SOrd (CBMCEither a b) + +deriving newtype instance (ToCon e1 e2, ToCon a1 a2) => ToCon (Either e1 a1) (CBMCEither e2 a2) + +instance (ToCon e1 e2, ToCon a1 a2) => ToCon (CBMCEither e1 a1) (CBMCEither e2 a2) where + toCon (CBMCEither a) = CBMCEither <$> toCon a + +instance (ToCon e1 e2, ToCon a1 a2) => ToCon (CBMCEither e1 a1) (Either e2 a2) where + toCon (CBMCEither a) = toCon a + +deriving newtype instance (ToSym e1 e2, ToSym a1 a2) => ToSym (Either e1 a1) (CBMCEither e2 a2) + +instance (ToSym e1 e2, ToSym a1 a2) => ToSym (CBMCEither e1 a1) (CBMCEither e2 a2) where + toSym (CBMCEither a) = CBMCEither $ toSym a + +instance (ToSym e1 e2, ToSym a1 a2) => ToSym (CBMCEither e1 a1) (Either e2 a2) where + toSym (CBMCEither a) = toSym a + +data EitherIdx idx = L idx | R deriving (Eq, Ord, Show) + +instance (Mergeable e, Mergeable a) => Mergeable (CBMCEither e a) where + rootStrategy = rootStrategy1 + +instance (Mergeable e) => Mergeable1 (CBMCEither e) where + liftRootStrategy ms = case rootStrategy of + SimpleStrategy m -> + SortedStrategy + ( \(CBMCEither e) -> case e of + Left _ -> False + Right _ -> True + ) + ( \case + False -> SimpleStrategy $ + \cond (CBMCEither le) (CBMCEither re) -> case (le, re) of + (Left l, Left r) -> CBMCEither $ Left $ m cond l r + _ -> error "impossible" + True -> wrapStrategy ms (CBMCEither . Right) (\case (CBMCEither (Right x)) -> x; _ -> error "impossible") + ) + NoStrategy -> + SortedStrategy + ( \(CBMCEither e) -> case e of + Left _ -> False + Right _ -> True + ) + ( \case + False -> NoStrategy + True -> wrapStrategy ms (CBMCEither . Right) (\case (CBMCEither (Right x)) -> x; _ -> error "impossible") + ) + SortedStrategy idx sub -> + SortedStrategy + ( \(CBMCEither e) -> case e of + Left v -> L $ idx v + Right _ -> R + ) + ( \case + L i -> wrapStrategy (sub i) (CBMCEither . Left) (\case (CBMCEither (Left x)) -> x; _ -> error "impossible") + R -> wrapStrategy ms (CBMCEither . Right) (\case (CBMCEither (Right x)) -> x; _ -> error "impossible") + ) + +cbmcEither :: forall a c b. (a -> c) -> (b -> c) -> CBMCEither a b -> c +cbmcEither l r v = either l r (unsafeCoerce v) + +-- | Wrap an 'Either' value in 'CBMCExceptT' +cbmcExcept :: (Monad m) => Either e a -> CBMCExceptT e m a +cbmcExcept m = CBMCExceptT (return $ CBMCEither m) + +-- | Map the error and values in a 'CBMCExceptT' +mapCBMCExceptT :: (m (Either e a) -> n (Either e' b)) -> CBMCExceptT e m a -> CBMCExceptT e' n b +mapCBMCExceptT f m = CBMCExceptT $ (unsafeCoerce . f . unsafeCoerce) (runCBMCExceptT m) + +-- | Map the error in a 'CBMCExceptT' +withCBMCExceptT :: (Functor m) => (e -> e') -> CBMCExceptT e m a -> CBMCExceptT e' m a +withCBMCExceptT f = mapCBMCExceptT $ fmap $ either (Left . f) Right + +-- | Similar to 'ExceptT', but with different error handling mechanism. +newtype CBMCExceptT e m a = CBMCExceptT {runCBMCExceptT :: m (CBMCEither e a)} deriving stock (Generic, Generic1) + +instance (Eq e, Eq1 m) => Eq1 (CBMCExceptT e m) where + liftEq eq (CBMCExceptT x) (CBMCExceptT y) = liftEq (liftEq eq) x y + {-# INLINE liftEq #-} + +instance (Ord e, Ord1 m) => Ord1 (CBMCExceptT e m) where + liftCompare comp (CBMCExceptT x) (CBMCExceptT y) = + liftCompare (liftCompare comp) x y + {-# INLINE liftCompare #-} + +instance (Read e, Read1 m) => Read1 (CBMCExceptT e m) where + liftReadsPrec rp rl = + readsData $ + readsUnaryWith (liftReadsPrec rp' rl') "CBMCExceptT" CBMCExceptT + where + rp' = liftReadsPrec rp rl + rl' = liftReadList rp rl + +instance (Show e, Show1 m) => Show1 (CBMCExceptT e m) where + liftShowsPrec sp sl d (CBMCExceptT m) = + showsUnaryWith (liftShowsPrec sp' sl') "CBMCExceptT" d m + where + sp' = liftShowsPrec sp sl + sl' = liftShowList sp sl + +instance (Eq e, Eq1 m, Eq a) => Eq (CBMCExceptT e m a) where + (==) = eq1 + +instance (Ord e, Ord1 m, Ord a) => Ord (CBMCExceptT e m a) where + compare = compare1 + +instance (Read e, Read1 m, Read a) => Read (CBMCExceptT e m a) where + readsPrec = readsPrec1 + +instance (Show e, Show1 m, Show a) => Show (CBMCExceptT e m a) where + showsPrec = showsPrec1 + +instance (Functor m) => Functor (CBMCExceptT e m) where + fmap f = CBMCExceptT . fmap (fmap f) . runCBMCExceptT + {-# INLINE fmap #-} + +instance (Foldable f) => Foldable (CBMCExceptT e f) where + foldMap f (CBMCExceptT a) = foldMap (cbmcEither (const mempty) f) a + {-# INLINE foldMap #-} + +instance (Traversable f) => Traversable (CBMCExceptT e f) where + traverse f (CBMCExceptT a) = + CBMCExceptT <$> traverse (cbmcEither (pure . CBMCEither . Left) (fmap (CBMCEither . Right) . f)) a + {-# INLINE traverse #-} + +instance (Functor m, Monad m) => Applicative (CBMCExceptT e m) where + pure a = CBMCExceptT $ return (CBMCEither . Right $ a) + {-# INLINE pure #-} + CBMCExceptT f <*> CBMCExceptT v = CBMCExceptT $ do + mf <- f + case mf of + CBMCEither (Left e) -> return (CBMCEither . Left $ e) + CBMCEither (Right k) -> do + mv <- v + case mv of + CBMCEither (Left e) -> return (CBMCEither . Left $ e) + CBMCEither (Right x) -> return (CBMCEither . Right $ k x) + {-# INLINEABLE (<*>) #-} + m *> k = m >> k + {-# INLINE (*>) #-} + +instance (Functor m, Monad m, Monoid e) => Alternative (CBMCExceptT e m) where + empty = CBMCExceptT $ return (CBMCEither . Left $ mempty) + {-# INLINE empty #-} + CBMCExceptT mx <|> CBMCExceptT my = CBMCExceptT $ do + ex <- mx + case ex of + CBMCEither (Left e) -> fmap (cbmcEither (CBMCEither . Left . mappend e) (CBMCEither . Right)) my + CBMCEither (Right x) -> return (CBMCEither . Right $ x) + {-# INLINEABLE (<|>) #-} + +instance (Monad m) => Monad (CBMCExceptT e m) where + m >>= k = CBMCExceptT $ do + a <- runCBMCExceptT m + case a of + CBMCEither (Left e) -> return (CBMCEither $ Left e) + CBMCEither (Right x) -> runCBMCExceptT (k x) + {-# INLINE (>>=) #-} + +instance (Fail.MonadFail m) => Fail.MonadFail (CBMCExceptT e m) where + fail = CBMCExceptT . Fail.fail + {-# INLINE fail #-} + +instance (Monad m, Monoid e) => MonadPlus (CBMCExceptT e m) where + mzero = CBMCExceptT $ return (CBMCEither $ Left mempty) + {-# INLINE mzero #-} + CBMCExceptT mx `mplus` CBMCExceptT my = CBMCExceptT $ do + ex <- mx + case ex of + CBMCEither (Left e) -> fmap (cbmcEither (CBMCEither . Left . mappend e) (CBMCEither . Right)) my + CBMCEither (Right x) -> return (CBMCEither $ Right x) + {-# INLINEABLE mplus #-} + +instance (MonadFix m) => MonadFix (CBMCExceptT e m) where + mfix f = CBMCExceptT (mfix (runCBMCExceptT . f . cbmcEither (const bomb) id)) + where + bomb = error "mfix (CBMCExceptT): inner computation returned Left value" + {-# INLINE mfix #-} + +instance MonadTrans (CBMCExceptT e) where + lift = CBMCExceptT . fmap (CBMCEither . Right) + {-# INLINE lift #-} + +instance (MonadIO m) => MonadIO (CBMCExceptT e m) where + liftIO = lift . liftIO + {-# INLINE liftIO #-} + +instance (MonadZip m) => MonadZip (CBMCExceptT e m) where + mzipWith f (CBMCExceptT a) (CBMCExceptT b) = CBMCExceptT $ mzipWith (liftA2 f) a b + {-# INLINE mzipWith #-} + +instance (Contravariant m) => Contravariant (CBMCExceptT e m) where + contramap f = CBMCExceptT . contramap (fmap f) . runCBMCExceptT + {-# INLINE contramap #-} + +throwE :: (Monad m) => e -> CBMCExceptT e m a +throwE = CBMCExceptT . return . CBMCEither . Left +{-# INLINE throwE #-} + +catchE :: + (Monad m) => + CBMCExceptT e m a -> + (e -> CBMCExceptT e' m a) -> + CBMCExceptT e' m a +m `catchE` h = CBMCExceptT $ do + a <- runCBMCExceptT m + case a of + CBMCEither (Left l) -> runCBMCExceptT (h l) + CBMCEither (Right r) -> return (CBMCEither . Right $ r) +{-# INLINE catchE #-} + +instance (Monad m) => OrigExcept.MonadError e (CBMCExceptT e m) where + throwError = throwE + {-# INLINE throwError #-} + catchError = catchE + {-# INLINE catchError #-} + +instance (SEq (m (CBMCEither e a))) => SEq (CBMCExceptT e m a) where + (CBMCExceptT a) .== (CBMCExceptT b) = a .== b + {-# INLINE (.==) #-} + +instance (EvaluateSym (m (CBMCEither e a))) => EvaluateSym (CBMCExceptT e m a) where + evaluateSym fillDefault model (CBMCExceptT v) = CBMCExceptT $ evaluateSym fillDefault model v + {-# INLINE evaluateSym #-} + +instance + (ExtractSymbolics (m (CBMCEither e a))) => + ExtractSymbolics (CBMCExceptT e m a) + where + extractSymbolics (CBMCExceptT v) = extractSymbolics v + +instance + (Mergeable1 m, Mergeable e, Mergeable a) => + Mergeable (CBMCExceptT e m a) + where + rootStrategy = wrapStrategy rootStrategy1 CBMCExceptT runCBMCExceptT + {-# INLINE rootStrategy #-} + +instance (Mergeable1 m, Mergeable e) => Mergeable1 (CBMCExceptT e m) where + liftRootStrategy m = wrapStrategy (liftRootStrategy (liftRootStrategy m)) CBMCExceptT runCBMCExceptT + {-# INLINE liftRootStrategy #-} + +instance + {-# OVERLAPPABLE #-} + ( GenSym spec (m (CBMCEither a b)), + Mergeable1 m, + Mergeable a, + Mergeable b + ) => + GenSym spec (CBMCExceptT a m b) + where + fresh v = do + x <- fresh v + return $ tryMerge . fmap CBMCExceptT $ x + +instance + {-# OVERLAPPABLE #-} + ( GenSymSimple spec (m (CBMCEither a b)) + ) => + GenSymSimple spec (CBMCExceptT a m b) + where + simpleFresh v = CBMCExceptT <$> simpleFresh v + +instance + {-# OVERLAPPING #-} + ( GenSymSimple (m (CBMCEither e a)) (m (CBMCEither e a)) + ) => + GenSymSimple (CBMCExceptT e m a) (CBMCExceptT e m a) + where + simpleFresh (CBMCExceptT v) = CBMCExceptT <$> simpleFresh v + +instance + {-# OVERLAPPING #-} + ( GenSymSimple (m (CBMCEither e a)) (m (CBMCEither e a)), + Mergeable1 m, + Mergeable e, + Mergeable a + ) => + GenSym (CBMCExceptT e m a) (CBMCExceptT e m a) + +instance + (UnionMergeable1 m, Mergeable e, Mergeable a) => + SimpleMergeable (CBMCExceptT e m a) + where + mrgIte = mrgIf + {-# INLINE mrgIte #-} + +instance + (UnionMergeable1 m, Mergeable e) => + SimpleMergeable1 (CBMCExceptT e m) + where + liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) + {-# INLINE liftMrgIte #-} + +instance + (TryMerge m, Mergeable e) => + TryMerge (CBMCExceptT e m) + where + tryMergeWithStrategy s (CBMCExceptT v) = CBMCExceptT $ tryMergeWithStrategy (liftRootStrategy s) v + {-# INLINE tryMergeWithStrategy #-} + +instance + (UnionMergeable1 m, Mergeable e) => + UnionMergeable1 (CBMCExceptT e m) + where + mrgIfWithStrategy s cond (CBMCExceptT t) (CBMCExceptT f) = CBMCExceptT $ mrgIfWithStrategy (liftRootStrategy s) cond t f + {-# INLINE mrgIfWithStrategy #-} + mrgIfPropagatedStrategy cond (CBMCExceptT t) (CBMCExceptT f) = CBMCExceptT $ mrgIfPropagatedStrategy cond t f + {-# INLINE mrgIfPropagatedStrategy #-} + +instance (SOrd (m (CBMCEither e a))) => SOrd (CBMCExceptT e m a) where + (CBMCExceptT l) .<= (CBMCExceptT r) = l .<= r + (CBMCExceptT l) .< (CBMCExceptT r) = l .< r + (CBMCExceptT l) .>= (CBMCExceptT r) = l .>= r + (CBMCExceptT l) .> (CBMCExceptT r) = l .> r + symCompare (CBMCExceptT l) (CBMCExceptT r) = symCompare l r + +instance + (ToCon (m1 (CBMCEither e1 a)) (m2 (CBMCEither e2 b))) => + ToCon (CBMCExceptT e1 m1 a) (CBMCExceptT e2 m2 b) + where + toCon (CBMCExceptT v) = CBMCExceptT <$> toCon v + +instance + (ToCon (m1 (CBMCEither e1 a)) (Either e2 b)) => + ToCon (CBMCExceptT e1 m1 a) (Either e2 b) + where + toCon (CBMCExceptT v) = toCon v + +instance + (ToSym (m1 (CBMCEither e1 a)) (m2 (CBMCEither e2 b))) => + ToSym (CBMCExceptT e1 m1 a) (CBMCExceptT e2 m2 b) + where + toSym (CBMCExceptT v) = CBMCExceptT $ toSym v + +instance + (Monad u, TryMerge u, Mergeable e, Mergeable v) => + UnionWithExcept (CBMCExceptT e u v) u e v + where + extractUnionExcept = tryMerge . fmap runCBMCEither . runCBMCExceptT + +instance UnionWithExcept (UnionM (CBMCEither e v)) UnionM e v where + extractUnionExcept = fmap runCBMCEither diff --git a/src/Grisette/Internal/Core/Control/Monad/Union.hs b/src/Grisette/Internal/Core/Control/Monad/Union.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Core/Control/Monad/Union.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Core.Control.Monad.Union +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Core.Control.Monad.Union + ( -- * MonadUnion + MonadUnion, + ) +where + +import Grisette.Internal.Core.Data.Class.SimpleMergeable (UnionMergeable1) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim + +-- | Class for monads that support union-like operations and +-- 'Grisette.Core.Data.Class.Mergeable' knowledge propagation. +type MonadUnion u = (UnionMergeable1 u, Monad u) diff --git a/src/Grisette/Internal/Core/Control/Monad/UnionM.hs b/src/Grisette/Internal/Core/Control/Monad/UnionM.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Core/Control/Monad/UnionM.hs @@ -0,0 +1,594 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# HLINT ignore "Use <&>" #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +-- | +-- Module : Grisette.Internal.Core.Control.Monad.UnionM +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Core.Control.Monad.UnionM + ( -- * UnionM and helpers + UnionM (..), + unionMUnaryOp, + unionMBinOp, + liftUnionM, + liftToMonadUnion, + underlyingUnion, + isMerged, + unionSize, + IsConcrete, + ) +where + +import Control.DeepSeq (NFData (rnf), NFData1 (liftRnf), rnf1) +import Data.Functor.Classes + ( Eq1 (liftEq), + Show1 (liftShowsPrec), + showsPrec1, + ) +import qualified Data.HashMap.Lazy as HML +import Data.Hashable (Hashable (hashWithSalt)) +import Data.String (IsString (fromString)) +import GHC.TypeNats (KnownNat, type (<=)) +import Grisette.Internal.Core.Control.Monad.Union (MonadUnion) +import Grisette.Internal.Core.Data.Class.EvaluateSym (EvaluateSym (evaluateSym)) +import Grisette.Internal.Core.Data.Class.ExtractSymbolics + ( ExtractSymbolics (extractSymbolics), + ) +import Grisette.Internal.Core.Data.Class.Function (Function ((#))) +import Grisette.Internal.Core.Data.Class.GPretty + ( GPretty (gpretty), + groupedEnclose, + ) +import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp (symIte)) +import Grisette.Internal.Core.Data.Class.LogicalOp + ( LogicalOp (symImplies, symNot, symXor, (.&&), (.||)), + ) +import Grisette.Internal.Core.Data.Class.Mergeable + ( Mergeable (rootStrategy), + Mergeable1 (liftRootStrategy), + MergingStrategy (SimpleStrategy), + ) +import Grisette.Internal.Core.Data.Class.PlainUnion + ( PlainUnion (ifView, singleView), + simpleMerge, + ) +import Grisette.Internal.Core.Data.Class.SEq (SEq ((.==))) +import Grisette.Internal.Core.Data.Class.SimpleMergeable + ( SimpleMergeable (mrgIte), + SimpleMergeable1 (liftMrgIte), + UnionMergeable1 (mrgIfPropagatedStrategy, mrgIfWithStrategy), + mrgIf, + ) +import Grisette.Internal.Core.Data.Class.Solvable + ( Solvable (con, conView, sym), + pattern Con, + ) +import Grisette.Internal.Core.Data.Class.Solver (UnionWithExcept (extractUnionExcept)) +import Grisette.Internal.Core.Data.Class.SubstituteSym (SubstituteSym (substituteSym)) +import Grisette.Internal.Core.Data.Class.ToCon (ToCon (toCon)) +import Grisette.Internal.Core.Data.Class.ToSym (ToSym (toSym)) +import Grisette.Internal.Core.Data.Class.TryMerge + ( TryMerge (tryMergeWithStrategy), + mrgSingle, + tryMerge, + ) +import Grisette.Internal.Core.Data.Union + ( Union (UnionIf, UnionSingle), + ifWithLeftMost, + ) +import Grisette.Internal.SymPrim.AllSyms + ( AllSyms (allSymsS), + ) +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.GeneralFun + ( type (-->), + ) +import Grisette.Internal.SymPrim.Prim.Term + ( LinkedRep, + SupportedPrim, + ) +import Grisette.Internal.SymPrim.SymBV + ( SymIntN, + SymWordN, + ) +import Grisette.Internal.SymPrim.SymBool (SymBool) +import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>)) +import Grisette.Internal.SymPrim.SymInteger (SymInteger) +import Grisette.Internal.SymPrim.SymTabularFun (type (=~>)) +import Grisette.Internal.SymPrim.TabularFun (type (=->)) +import Language.Haskell.TH.Syntax (Lift (lift, liftTyped)) +import Language.Haskell.TH.Syntax.Compat (unTypeSplice) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim +-- >>> :set -XScopedTypeVariables + +-- | 'UnionM' is the 'Union' container (hidden) enhanced with +-- 'MergingStrategy' +-- [knowledge propagation](https://okmij.org/ftp/Haskell/set-monad.html#PE). +-- +-- The 'Union' models the underlying semantics evaluation semantics for +-- unsolvable types with the nested if-then-else tree semantics, and can be +-- viewed as the following structure: +-- +-- > data Union a +-- > = Single a +-- > | If bool (Union a) (Union a) +-- +-- The 'Single' constructor is for a single value with the path condition +-- @true@, and the 'If' constructor is the if operator in an if-then-else +-- tree. +-- For clarity, when printing a 'UnionM' value, we will omit the 'Single' +-- constructor. The following two representations has the same semantics. +-- +-- > If c1 (If c11 v11 (If c12 v12 v13)) +-- > (If c2 v2 +-- > v3) +-- +-- \[ +-- \left\{\begin{aligned}&t_1&&\mathrm{if}&&c_1\\&v_2&&\mathrm{else if}&&c_2\\&v_3&&\mathrm{otherwise}&&\end{aligned}\right.\hspace{2em}\mathrm{where}\hspace{2em}t_1 = \left\{\begin{aligned}&v_{11}&&\mathrm{if}&&c_{11}\\&v_{12}&&\mathrm{else if}&&c_{12}\\&v_{13}&&\mathrm{otherwise}&&\end{aligned}\right. +-- \] +-- +-- To reduce the size of the if-then-else tree to reduce the number of paths to +-- execute, Grisette would merge the branches in a 'Union' container and +-- maintain a representation invariant for them. To perform this merging +-- procedure, Grisette relies on a type class called 'Mergeable' and the +-- merging strategy defined by it. +-- +-- 'Union' is a monad, so we can easily write code with the do-notation and +-- monadic combinators. However, the standard monadic operators cannot +-- resolve any extra constraints, including the 'Mergeable' constraint (see +-- [The constrained-monad +-- problem](https://dl.acm.org/doi/10.1145/2500365.2500602) +-- by Sculthorpe et al.). +-- This prevents the standard do-notations to merge the results automatically, +-- and would result in bad performance or very verbose code. +-- +-- To reduce this boilerplate, Grisette provide another monad, 'UnionM' that +-- would try to cache the merging strategy. +-- The 'UnionM' has two data constructors (hidden intentionally), 'UAny' and 'UMrg'. +-- The 'UAny' data constructor (printed as @<@@...@@>@) wraps an arbitrary (probably +-- unmerged) 'Union'. It is constructed when no 'Mergeable' knowledge is +-- available (for example, when constructed with Haskell\'s 'return'). +-- The 'UMrg' data constructor (printed as @{...}@) wraps a merged 'UnionM' along with the +-- 'Mergeable' constraint. This constraint can be propagated to the contexts +-- without 'Mergeable' knowledge, and helps the system to merge the resulting +-- 'Union'. +-- +-- __/Examples:/__ +-- +-- 'return' cannot resolve the 'Mergeable' constraint. +-- +-- >>> return 1 :: UnionM Integer +-- <1> +-- +-- 'Grisette.Lib.Control.Monad.mrgReturn' can resolve the 'Mergeable' constraint. +-- +-- >>> import Grisette.Lib.Base +-- >>> mrgReturn 1 :: UnionM Integer +-- {1} +-- +-- 'mrgIfPropagatedStrategy' does not try to 'Mergeable' constraint. +-- +-- >>> mrgIfPropagatedStrategy "a" (return 1) (mrgIfPropagatedStrategy "b" (return 1) (return 2)) :: UnionM Integer +-- +-- +-- But 'mrgIfPropagatedStrategy' is able to merge the result if some of the +-- branches are merged and have a cached merging strategy: +-- +-- >>> mrgIfPropagatedStrategy "a" (return 1) (mrgIfPropagatedStrategy "b" (mrgReturn 1) (return 2)) :: UnionM Integer +-- {If (|| a b) 1 2} +-- +-- The '>>=' operator uses 'mrgIfPropagatedStrategy' internally. When the final +-- statement in a do-block merges the values, the system can then merge the +-- final result. +-- +-- >>> :{ +-- do +-- x <- mrgIfPropagatedStrategy (ssym "a") (return 1) (mrgIfPropagatedStrategy (ssym "b") (return 1) (return 2)) +-- mrgSingle $ x + 1 :: UnionM Integer +-- :} +-- {If (|| a b) 2 3} +-- +-- Calling a function that merges a result at the last line of a do-notation +-- will also merge the whole block. If you stick to these @mrg*@ combinators and +-- all the functions will merge the results, the whole program can be +-- symbolically evaluated efficiently. +-- +-- >>> f x y = mrgIf "c" x y +-- >>> :{ +-- do +-- x <- mrgIfPropagatedStrategy (ssym "a") (return 1) (mrgIfPropagatedStrategy (ssym "b") (return 1) (return 2)) +-- f x (x + 1) :: UnionM Integer +-- :} +-- {If (&& c (|| a b)) 1 (If (|| a (|| b c)) 2 3)} +-- +-- In "Grisette.Lib.Base", "Grisette.Lib.Mtl", we also provided more @mrg*@ +-- variants of other combinators. You should stick to these combinators to +-- ensure efficient merging by Grisette. +data UnionM a where + -- | 'UnionM' with no 'Mergeable' knowledge. + UAny :: + -- | Original 'Union'. + Union a -> + UnionM a + -- | 'UnionM' with 'Mergeable' knowledge. + UMrg :: + -- | Cached merging strategy. + MergingStrategy a -> + -- | Merged Union + Union a -> + UnionM a + +instance (NFData a) => NFData (UnionM a) where + rnf = rnf1 + +instance NFData1 UnionM where + liftRnf _a (UAny m) = liftRnf _a m + liftRnf _a (UMrg _ m) = liftRnf _a m + +instance (Lift a) => Lift (UnionM a) where + liftTyped (UAny v) = [||UAny v||] + liftTyped (UMrg _ v) = [||UAny v||] + lift = unTypeSplice . liftTyped + +instance (Show a) => (Show (UnionM a)) where + showsPrec = showsPrec1 + +liftShowsPrecUnion :: + forall a. + (Int -> a -> ShowS) -> + ([a] -> ShowS) -> + Int -> + Union a -> + ShowS +liftShowsPrecUnion sp _ i (UnionSingle a) = sp i a +liftShowsPrecUnion sp sl i (UnionIf _ _ cond t f) = + showParen (i > 10) $ + showString "If" + . showChar ' ' + . showsPrec 11 cond + . showChar ' ' + . sp1 11 t + . showChar ' ' + . sp1 11 f + where + sp1 = liftShowsPrecUnion sp sl + +wrapBracket :: Char -> Char -> ShowS -> ShowS +wrapBracket l r p = showChar l . p . showChar r + +instance Show1 UnionM where + liftShowsPrec sp sl _ (UAny a) = + wrapBracket '<' '>' + . liftShowsPrecUnion sp sl 0 + $ a + liftShowsPrec sp sl _ (UMrg _ a) = + wrapBracket '{' '}' + . liftShowsPrecUnion sp sl 0 + $ a + +instance (GPretty a) => GPretty (UnionM a) where + gpretty = \case + (UAny a) -> groupedEnclose "<" ">" $ gpretty a + (UMrg _ a) -> groupedEnclose "{" "}" $ gpretty a + +-- | Extract the underlying Union. May be unmerged. +underlyingUnion :: UnionM a -> Union a +underlyingUnion (UAny a) = a +underlyingUnion (UMrg _ a) = a +{-# INLINE underlyingUnion #-} + +-- | Check if a UnionM is already merged. +isMerged :: UnionM a -> Bool +isMerged UAny {} = False +isMerged UMrg {} = True +{-# INLINE isMerged #-} + +instance PlainUnion UnionM where + singleView = singleView . underlyingUnion + {-# INLINE singleView #-} + ifView (UAny u) = case ifView u of + Just (c, t, f) -> Just (c, UAny t, UAny f) + Nothing -> Nothing + ifView (UMrg m u) = case ifView u of + Just (c, t, f) -> Just (c, UMrg m t, UMrg m f) + Nothing -> Nothing + {-# INLINE ifView #-} + +instance Functor UnionM where + fmap f fa = fa >>= return . f + {-# INLINE fmap #-} + +instance Applicative UnionM where + pure = UAny . pure + {-# INLINE pure #-} + f <*> a = f >>= (\xf -> a >>= (return . xf)) + {-# INLINE (<*>) #-} + +bindUnion :: Union a -> (a -> UnionM b) -> UnionM b +bindUnion (UnionSingle a') f' = f' a' +bindUnion (UnionIf _ _ cond ifTrue ifFalse) f' = + mrgIfPropagatedStrategy cond (bindUnion ifTrue f') (bindUnion ifFalse f') +{-# INLINE bindUnion #-} + +instance Monad UnionM where + a >>= f = bindUnion (underlyingUnion a) f + {-# INLINE (>>=) #-} + +unionMUnaryOp :: (Mergeable a, Mergeable b) => (a -> b) -> UnionM a -> UnionM b +unionMUnaryOp f a = do + a1 <- tryMerge a + mrgSingle $ f a1 +{-# INLINE unionMUnaryOp #-} + +unionMBinOp :: + (Mergeable a, Mergeable b, Mergeable c) => + (a -> b -> c) -> + UnionM a -> + UnionM b -> + UnionM c +unionMBinOp f a b = do + a1 <- tryMerge a + b1 <- tryMerge b + mrgSingle $ f a1 b1 +{-# INLINE unionMBinOp #-} + +instance (Mergeable a) => Mergeable (UnionM a) where + rootStrategy = SimpleStrategy mrgIf + {-# INLINE rootStrategy #-} + +instance (Mergeable a) => SimpleMergeable (UnionM a) where + mrgIte = mrgIf + {-# INLINE mrgIte #-} + +instance Mergeable1 UnionM where + liftRootStrategy m = SimpleStrategy $ mrgIfWithStrategy m + {-# INLINE liftRootStrategy #-} + +instance SimpleMergeable1 UnionM where + liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) + {-# INLINE liftMrgIte #-} + +instance TryMerge UnionM where + tryMergeWithStrategy _ m@(UMrg _ _) = m + tryMergeWithStrategy s (UAny u) = UMrg s $ tryMergeWithStrategy s u + {-# INLINE tryMergeWithStrategy #-} + +instance UnionMergeable1 UnionM where + mrgIfWithStrategy s (Con c) l r = + if c then tryMergeWithStrategy s l else tryMergeWithStrategy s r + mrgIfWithStrategy s cond l r = + UMrg s $ mrgIfWithStrategy s cond (underlyingUnion l) (underlyingUnion r) + {-# INLINE mrgIfWithStrategy #-} + mrgIfPropagatedStrategy cond (UAny t) (UAny f) = UAny $ ifWithLeftMost False cond t f + mrgIfPropagatedStrategy cond t@(UMrg m _) f = mrgIfWithStrategy m cond t f + mrgIfPropagatedStrategy cond t f@(UMrg m _) = mrgIfWithStrategy m cond t f + {-# INLINE mrgIfPropagatedStrategy #-} + +instance (Mergeable a, SEq a) => SEq (UnionM a) where + x .== y = simpleMerge $ unionMBinOp (.==) x y + {-# INLINE (.==) #-} + +-- | Lift the 'UnionM' to any Applicative 'UnionMergeable1'. +liftUnionM :: (Mergeable a, UnionMergeable1 u, Applicative u) => UnionM a -> u a +liftUnionM u = go (underlyingUnion u) + where + go (UnionSingle v) = mrgSingle v + go (UnionIf _ _ c t f) = mrgIf c (go t) (go f) + +-- | Alias for `liftUnionM`, but for monads. +liftToMonadUnion :: (Mergeable a, MonadUnion u) => UnionM a -> u a +liftToMonadUnion = liftUnionM + +instance {-# INCOHERENT #-} (ToSym a b, Mergeable b) => ToSym a (UnionM b) where + toSym = mrgSingle . toSym + +instance (ToSym a b, Mergeable b) => ToSym (UnionM a) (UnionM b) where + toSym = tryMerge . fmap toSym + +#define TO_SYM_FROM_UNION_CON_SIMPLE(contype, symtype) \ +instance ToSym (UnionM contype) symtype where \ + toSym = simpleMerge . fmap con + +#define TO_SYM_FROM_UNION_CON_BV(contype, symtype) \ +instance (KnownNat n, 1 <= n) => ToSym (UnionM (contype n)) (symtype n) where \ + toSym = simpleMerge . fmap con + +#define TO_SYM_FROM_UNION_CON_FUN(conop, symop) \ +instance (SupportedPrim (conop ca cb), LinkedRep ca sa, LinkedRep cb sb) => ToSym (UnionM (conop ca cb)) (symop sa sb) where \ + toSym = simpleMerge . fmap con + +#define TO_SYM_FROM_UNION_CON_BV_SOME(contype, symtype) \ +instance ToSym (UnionM contype) symtype where \ + toSym = simpleMerge . fmap (toSym :: contype -> symtype) + +#if 1 +TO_SYM_FROM_UNION_CON_SIMPLE(Bool, SymBool) +TO_SYM_FROM_UNION_CON_SIMPLE(Integer, SymInteger) +TO_SYM_FROM_UNION_CON_BV(IntN, SymIntN) +TO_SYM_FROM_UNION_CON_BV(WordN, SymWordN) +TO_SYM_FROM_UNION_CON_FUN((=->), (=~>)) +TO_SYM_FROM_UNION_CON_FUN((-->), (-~>)) +#endif + +instance {-# INCOHERENT #-} (ToCon a b, Mergeable a) => ToCon (UnionM a) b where + toCon v = go $ underlyingUnion $ tryMerge v + where + go (UnionSingle x) = toCon x + go _ = Nothing + +instance + (ToCon a b, Mergeable a, Mergeable b) => + ToCon (UnionM a) (UnionM b) + where + toCon v = go $ underlyingUnion $ tryMerge v + where + go (UnionSingle x) = case toCon x of + Nothing -> Nothing + Just v -> Just $ mrgSingle v + go (UnionIf _ _ c t f) = do + t' <- go t + f' <- go f + return $ mrgIf c t' f' + +instance (Mergeable a, EvaluateSym a) => EvaluateSym (UnionM a) where + evaluateSym fillDefault model x = go $ underlyingUnion x + where + go :: Union a -> UnionM a + go (UnionSingle v) = mrgSingle $ evaluateSym fillDefault model v + go (UnionIf _ _ cond t f) = + mrgIf + (evaluateSym fillDefault model cond) + (go t) + (go f) + +instance (Mergeable a, SubstituteSym a) => SubstituteSym (UnionM a) where + substituteSym sym val x = go $ underlyingUnion x + where + go :: Union a -> UnionM a + go (UnionSingle v) = mrgSingle $ substituteSym sym val v + go (UnionIf _ _ cond t f) = + mrgIf + (substituteSym sym val cond) + (go t) + (go f) + +instance + (ExtractSymbolics a) => + ExtractSymbolics (UnionM a) + where + extractSymbolics v = go $ underlyingUnion v + where + go (UnionSingle x) = extractSymbolics x + go (UnionIf _ _ cond t f) = extractSymbolics cond <> go t <> go f + +instance (Hashable a) => Hashable (UnionM a) where + s `hashWithSalt` (UAny u) = s `hashWithSalt` (0 :: Int) `hashWithSalt` u + s `hashWithSalt` (UMrg _ u) = s `hashWithSalt` (1 :: Int) `hashWithSalt` u + +instance (Eq a) => Eq (UnionM a) where + UAny l == UAny r = l == r + UMrg _ l == UMrg _ r = l == r + _ == _ = False + +instance Eq1 UnionM where + liftEq e l r = liftEq e (underlyingUnion l) (underlyingUnion r) + +instance (Num a, Mergeable a) => Num (UnionM a) where + fromInteger = mrgSingle . fromInteger + negate = unionMUnaryOp negate + (+) = unionMBinOp (+) + (*) = unionMBinOp (*) + (-) = unionMBinOp (-) + abs = unionMUnaryOp abs + signum = unionMUnaryOp signum + +instance (ITEOp a, Mergeable a) => ITEOp (UnionM a) where + symIte = mrgIf + +instance (LogicalOp a, Mergeable a) => LogicalOp (UnionM a) where + (.||) = unionMBinOp (.||) + (.&&) = unionMBinOp (.&&) + symNot = unionMUnaryOp symNot + symXor = unionMBinOp symXor + symImplies = unionMBinOp symImplies + +instance (Solvable c t, Mergeable t) => Solvable c (UnionM t) where + con = mrgSingle . con + {-# INLINE con #-} + sym = mrgSingle . sym + {-# INLINE sym #-} + conView v = do + c <- singleView $ tryMerge v + conView c + {-# INLINE conView #-} + +instance + (Function f arg ret, Mergeable f, Mergeable ret) => + Function (UnionM f) arg (UnionM ret) + where + f # a = do + f1 <- f + mrgSingle $ f1 # a + +instance (IsString a, Mergeable a) => IsString (UnionM a) where + fromString = mrgSingle . fromString + +-- AllSyms +instance (AllSyms a) => AllSyms (UnionM a) where + allSymsS = allSymsS . underlyingUnion + +-- Concrete Key HashMaps + +-- | Tag for concrete types. +-- Useful for specifying the merge strategy for some parametrized types where we should have different +-- merge strategy for symbolic and concrete ones. +class (Eq t, Ord t, Hashable t) => IsConcrete t + +instance IsConcrete Bool + +instance IsConcrete Integer + +instance (IsConcrete k, Mergeable t) => Mergeable (HML.HashMap k (UnionM (Maybe t))) where + rootStrategy = SimpleStrategy mrgIte + +instance (IsConcrete k, Mergeable t) => SimpleMergeable (HML.HashMap k (UnionM (Maybe t))) where + mrgIte cond l r = + HML.unionWith (mrgIf cond) ul ur + where + ul = + foldr + ( \k m -> case HML.lookup k m of + Nothing -> HML.insert k (mrgSingle Nothing) m + _ -> m + ) + l + (HML.keys r) + ur = + foldr + ( \k m -> case HML.lookup k m of + Nothing -> HML.insert k (mrgSingle Nothing) m + _ -> m + ) + r + (HML.keys l) + +instance UnionWithExcept (UnionM (Either e v)) UnionM e v where + extractUnionExcept = id + +-- | The size of a union is defined as the number of branches. +-- For example, +-- +-- >>> unionSize (return True) +-- 1 +-- >>> unionSize (mrgIf "a" (return 1) (return 2) :: UnionM Integer) +-- 2 +-- >>> unionSize (choose [1..7] "a" :: UnionM Integer) +-- 7 +unionSize :: UnionM a -> Int +unionSize = unionSize' . underlyingUnion + where + unionSize' (UnionSingle _) = 1 + unionSize' (UnionIf _ _ _ l r) = unionSize' l + unionSize' r diff --git a/src/Grisette/Internal/Core/Data/Class/BitVector.hs b/src/Grisette/Internal/Core/Data/Class/BitVector.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Core/Data/Class/BitVector.hs @@ -0,0 +1,254 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +-- | +-- Module : Grisette.Internal.Core.Data.Class.BitVector +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Core.Data.Class.BitVector + ( -- * Bit vector operations + BV (..), + bvExtract, + SizedBV (..), + sizedBVExtract, + ) +where + +import Data.Proxy (Proxy (Proxy)) +import GHC.TypeNats (KnownNat, type (+), type (-), type (<=)) +import Grisette.Internal.Utils.Parameterized + ( KnownProof (KnownProof), + LeqProof (LeqProof), + addNat, + hasRepr, + natRepr, + subNat, + unsafeLeqProof, + ) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim +-- >>> import Grisette.Utils +-- >>> :set -XDataKinds +-- >>> :set -XBinaryLiterals +-- >>> :set -XFlexibleContexts +-- >>> :set -XFlexibleInstances +-- >>> :set -XFunctionalDependencies + +-- | Bit vector operations. Including concatenation ('bvConcat'), +-- extension ('bvZext', 'bvSext', 'bvExt'), and selection +-- ('bvSelect'). +class BV bv where + -- | Concatenation of two bit vectors. + -- + -- >>> bvConcat (SomeSymWordN (0b101 :: SymWordN 3)) (SomeSymWordN (0b010 :: SymWordN 3)) + -- 0b101010 + bvConcat :: bv -> bv -> bv + + -- | Zero extension of a bit vector. + -- + -- >>> bvZext 6 (SomeSymWordN (0b101 :: SymWordN 3)) + -- 0b000101 + bvZext :: + -- | Desired output length + Int -> + -- | Bit vector to extend + bv -> + bv + + -- | Sign extension of a bit vector. + -- + -- >>> bvSext 6 (SomeSymWordN (0b101 :: SymWordN 3)) + -- 0b111101 + bvSext :: + -- | Desired output length + Int -> + -- | Bit vector to extend + bv -> + bv + + -- | Extension of a bit vector. + -- Signedness is determined by the input bit vector type. + -- + -- >>> bvExt 6 (SomeSymIntN (0b101 :: SymIntN 3)) + -- 0b111101 + -- >>> bvExt 6 (SomeSymIntN (0b001 :: SymIntN 3)) + -- 0b000001 + -- >>> bvExt 6 (SomeSymWordN (0b101 :: SymWordN 3)) + -- 0b000101 + -- >>> bvExt 6 (SomeSymWordN (0b001 :: SymWordN 3)) + -- 0b000001 + bvExt :: + -- | Desired output length + Int -> + -- | Bit vector to extend + bv -> + bv + + -- | Slicing out a smaller bit vector from a larger one, + -- selecting a slice with width @w@ starting from index @ix@. + -- + -- The least significant bit is indexed as 0. + -- + -- >>> bvSelect 1 3 (SomeSymIntN (0b001010 :: SymIntN 6)) + -- 0b101 + bvSelect :: + -- | Index of the least significant bit of the slice + Int -> + -- | Desired output width, @ix + w <= n@ must hold where @n@ is + -- the size of the input bit vector + Int -> + -- | Bit vector to select from + bv -> + bv + + -- | Create a bit vector from an integer. The bit-width is the first argument, + -- which should not be zero. + -- + -- >>> bv 12 21 :: SomeSymIntN + -- 0x015 + bv :: + (Integral a) => + -- | Bit width + Int -> + -- | Integral value + a -> + bv + +-- | Slicing out a smaller bit vector from a larger one, extract a slice from +-- bit @i@ down to @j@. +-- +-- The least significant bit is indexed as 0. +-- +-- >>> bvExtract 4 2 (SomeSymIntN (0b010100 :: SymIntN 6)) +-- 0b101 +bvExtract :: + (BV bv) => + -- | The start position to extract from, @i < n@ must hold where @n@ is + -- the size of the output bit vector + Int -> + -- | The end position to extract from, @j <= i@ must hold + Int -> + -- | Bit vector to extract from + bv -> + bv +bvExtract i j = bvSelect j (i - j + 1) +{-# INLINE bvExtract #-} + +-- | Sized bit vector operations. Including concatenation ('sizedBVConcat'), +-- extension ('sizedBVZext', 'sizedBVSext', 'sizedBVExt'), and selection +-- ('sizedBVSelect'). +class SizedBV bv where + -- | Concatenation of two bit vectors. + -- + -- >>> sizedBVConcat (0b101 :: SymIntN 3) (0b010 :: SymIntN 3) + -- 0b101010 + sizedBVConcat :: (KnownNat l, KnownNat r, 1 <= l, 1 <= r) => bv l -> bv r -> bv (l + r) + + -- | Zero extension of a bit vector. + -- + -- >>> sizedBVZext (Proxy @6) (0b101 :: SymIntN 3) + -- 0b000101 + sizedBVZext :: + (KnownNat l, KnownNat r, 1 <= l, KnownNat r, l <= r) => + -- | Desired output width + proxy r -> + -- | Bit vector to extend + bv l -> + bv r + + -- | Signed extension of a bit vector. + -- + -- >>> sizedBVSext (Proxy @6) (0b101 :: SymIntN 3) + -- 0b111101 + sizedBVSext :: + (KnownNat l, KnownNat r, 1 <= l, KnownNat r, l <= r) => + -- | Desired output width + proxy r -> + -- | Bit vector to extend + bv l -> + bv r + + -- | Extension of a bit vector. + -- Signedness is determined by the input bit vector type. + -- + -- >>> sizedBVExt (Proxy @6) (0b101 :: SymIntN 3) + -- 0b111101 + -- >>> sizedBVExt (Proxy @6) (0b001 :: SymIntN 3) + -- 0b000001 + -- >>> sizedBVExt (Proxy @6) (0b101 :: SymWordN 3) + -- 0b000101 + -- >>> sizedBVExt (Proxy @6) (0b001 :: SymWordN 3) + -- 0b000001 + sizedBVExt :: + (KnownNat l, KnownNat r, 1 <= l, KnownNat r, l <= r) => + -- | Desired output width + proxy r -> + -- | Bit vector to extend + bv l -> + bv r + + -- | Slicing out a smaller bit vector from a larger one, selecting a slice with + -- width @w@ starting from index @ix@. + -- + -- The least significant bit is indexed as 0. + -- + -- >>> sizedBVSelect (Proxy @2) (Proxy @3) (con 0b010100 :: SymIntN 6) + -- 0b101 + sizedBVSelect :: + (KnownNat n, KnownNat ix, KnownNat w, 1 <= n, 1 <= w, ix + w <= n) => + -- | Index of the least significant bit of the slice + p ix -> + -- | Desired output width, @ix + w <= n@ must hold where @n@ is + -- the size of the input bit vector + q w -> + -- | Bit vector to select from + bv n -> + bv w + + -- Analogous to 'fromIntegral'. + sizedBVFromIntegral :: (Integral a, KnownNat n, 1 <= n) => a -> bv n + default sizedBVFromIntegral :: + (Num (bv n), Integral a, KnownNat n, 1 <= n) => a -> bv n + sizedBVFromIntegral = fromIntegral + +-- | Slicing out a smaller bit vector from a larger one, extract a slice from +-- bit @i@ down to @j@. +-- +-- The least significant bit is indexed as 0. +-- +-- >>> sizedBVExtract (Proxy @4) (Proxy @2) (con 0b010100 :: SymIntN 6) +-- 0b101 +sizedBVExtract :: + forall p i q j n bv. + (SizedBV bv, KnownNat n, KnownNat i, KnownNat j, 1 <= n, i + 1 <= n, j <= i) => + -- | The start position to extract from, @i < n@ must hold where @n@ is + -- the size of the output bit vector + p i -> + -- | The end position to extract from, @j <= i@ must hold + q j -> + -- | Bit vector to extract from + bv n -> + bv (i - j + 1) +sizedBVExtract _ _ = + case ( hasRepr (addNat (subNat (natRepr @i) (natRepr @j)) (natRepr @1)), + unsafeLeqProof @(j + (i - j + 1)) @n, + unsafeLeqProof @1 @(i - j + 1) + ) of + (KnownProof, LeqProof, LeqProof) -> + sizedBVSelect (Proxy @j) (Proxy @(i - j + 1)) +{-# INLINE sizedBVExtract #-} diff --git a/src/Grisette/Internal/Core/Data/Class/CEGISSolver.hs b/src/Grisette/Internal/Core/Data/Class/CEGISSolver.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Core/Data/Class/CEGISSolver.hs @@ -0,0 +1,616 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Trustworthy #-} + +-- | +-- Module : Grisette.Internal.Core.Data.Class.CEGISSolver +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Core.Data.Class.CEGISSolver + ( -- * Note for the examples + + -- + + -- | The examples assumes that the [z3](https://github.com/Z3Prover/z3) + -- solver is available in @PATH@. + + -- * Generic CEGIS interface + SynthesisConstraintFun, + VerifierResult (..), + StatefulVerifierFun, + CEGISResult (..), + genericCEGIS, + + -- * CEGIS interfaces with pre/post conditions + CEGISCondition (..), + cegisPostCond, + cegisPrePost, + cegisMultiInputs, + cegis, + cegisExcept, + cegisExceptStdVC, + cegisExceptVC, + cegisExceptMultiInputs, + cegisExceptStdVCMultiInputs, + cegisExceptVCMultiInputs, + cegisForAll, + cegisForAllExcept, + cegisForAllExceptStdVC, + cegisForAllExceptVC, + ) +where + +import Control.Monad (foldM, unless) +import Data.List (partition) +import GHC.Generics (Generic) +import Generics.Deriving (Default (Default)) +import Grisette.Internal.Core.Control.Exception + ( VerificationConditions (AssertionViolation, AssumptionViolation), + ) +import Grisette.Internal.Core.Data.Class.EvaluateSym (EvaluateSym, evaluateSym) +import Grisette.Internal.Core.Data.Class.ExtractSymbolics + ( ExtractSymbolics, + extractSymbolics, + ) +import Grisette.Internal.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.&&))) +import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) +import Grisette.Internal.Core.Data.Class.ModelOps + ( ModelOps (exact, exceptFor), + SymbolSetOps (isEmptySet), + ) +import Grisette.Internal.Core.Data.Class.PlainUnion + ( PlainUnion, + simpleMerge, + ) +import Grisette.Internal.Core.Data.Class.SEq (SEq) +import Grisette.Internal.Core.Data.Class.SimpleMergeable + ( SimpleMergeable, + ) +import Grisette.Internal.Core.Data.Class.Solvable (Solvable (con)) +import Grisette.Internal.Core.Data.Class.Solver + ( ConfigurableSolver, + Solver (solverSolve), + SolvingFailure (Unsat), + UnionWithExcept (extractUnionExcept), + solve, + withSolver, + ) +import Grisette.Internal.SymPrim.Prim.Model (Model) +import Grisette.Internal.SymPrim.SymBool (SymBool) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.Lib.Base +-- >>> import Grisette.SymPrim +-- >>> import Grisette.Backend + +-- | Synthesis constraint function. +-- +-- The first argument is the iteration number, for angelic programs, you can use +-- it to instantiate the angelic variables in the program. +-- +-- The second argument is the counter-example generated by the verifier. +-- +-- The synthesizer will try to find a program that is true for all the synthesis +-- constraints. +type SynthesisConstraintFun input = Int -> input -> IO SymBool + +-- | The result of the verifier. +data VerifierResult input exception + = CEGISVerifierFoundCex input + | CEGISVerifierNoCex + | CEGISVerifierException exception + +-- | The verifier function. +-- +-- The first argument is the state of the verifier. +-- +-- The second argument is the candidate model proposed by the synthesizer. +type StatefulVerifierFun state input exception = + state -> Model -> IO (state, VerifierResult input exception) + +-- | The result of the CEGIS procedure. +data CEGISResult exception + = CEGISSuccess Model + | CEGISVerifierFailure exception + | CEGISSolverFailure SolvingFailure + deriving (Show) + +-- | Generic CEGIS procedure. +-- +-- The CEGIS procedure will try to find a model that satisfies the initial +-- synthesis constraint, and satisfies all the inputs generated by the verifier. +genericCEGIS :: + (ConfigurableSolver config handle) => + -- | Configuration of the solver. + config -> + -- | The initial synthesis constraint. + SymBool -> + -- | The synthesis constraint function. + SynthesisConstraintFun input -> + -- | The initial state of the verifier. + verifierState -> + -- | The verifier function. + StatefulVerifierFun verifierState input exception -> + IO ([input], CEGISResult exception) +genericCEGIS config initConstr synthConstr initVerifierState verifier = + withSolver config $ \solver -> do + firstResult <- solverSolve solver initConstr + case firstResult of + Left err -> return ([], CEGISSolverFailure err) + Right model -> go solver model 0 initVerifierState + where + go solver prevModel iterNum verifierState = do + (newVerifierState, verifierResult) <- + verifier verifierState prevModel + case verifierResult of + CEGISVerifierFoundCex cex -> do + newResult <- solverSolve solver =<< synthConstr iterNum cex + case newResult of + Left err -> return ([], CEGISSolverFailure err) + Right model -> do + (cexes, result) <- go solver model (iterNum + 1) newVerifierState + return (cex : cexes, result) + CEGISVerifierNoCex -> return ([], CEGISSuccess prevModel) + CEGISVerifierException exception -> + return ([], CEGISVerifierFailure exception) + +data CEGISMultiInputsState input = CEGISMultiInputsState + { _cegisMultiInputsRemainingSymInputs :: [input], + _cegisMultiInputsPre :: SymBool, + _cegisMultiInputsPost :: SymBool + } + +-- | The condition for CEGIS to solve. +-- +-- The first argument is the pre-condition, and the second argument is the +-- post-condition. +-- +-- The CEGIS procedures would try to find a model for the formula +-- +-- \[ +-- \forall P. (\exists I. \mathrm{pre}(P, I)) \wedge (\forall I. \mathrm{pre}(P, I)\implies \mathrm{post}(P, I)) +-- \] +-- +-- In program synthesis tasks, \(P\) is the symbolic constants in the symbolic +-- program, and \(I\) is the input. The pre-condition is used to restrict the +-- search space of the program. The procedure would only return programs that +-- meets the pre-conditions on every possible inputs, and there are at least +-- one possible input. The post-condition is used to specify the desired program +-- behaviors. +data CEGISCondition = CEGISCondition SymBool SymBool + deriving (Generic) + deriving (EvaluateSym) via (Default CEGISCondition) + +-- | Construct a CEGIS condition with only a post-condition. The pre-condition +-- would be set to true, meaning that all programs in the program space are +-- allowed. +cegisPostCond :: SymBool -> CEGISCondition +cegisPostCond = CEGISCondition (con True) + +-- | Construct a CEGIS condition with both pre- and post-conditions. +cegisPrePost :: SymBool -> SymBool -> CEGISCondition +cegisPrePost = CEGISCondition + +deriving via (Default CEGISCondition) instance Mergeable CEGISCondition + +deriving via (Default CEGISCondition) instance SimpleMergeable CEGISCondition + +-- | +-- CEGIS with multiple (possibly symbolic) inputs. Solves the following formula +-- (see 'CEGISCondition' for details). +-- +-- \[ +-- \forall P. (\exists I\in\mathrm{inputs}. \mathrm{pre}(P, I)) \wedge (\forall I\in\mathrm{inputs}. \mathrm{pre}(P, I)\implies \mathrm{post}(P, I)) +-- \] +-- +-- For simpler queries, where the inputs are representable by a single +-- symbolic value, you may want to use 'cegis' or 'cegisExcept' instead. +-- We have an example for the 'cegis' call. +cegisMultiInputs :: + ( EvaluateSym input, + ExtractSymbolics input, + ConfigurableSolver config handle + ) => + config -> + [input] -> + (input -> CEGISCondition) -> + IO ([input], CEGISResult SolvingFailure) +cegisMultiInputs config inputs toCEGISCondition = do + initConstr <- cexesAssertFun conInputs + genericCEGIS + config + initConstr + synthConstr + (CEGISMultiInputsState symInputs (con True) (con True)) + verifier + where + (conInputs, symInputs) = partition (isEmptySet . extractSymbolics) inputs + forallSymbols = extractSymbolics symInputs + cexAssertFun input = do + unless (isEmptySet (extractSymbolics input)) $ error "BUG" + CEGISCondition pre post <- return $ toCEGISCondition input + return $ pre .&& post + cexesAssertFun = foldM (\acc x -> (acc .&&) <$> cexAssertFun x) (con True) + synthConstr _ = cexAssertFun + verifier state@(CEGISMultiInputsState [] _ _) _ = + return (state, CEGISVerifierNoCex) + verifier + (CEGISMultiInputsState (nextSymInput : symInputs) pre post) + candidate = do + CEGISCondition nextPre nextPost <- + return $ toCEGISCondition nextSymInput + let newPre = pre .&& nextPre + let newPost = post .&& nextPost + let evaluated = + evaluateSym False (exceptFor forallSymbols candidate) $ + newPre .&& symNot newPost + r <- solve config evaluated + case r of + Left Unsat -> + verifier (CEGISMultiInputsState symInputs newPre newPost) candidate + Left err -> + return + ( CEGISMultiInputsState [] newPre newPost, + CEGISVerifierException err + ) + Right model -> + return + ( CEGISMultiInputsState (nextSymInput : symInputs) newPre newPost, + CEGISVerifierFoundCex $ + evaluateSym False (exact forallSymbols model) nextSymInput + ) + +-- | +-- CEGIS with a single symbolic input to represent a set of inputs. +-- +-- The following example tries to find the value of @c@ such that for all +-- positive @x@, @x * c < 0 && c > -2@. The @c .> -2@ clause is used to make +-- the solution unique. +-- +-- >>> :set -XOverloadedStrings +-- >>> let [x,c] = ["x","c"] :: [SymInteger] +-- >>> cegis (precise z3) x (\x -> cegisPrePost (x .> 0) (x * c .< 0 .&& c .> -2)) +-- (...,CEGISSuccess (Model {c -> -1 :: Integer})) +cegis :: + ( ConfigurableSolver config handle, + EvaluateSym inputs, + ExtractSymbolics inputs, + SEq inputs + ) => + -- | The configuration of the solver + config -> + -- | Initial symbolic inputs. The solver will try to find a + -- program that works on all the inputs representable by it (see + -- 'CEGISCondition'). + inputs -> + -- | The condition for the solver to solve. All the + -- symbolic constants that are not in the inputs will + -- be considered as part of the symbolic program. + (inputs -> CEGISCondition) -> + -- | The counter-examples generated + -- during the CEGIS loop, and the + -- model found by the solver. + IO ([inputs], CEGISResult SolvingFailure) +cegis config inputs = cegisMultiInputs config [inputs] + +-- | +-- CEGIS for symbolic programs with error handling, using multiple (possibly +-- symbolic) inputs to represent a set of inputs. +cegisExceptMultiInputs :: + ( ConfigurableSolver config handle, + EvaluateSym inputs, + ExtractSymbolics inputs, + UnionWithExcept t u e v, + PlainUnion u, + Monad u + ) => + config -> + [inputs] -> + (Either e v -> CEGISCondition) -> + (inputs -> t) -> + IO ([inputs], CEGISResult SolvingFailure) +cegisExceptMultiInputs config cexes interpretFun f = + cegisMultiInputs + config + cexes + (simpleMerge . (interpretFun <$>) . extractUnionExcept . f) + +-- | +-- CEGIS for symbolic programs with error handling, using multiple (possibly +-- symbolic) inputs to represent a set of inputs. +-- +-- The errors should be translated to assertion or assumption violations. +cegisExceptVCMultiInputs :: + ( ConfigurableSolver config handle, + EvaluateSym inputs, + ExtractSymbolics inputs, + UnionWithExcept t u e v, + PlainUnion u, + Monad u + ) => + config -> + [inputs] -> + (Either e v -> u (Either VerificationConditions ())) -> + (inputs -> t) -> + IO ([inputs], CEGISResult SolvingFailure) +cegisExceptVCMultiInputs config cexes interpretFun f = + cegisMultiInputs + config + cexes + ( \v -> + simpleMerge + ( ( \case + Left AssumptionViolation -> cegisPrePost (con False) (con True) + Left AssertionViolation -> cegisPostCond (con False) + _ -> cegisPostCond (con True) + ) + <$> (extractUnionExcept (f v) >>= interpretFun) + ) + ) + +-- | +-- CEGIS for symbolic programs with error handling, using multiple (possibly +-- symbolic) inputs to represent a set of inputs. This function saves the +-- efforts to implement the translation function for the standard error type +-- 'VerificationConditions', and the standard result type '()'. +-- +-- This function translates assumption violations to failed pre-conditions, +-- and translates assertion violations to failed post-conditions. +-- The '()' result will not fail any conditions. +cegisExceptStdVCMultiInputs :: + ( ConfigurableSolver config handle, + EvaluateSym inputs, + ExtractSymbolics inputs, + UnionWithExcept t u VerificationConditions (), + PlainUnion u, + Monad u + ) => + config -> + [inputs] -> + (inputs -> t) -> + IO ([inputs], CEGISResult SolvingFailure) +cegisExceptStdVCMultiInputs config cexes = + cegisExceptVCMultiInputs config cexes return + +-- | +-- CEGIS for symbolic programs with error handling, using a single symbolic +-- input to represent a set of inputs. +-- +-- 'cegisExcept' is particularly useful when custom error types are used. +-- With 'cegisExcept', you define how the errors are interpreted to the +-- CEGIS conditions after the symbolic evaluation. This could increase the +-- readability and modularity of the code. +-- +-- The following example tries to find the value of @c@ such that for all +-- positive @x@, @x * c < 0 && c > -2@. The @c .> -2@ assertion is used to make +-- the solution unique. +-- +-- >>> :set -XOverloadedStrings +-- >>> let [x,c] = ["x","c"] :: [SymInteger] +-- >>> import Control.Monad.Except +-- >>> :{ +-- res :: SymInteger -> ExceptT VerificationConditions UnionM () +-- res x = do +-- symAssume $ x .> 0 +-- symAssert $ x * c .< 0 +-- symAssert $ c .> -2 +-- :} +-- +-- >>> :{ +-- translation (Left AssumptionViolation) = cegisPrePost (con False) (con True) +-- translation (Left AssertionViolation) = cegisPostCond (con False) +-- translation _ = cegisPostCond (con True) +-- :} +-- +-- >>> cegisExcept (precise z3) x translation res +-- ([...],CEGISSuccess (Model {c -> -1 :: Integer})) +cegisExcept :: + ( UnionWithExcept t u e v, + PlainUnion u, + Functor u, + EvaluateSym inputs, + ExtractSymbolics inputs, + ConfigurableSolver config handle, + SEq inputs + ) => + config -> + inputs -> + (Either e v -> CEGISCondition) -> + (inputs -> t) -> + IO ([inputs], CEGISResult SolvingFailure) +cegisExcept config inputs f v = + cegis config inputs $ \i -> simpleMerge $ f <$> extractUnionExcept (v i) + +-- | +-- CEGIS for symbolic programs with error handling, using a single symbolic +-- input to represent a set of inputs. +-- +-- The errors should be translated to assertion or assumption violations. +cegisExceptVC :: + ( UnionWithExcept t u e v, + PlainUnion u, + Monad u, + EvaluateSym inputs, + ExtractSymbolics inputs, + ConfigurableSolver config handle, + SEq inputs + ) => + config -> + inputs -> + (Either e v -> u (Either VerificationConditions ())) -> + (inputs -> t) -> + IO ([inputs], CEGISResult SolvingFailure) +cegisExceptVC config inputs f v = do + cegis config inputs $ \i -> + simpleMerge $ + ( \case + Left AssumptionViolation -> cegisPrePost (con False) (con True) + Left AssertionViolation -> cegisPostCond (con False) + _ -> cegisPostCond (con True) + ) + <$> (extractUnionExcept (v i) >>= f) + +-- | +-- CEGIS for symbolic programs with error handling, using a single symbolic +-- input to represent a set of inputs. This function saves the efforts to +-- implement the translation function for the standard error type +-- 'VerificationConditions', and the standard result type '()'. +-- +-- This function translates assumption violations to failed pre-conditions, +-- and translates assertion violations to failed post-conditions. +-- The '()' result will not fail any conditions. +-- +-- The following example tries to find the value of @c@ such that for all +-- positive @x@, @x * c < 0 && c > -2@. The @c .> -2@ assertion is used to make +-- the solution unique. +-- +-- >>> :set -XOverloadedStrings +-- >>> let [x,c] = ["x","c"] :: [SymInteger] +-- >>> import Control.Monad.Except +-- >>> :{ +-- res :: SymInteger -> ExceptT VerificationConditions UnionM () +-- res x = do +-- symAssume $ x .> 0 +-- symAssert $ x * c .< 0 +-- symAssert $ c .> -2 +-- :} +-- +-- >>> cegisExceptStdVC (precise z3) x res +-- ([...],CEGISSuccess (Model {c -> -1 :: Integer})) +cegisExceptStdVC :: + ( UnionWithExcept t u VerificationConditions (), + PlainUnion u, + Monad u, + EvaluateSym inputs, + ExtractSymbolics inputs, + ConfigurableSolver config handle, + SEq inputs + ) => + config -> + inputs -> + (inputs -> t) -> + IO ([inputs], CEGISResult SolvingFailure) +cegisExceptStdVC config inputs = cegisExceptVC config inputs return + +-- | +-- CEGIS with a single symbolic input to represent a set of inputs. +-- +-- The following example tries to find the value of @c@ such that for all +-- positive @x@, @x * c < 0 && c > -2@. The @c .> -2@ clause is used to make +-- the solution unique. +-- +-- >>> :set -XOverloadedStrings +-- >>> let [x,c] = ["x","c"] :: [SymInteger] +-- >>> cegisForAll (precise z3) x $ cegisPrePost (x .> 0) (x * c .< 0 .&& c .> -2) +-- (...,CEGISSuccess (Model {c -> -1 :: Integer})) +cegisForAll :: + ( ExtractSymbolics forallInput, + ConfigurableSolver config handle + ) => + config -> + -- | A symbolic value. All the symbolic constants in the value are treated as + -- for-all variables. + forallInput -> + CEGISCondition -> + -- | First output are the counter-examples for all the for-all variables, and + -- the second output is the model for all other variables if CEGIS succeeds. + IO ([Model], CEGISResult SolvingFailure) +cegisForAll config input (CEGISCondition pre post) = do + (models, result) <- genericCEGIS config phi synthConstr () verifier + let exactResult = case result of + CEGISSuccess model -> CEGISSuccess $ exceptFor forallSymbols model + _ -> result + return (models, exactResult) + where + phi = pre .&& post + negphi = pre .&& symNot post + forallSymbols = extractSymbolics input + synthConstr _ model = return $ evaluateSym False model phi + verifier () candidate = do + let evaluated = + evaluateSym False (exceptFor forallSymbols candidate) negphi + r <- solve config evaluated + case r of + Left Unsat -> return ((), CEGISVerifierNoCex) + Left err -> return ((), CEGISVerifierException err) + Right model -> + return ((), CEGISVerifierFoundCex $ exact forallSymbols model) + +-- | +-- CEGIS for symbolic programs with error handling, with a forall variable. +-- +-- See 'cegisForAll' and 'cegisExcept'. +cegisForAllExcept :: + ( UnionWithExcept t u e v, + PlainUnion u, + Functor u, + EvaluateSym inputs, + ExtractSymbolics inputs, + ConfigurableSolver config handle, + SEq inputs + ) => + config -> + inputs -> + (Either e v -> CEGISCondition) -> + t -> + IO ([Model], CEGISResult SolvingFailure) +cegisForAllExcept config inputs f v = + cegisForAll config inputs $ simpleMerge $ f <$> extractUnionExcept v + +-- | +-- CEGIS for symbolic programs with error handling, with a forall variable. +-- +-- See 'cegisForAll' and 'cegisExceptVC'. +cegisForAllExceptVC :: + ( UnionWithExcept t u e v, + PlainUnion u, + Monad u, + EvaluateSym inputs, + ExtractSymbolics inputs, + ConfigurableSolver config handle, + SEq inputs + ) => + config -> + inputs -> + (Either e v -> u (Either VerificationConditions ())) -> + t -> + IO ([Model], CEGISResult SolvingFailure) +cegisForAllExceptVC config inputs f v = do + cegisForAll config inputs $ + simpleMerge $ + ( \case + Left AssumptionViolation -> cegisPrePost (con False) (con True) + Left AssertionViolation -> cegisPostCond (con False) + _ -> cegisPostCond (con True) + ) + <$> (extractUnionExcept v >>= f) + +-- | +-- CEGIS for symbolic programs with error handling, with a forall variable. +-- +-- See 'cegisForAll' and 'cegisExceptStdVC'. +cegisForAllExceptStdVC :: + ( UnionWithExcept t u VerificationConditions (), + PlainUnion u, + Monad u, + EvaluateSym inputs, + ExtractSymbolics inputs, + ConfigurableSolver config handle, + SEq inputs + ) => + config -> + inputs -> + t -> + IO ([Model], CEGISResult SolvingFailure) +cegisForAllExceptStdVC config inputs = cegisForAllExceptVC config inputs return diff --git a/src/Grisette/Internal/Core/Data/Class/Error.hs b/src/Grisette/Internal/Core/Data/Class/Error.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Core/Data/Class/Error.hs @@ -0,0 +1,206 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Trustworthy #-} + +-- | +-- Module : Grisette.Internal.Core.Data.Class.Error +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Core.Data.Class.Error + ( -- * Error transformation + TransformError (..), + + -- * Throwing error + symAssertWith, + symAssertTransformableError, + symThrowTransformableError, + symAssert, + symAssume, + ) +where + +import Control.Exception (ArithException, ArrayException) +import Control.Monad.Except (MonadError (throwError)) +import Grisette.Internal.Core.Control.Exception + ( AssertionError (AssertionError), + VerificationConditions (AssertionViolation, AssumptionViolation), + ) +import Grisette.Internal.Core.Control.Monad.Union (MonadUnion) +import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) +import Grisette.Internal.Core.Data.Class.SimpleMergeable (mrgIf) +import Grisette.Internal.Core.Data.Class.TryMerge (tryMerge) +import Grisette.Internal.SymPrim.SymBool (SymBool) + +-- $setup +-- >>> import Control.Exception +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim +-- >>> import Grisette.Lib.Control.Monad +-- >>> import Control.Monad.Except +-- >>> :set -XOverloadedStrings +-- >>> :set -XFlexibleContexts + +-- | This class indicates that the error type @to@ can always represent the +-- error type @from@. +-- +-- This is useful in implementing generic procedures that may throw errors. +-- For example, we support symbolic division and modulo operations. These +-- operations should throw an error when the divisor is zero, and we use the +-- standard error type 'Control.Exception.ArithException' for this purpose. +-- However, the user may use other type to represent errors, so we need this +-- type class to transform the 'Control.Exception.ArithException' to the +-- user-defined types. +-- +-- Another example of these generic procedures is the +-- 'Grisette.Core.symAssert' and 'Grisette.Core.symAssume' functions. +-- They can be used with any error types that are +-- compatible with the 'Grisette.Core.AssertionError' and +-- 'Grisette.Core.VerificationConditions' types, respectively. +class TransformError from to where + -- | Transforms an error with type @from@ to an error with type @to@. + transformError :: from -> to + +instance {-# OVERLAPPABLE #-} TransformError a a where + transformError = id + {-# INLINE transformError #-} + +instance {-# OVERLAPS #-} TransformError a () where + transformError _ = () + {-# INLINE transformError #-} + +instance {-# OVERLAPPING #-} TransformError () () where + transformError _ = () + {-# INLINE transformError #-} + +-- | Used within a monadic multi path computation to begin exception processing. +-- +-- Terminate the current execution path with the specified error. Compatible +-- errors can be transformed. +-- +-- >>> symThrowTransformableError Overflow :: ExceptT AssertionError UnionM () +-- ExceptT {Left AssertionError} +symThrowTransformableError :: + ( Mergeable to, + Mergeable a, + TransformError from to, + MonadError to erm, + MonadUnion erm + ) => + from -> + erm a +symThrowTransformableError = tryMerge . throwError . transformError +{-# INLINE symThrowTransformableError #-} + +-- | Used within a monadic multi path computation for exception processing. +-- +-- Terminate the current execution path with the specified error if the condition does not hold. +-- Compatible error can be transformed. +-- +-- >>> let assert = symAssertTransformableError AssertionError +-- >>> assert "a" :: ExceptT AssertionError UnionM () +-- ExceptT {If (! a) (Left AssertionError) (Right ())} +symAssertTransformableError :: + ( Mergeable to, + TransformError from to, + MonadError to erm, + MonadUnion erm + ) => + from -> + SymBool -> + erm () +symAssertTransformableError err cond = mrgIf cond (return ()) (symThrowTransformableError err) +{-# INLINE symAssertTransformableError #-} + +symAssertWith :: + ( Mergeable e, + MonadError e erm, + MonadUnion erm + ) => + e -> + SymBool -> + erm () +symAssertWith err cond = mrgIf cond (return ()) (throwError err) +{-# INLINE symAssertWith #-} + +instance TransformError VerificationConditions VerificationConditions where + transformError = id + +instance TransformError AssertionError VerificationConditions where + transformError _ = AssertionViolation + +instance TransformError ArithException AssertionError where + transformError _ = AssertionError + +instance TransformError ArrayException AssertionError where + transformError _ = AssertionError + +instance TransformError AssertionError AssertionError where + transformError = id + +-- | Used within a monadic multi path computation to begin exception processing. +-- +-- Checks the condition passed to the function. +-- The current execution path will be terminated with assertion error if the condition is false. +-- +-- If the condition is symbolic, Grisette will split the execution into two paths based on the condition. +-- The symbolic execution will continue on the then-branch, where the condition is true. +-- For the else branch, where the condition is false, the execution will be terminated. +-- +-- The resulting monadic environment should be compatible with the 'AssertionError' +-- error type. See 'TransformError' type class for details. +-- +-- __/Examples/__: +-- +-- Terminates the execution if the condition is false. +-- Note that we may lose the 'Mergeable' knowledge here if no possible execution +-- path is viable. This may affect the efficiency in theory, but in practice this +-- should not be a problem as all paths are terminated and no further evaluation +-- would be performed. +-- +-- >>> symAssert (con False) :: ExceptT AssertionError UnionM () +-- ExceptT {Left AssertionError} +-- >>> do; symAssert (con False); mrgReturn 1 :: ExceptT AssertionError UnionM Integer +-- ExceptT +-- +-- No effect if the condition is true: +-- +-- >>> symAssert (con True) :: ExceptT AssertionError UnionM () +-- ExceptT {Right ()} +-- >>> do; symAssert (con True); mrgReturn 1 :: ExceptT AssertionError UnionM Integer +-- ExceptT {Right 1} +-- +-- Splitting the path and terminate one of them when the condition is symbolic. +-- +-- >>> symAssert (ssym "a") :: ExceptT AssertionError UnionM () +-- ExceptT {If (! a) (Left AssertionError) (Right ())} +-- >>> do; symAssert (ssym "a"); mrgReturn 1 :: ExceptT AssertionError UnionM Integer +-- ExceptT {If (! a) (Left AssertionError) (Right 1)} +-- +-- 'AssertionError' is compatible with 'VerificationConditions': +-- +-- >>> symAssert (ssym "a") :: ExceptT VerificationConditions UnionM () +-- ExceptT {If (! a) (Left AssertionViolation) (Right ())} +symAssert :: + (TransformError AssertionError to, Mergeable to, MonadError to erm, MonadUnion erm) => + SymBool -> + erm () +symAssert = symAssertTransformableError AssertionError + +-- | Used within a monadic multi path computation to begin exception processing. +-- +-- Similar to 'symAssert', but terminates the execution path with 'AssumptionViolation' error. +-- +-- /Examples/: +-- +-- >>> symAssume (ssym "a") :: ExceptT VerificationConditions UnionM () +-- ExceptT {If (! a) (Left AssumptionViolation) (Right ())} +symAssume :: + (TransformError VerificationConditions to, Mergeable to, MonadError to erm, MonadUnion erm) => + SymBool -> + erm () +symAssume = symAssertTransformableError AssumptionViolation diff --git a/src/Grisette/Internal/Core/Data/Class/EvaluateSym.hs b/src/Grisette/Internal/Core/Data/Class/EvaluateSym.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Core/Data/Class/EvaluateSym.hs @@ -0,0 +1,292 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Core.Data.Class.EvaluateSym +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Core.Data.Class.EvaluateSym + ( -- * Evaluating symbolic values with model + EvaluateSym (..), + evaluateSymToCon, + ) +where + +import Control.Monad.Except (ExceptT (ExceptT)) +import Control.Monad.Identity + ( Identity (Identity), + IdentityT (IdentityT), + ) +import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import qualified Data.ByteString as B +import Data.Functor.Sum (Sum) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Maybe (fromJust) +import qualified Data.Text as T +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.TypeNats (KnownNat, type (<=)) +import Generics.Deriving + ( Default (Default, unDefault), + Generic (Rep, from, to), + K1 (K1), + M1 (M1), + U1, + V1, + type (:*:) ((:*:)), + type (:+:) (L1, R1), + ) +import Generics.Deriving.Instances () +import Grisette.Internal.Core.Control.Exception (AssertionError, VerificationConditions) +import Grisette.Internal.Core.Data.Class.ToCon (ToCon (toCon)) +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.GeneralFun (type (-->)) +import Grisette.Internal.SymPrim.Prim.Model (Model, evaluateTerm) +import Grisette.Internal.SymPrim.Prim.Term (LinkedRep, SupportedPrim) +import Grisette.Internal.SymPrim.SymBV + ( SymIntN (SymIntN), + SymWordN (SymWordN), + ) +import Grisette.Internal.SymPrim.SymBool (SymBool (SymBool)) +import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>) (SymGeneralFun)) +import Grisette.Internal.SymPrim.SymInteger (SymInteger (SymInteger)) +import Grisette.Internal.SymPrim.SymTabularFun (type (=~>) (SymTabularFun)) +import Grisette.Internal.SymPrim.TabularFun (type (=->)) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim +-- >>> import Data.Proxy +-- >>> :set -XTypeApplications + +-- | Evaluating symbolic values with some model. +-- +-- >>> let model = insertValue "a" (1 :: Integer) emptyModel :: Model +-- >>> evaluateSym False model ([ssym "a", ssym "b"] :: [SymInteger]) +-- [1,b] +-- +-- If we set the first argument true, the missing variables will be filled in with +-- some default values: +-- +-- >>> evaluateSym True model ([ssym "a", ssym "b"] :: [SymInteger]) +-- [1,0] +-- +-- __Note 1:__ This type class can be derived for algebraic data types. +-- You may need the @DerivingVia@ and @DerivingStrategies@ extensions. +-- +-- > data X = ... deriving Generic deriving EvaluateSym via (Default X) +class EvaluateSym a where + -- | Evaluate a symbolic variable with some model, possibly fill in values for the missing variables. + evaluateSym :: Bool -> Model -> a -> a + +-- | Evaluate a symbolic variable with some model, fill in values for the missing variables, +-- and transform to concrete ones +-- +-- >>> let model = insertValue "a" (1 :: Integer) emptyModel :: Model +-- >>> evaluateSymToCon model ([ssym "a", ssym "b"] :: [SymInteger]) :: [Integer] +-- [1,0] +evaluateSymToCon :: (ToCon a b, EvaluateSym a) => Model -> a -> b +evaluateSymToCon model a = fromJust $ toCon $ evaluateSym True model a + +-- instances + +#define CONCRETE_EVALUATESYM(type) \ +instance EvaluateSym type where \ + evaluateSym _ _ = id + +#define CONCRETE_EVALUATESYM_BV(type) \ +instance (KnownNat n, 1 <= n) => EvaluateSym (type n) where \ + evaluateSym _ _ = id + +#if 1 +CONCRETE_EVALUATESYM(Bool) +CONCRETE_EVALUATESYM(Integer) +CONCRETE_EVALUATESYM(Char) +CONCRETE_EVALUATESYM(Int) +CONCRETE_EVALUATESYM(Int8) +CONCRETE_EVALUATESYM(Int16) +CONCRETE_EVALUATESYM(Int32) +CONCRETE_EVALUATESYM(Int64) +CONCRETE_EVALUATESYM(Word) +CONCRETE_EVALUATESYM(Word8) +CONCRETE_EVALUATESYM(Word16) +CONCRETE_EVALUATESYM(Word32) +CONCRETE_EVALUATESYM(Word64) +CONCRETE_EVALUATESYM(B.ByteString) +CONCRETE_EVALUATESYM(T.Text) +CONCRETE_EVALUATESYM_BV(IntN) +CONCRETE_EVALUATESYM_BV(WordN) +#endif + +-- () +instance EvaluateSym () where + evaluateSym _ _ = id + +-- Either +deriving via (Default (Either a b)) instance (EvaluateSym a, EvaluateSym b) => EvaluateSym (Either a b) + +-- Maybe +deriving via (Default (Maybe a)) instance (EvaluateSym a) => EvaluateSym (Maybe a) + +-- List +deriving via (Default [a]) instance (EvaluateSym a) => EvaluateSym [a] + +-- (,) +deriving via (Default (a, b)) instance (EvaluateSym a, EvaluateSym b) => EvaluateSym (a, b) + +-- (,,) +deriving via (Default (a, b, c)) instance (EvaluateSym a, EvaluateSym b, EvaluateSym c) => EvaluateSym (a, b, c) + +-- (,,,) +deriving via + (Default (a, b, c, d)) + instance + (EvaluateSym a, EvaluateSym b, EvaluateSym c, EvaluateSym d) => EvaluateSym (a, b, c, d) + +-- (,,,,) +deriving via + (Default (a, b, c, d, e)) + instance + (EvaluateSym a, EvaluateSym b, EvaluateSym c, EvaluateSym d, EvaluateSym e) => + EvaluateSym (a, b, c, d, e) + +-- (,,,,,) +deriving via + (Default (a, b, c, d, e, f)) + instance + (EvaluateSym a, EvaluateSym b, EvaluateSym c, EvaluateSym d, EvaluateSym e, EvaluateSym f) => + EvaluateSym (a, b, c, d, e, f) + +-- (,,,,,,) +deriving via + (Default (a, b, c, d, e, f, g)) + instance + ( EvaluateSym a, + EvaluateSym b, + EvaluateSym c, + EvaluateSym d, + EvaluateSym e, + EvaluateSym f, + EvaluateSym g + ) => + EvaluateSym (a, b, c, d, e, f, g) + +-- (,,,,,,,) +deriving via + (Default (a, b, c, d, e, f, g, h)) + instance + ( EvaluateSym a, + EvaluateSym b, + EvaluateSym c, + EvaluateSym d, + EvaluateSym e, + EvaluateSym f, + EvaluateSym g, + EvaluateSym h + ) => + EvaluateSym ((,,,,,,,) a b c d e f g h) + +-- MaybeT +instance (EvaluateSym (m (Maybe a))) => EvaluateSym (MaybeT m a) where + evaluateSym fillDefault model (MaybeT v) = MaybeT $ evaluateSym fillDefault model v + +-- ExceptT +instance (EvaluateSym (m (Either e a))) => EvaluateSym (ExceptT e m a) where + evaluateSym fillDefault model (ExceptT v) = ExceptT $ evaluateSym fillDefault model v + +-- Sum +deriving via + (Default (Sum f g a)) + instance + (EvaluateSym (f a), EvaluateSym (g a)) => EvaluateSym (Sum f g a) + +-- WriterT +instance (EvaluateSym (m (a, s))) => EvaluateSym (WriterLazy.WriterT s m a) where + evaluateSym fillDefault model (WriterLazy.WriterT v) = WriterLazy.WriterT $ evaluateSym fillDefault model v + +instance (EvaluateSym (m (a, s))) => EvaluateSym (WriterStrict.WriterT s m a) where + evaluateSym fillDefault model (WriterStrict.WriterT v) = WriterStrict.WriterT $ evaluateSym fillDefault model v + +-- Identity +instance (EvaluateSym a) => EvaluateSym (Identity a) where + evaluateSym fillDefault model (Identity a) = Identity $ evaluateSym fillDefault model a + +-- IdentityT +instance (EvaluateSym (m a)) => EvaluateSym (IdentityT m a) where + evaluateSym fillDefault model (IdentityT a) = IdentityT $ evaluateSym fillDefault model a + +-- Symbolic primitives +#define EVALUATE_SYM_SIMPLE(symtype) \ +instance EvaluateSym symtype where \ + evaluateSym fillDefault model (symtype t) = symtype $ evaluateTerm fillDefault model t + +#define EVALUATE_SYM_BV(symtype) \ +instance (KnownNat n, 1 <= n) => EvaluateSym (symtype n) where \ + evaluateSym fillDefault model (symtype t) = symtype $ evaluateTerm fillDefault model t + +#define EVALUATE_SYM_FUN(cop, op, cons) \ +instance (SupportedPrim (cop ca cb), LinkedRep ca sa, LinkedRep cb sb) => \ + EvaluateSym (op sa sb) where \ + evaluateSym fillDefault model (cons t) = \ + cons $ evaluateTerm fillDefault model t + +#if 1 +EVALUATE_SYM_SIMPLE(SymBool) +EVALUATE_SYM_SIMPLE(SymInteger) +EVALUATE_SYM_BV(SymIntN) +EVALUATE_SYM_BV(SymWordN) +EVALUATE_SYM_FUN((=->), (=~>), SymTabularFun) +EVALUATE_SYM_FUN((-->), (-~>), SymGeneralFun) +#endif + +-- Exception +deriving via (Default AssertionError) instance EvaluateSym AssertionError + +deriving via (Default VerificationConditions) instance EvaluateSym VerificationConditions + +instance (Generic a, EvaluateSym' (Rep a)) => EvaluateSym (Default a) where + evaluateSym fillDefault model = + Default . to . evaluateSym' fillDefault model . from . unDefault + +class EvaluateSym' a where + evaluateSym' :: Bool -> Model -> a c -> a c + +instance EvaluateSym' U1 where + evaluateSym' _ _ = id + {-# INLINE evaluateSym' #-} + +instance EvaluateSym' V1 where + evaluateSym' _ _ = id + {-# INLINE evaluateSym' #-} + +instance (EvaluateSym c) => EvaluateSym' (K1 i c) where + evaluateSym' fillDefault model (K1 v) = K1 $ evaluateSym fillDefault model v + {-# INLINE evaluateSym' #-} + +instance (EvaluateSym' a) => EvaluateSym' (M1 i c a) where + evaluateSym' fillDefault model (M1 v) = M1 $ evaluateSym' fillDefault model v + {-# INLINE evaluateSym' #-} + +instance (EvaluateSym' a, EvaluateSym' b) => EvaluateSym' (a :+: b) where + evaluateSym' fillDefault model (L1 l) = L1 $ evaluateSym' fillDefault model l + evaluateSym' fillDefault model (R1 r) = R1 $ evaluateSym' fillDefault model r + {-# INLINE evaluateSym' #-} + +instance (EvaluateSym' a, EvaluateSym' b) => EvaluateSym' (a :*: b) where + evaluateSym' fillDefault model (a :*: b) = + evaluateSym' fillDefault model a :*: evaluateSym' fillDefault model b + {-# INLINE evaluateSym' #-} diff --git a/src/Grisette/Internal/Core/Data/Class/ExtractSymbolics.hs b/src/Grisette/Internal/Core/Data/Class/ExtractSymbolics.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Core/Data/Class/ExtractSymbolics.hs @@ -0,0 +1,320 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Core.Data.Class.ExtractSymbolics +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Core.Data.Class.ExtractSymbolics + ( -- * Extracting symbolic constant set from a value + ExtractSymbolics (..), + ) +where + +import Control.Monad.Except (ExceptT (ExceptT)) +import Control.Monad.Identity + ( Identity (Identity), + IdentityT (IdentityT), + ) +import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import qualified Data.ByteString as B +import Data.Functor.Sum (Sum) +import Data.Int (Int16, Int32, Int64, Int8) +import qualified Data.Text as T +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.TypeNats (KnownNat, type (<=)) +import Generics.Deriving + ( Default (Default, unDefault), + Generic (Rep, from), + K1 (unK1), + M1 (unM1), + U1, + V1, + type (:*:) ((:*:)), + type (:+:) (L1, R1), + ) +import Grisette.Internal.Core.Control.Exception (AssertionError, VerificationConditions) +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.GeneralFun (type (-->)) +import Grisette.Internal.SymPrim.Prim.Model + ( SymbolSet (SymbolSet), + ) +import Grisette.Internal.SymPrim.Prim.Term + ( LinkedRep, + SupportedPrim, + ) +import Grisette.Internal.SymPrim.Prim.TermUtils (extractSymbolicsTerm) +import Grisette.Internal.SymPrim.SymBV + ( SymIntN (SymIntN), + SymWordN (SymWordN), + ) +import Grisette.Internal.SymPrim.SymBool (SymBool (SymBool)) +import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>) (SymGeneralFun)) +import Grisette.Internal.SymPrim.SymInteger (SymInteger (SymInteger)) +import Grisette.Internal.SymPrim.SymTabularFun (type (=~>) (SymTabularFun)) +import Grisette.Internal.SymPrim.TabularFun (type (=->)) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim +-- >>> import Grisette.Lib.Base +-- >>> import Data.HashSet as HashSet +-- >>> import Data.List (sort) + +-- | Extracts all the symbolic variables that are transitively contained in the given value. +-- +-- >>> extractSymbolics ("a" :: SymBool) :: SymbolSet +-- SymbolSet {a :: Bool} +-- +-- >>> extractSymbolics (mrgIf "a" (mrgReturn ["b"]) (mrgReturn ["c", "d"]) :: UnionM [SymBool]) :: SymbolSet +-- SymbolSet {a :: Bool, b :: Bool, c :: Bool, d :: Bool} +-- +-- __Note 1:__ This type class can be derived for algebraic data types. +-- You may need the @DerivingVia@ and @DerivingStrategies@ extensions. +-- +-- > data X = ... deriving Generic deriving ExtractSymbolics via (Default X) +class ExtractSymbolics a where + extractSymbolics :: a -> SymbolSet + +-- instances +#define CONCRETE_EXTRACT_SYMBOLICS(type) \ +instance ExtractSymbolics type where \ + extractSymbolics _ = mempty + +#define CONCRETE_EXTRACT_SYMBOLICS_BV(type) \ +instance (KnownNat n, 1 <= n) => ExtractSymbolics (type n) where \ + extractSymbolics _ = mempty + +#if 1 +CONCRETE_EXTRACT_SYMBOLICS(Bool) +CONCRETE_EXTRACT_SYMBOLICS(Integer) +CONCRETE_EXTRACT_SYMBOLICS(Char) +CONCRETE_EXTRACT_SYMBOLICS(Int) +CONCRETE_EXTRACT_SYMBOLICS(Int8) +CONCRETE_EXTRACT_SYMBOLICS(Int16) +CONCRETE_EXTRACT_SYMBOLICS(Int32) +CONCRETE_EXTRACT_SYMBOLICS(Int64) +CONCRETE_EXTRACT_SYMBOLICS(Word) +CONCRETE_EXTRACT_SYMBOLICS(Word8) +CONCRETE_EXTRACT_SYMBOLICS(Word16) +CONCRETE_EXTRACT_SYMBOLICS(Word32) +CONCRETE_EXTRACT_SYMBOLICS(Word64) +CONCRETE_EXTRACT_SYMBOLICS(B.ByteString) +CONCRETE_EXTRACT_SYMBOLICS(T.Text) +CONCRETE_EXTRACT_SYMBOLICS_BV(WordN) +CONCRETE_EXTRACT_SYMBOLICS_BV(IntN) +#endif + +-- () +instance ExtractSymbolics () where + extractSymbolics _ = mempty + +-- Either +deriving via + (Default (Either a b)) + instance + (ExtractSymbolics a, ExtractSymbolics b) => + ExtractSymbolics (Either a b) + +-- Maybe +deriving via + (Default (Maybe a)) + instance + (ExtractSymbolics a) => ExtractSymbolics (Maybe a) + +-- List +deriving via + (Default [a]) + instance + (ExtractSymbolics a) => ExtractSymbolics [a] + +-- (,) +deriving via + (Default (a, b)) + instance + (ExtractSymbolics a, ExtractSymbolics b) => + ExtractSymbolics (a, b) + +-- (,,) +deriving via + (Default (a, b, c)) + instance + (ExtractSymbolics a, ExtractSymbolics b, ExtractSymbolics c) => + ExtractSymbolics (a, b, c) + +-- (,,,) +deriving via + (Default (a, b, c, d)) + instance + ( ExtractSymbolics a, + ExtractSymbolics b, + ExtractSymbolics c, + ExtractSymbolics d + ) => + ExtractSymbolics (a, b, c, d) + +-- (,,,,) +deriving via + (Default (a, b, c, d, e)) + instance + ( ExtractSymbolics a, + ExtractSymbolics b, + ExtractSymbolics c, + ExtractSymbolics d, + ExtractSymbolics e + ) => + ExtractSymbolics (a, b, c, d, e) + +-- (,,,,,) +deriving via + (Default (a, b, c, d, e, f)) + instance + ( ExtractSymbolics a, + ExtractSymbolics b, + ExtractSymbolics c, + ExtractSymbolics d, + ExtractSymbolics e, + ExtractSymbolics f + ) => + ExtractSymbolics (a, b, c, d, e, f) + +-- (,,,,,,) +deriving via + (Default (a, b, c, d, e, f, g)) + instance + ( ExtractSymbolics a, + ExtractSymbolics b, + ExtractSymbolics c, + ExtractSymbolics d, + ExtractSymbolics e, + ExtractSymbolics f, + ExtractSymbolics g + ) => + ExtractSymbolics (a, b, c, d, e, f, g) + +-- (,,,,,,,) +deriving via + (Default (a, b, c, d, e, f, g, h)) + instance + ( ExtractSymbolics a, + ExtractSymbolics b, + ExtractSymbolics c, + ExtractSymbolics d, + ExtractSymbolics e, + ExtractSymbolics f, + ExtractSymbolics g, + ExtractSymbolics h + ) => + ExtractSymbolics (a, b, c, d, e, f, g, h) + +-- MaybeT +instance (ExtractSymbolics (m (Maybe a))) => ExtractSymbolics (MaybeT m a) where + extractSymbolics (MaybeT v) = extractSymbolics v + +-- ExceptT +instance + (ExtractSymbolics (m (Either e a))) => + ExtractSymbolics (ExceptT e m a) + where + extractSymbolics (ExceptT v) = extractSymbolics v + +-- Sum +deriving via + (Default (Sum f g a)) + instance + (ExtractSymbolics (f a), ExtractSymbolics (g a)) => + ExtractSymbolics (Sum f g a) + +-- WriterT +instance + (ExtractSymbolics (m (a, s))) => + ExtractSymbolics (WriterLazy.WriterT s m a) + where + extractSymbolics (WriterLazy.WriterT f) = extractSymbolics f + +instance + (ExtractSymbolics (m (a, s))) => + ExtractSymbolics (WriterStrict.WriterT s m a) + where + extractSymbolics (WriterStrict.WriterT f) = extractSymbolics f + +-- Identity +instance (ExtractSymbolics a) => ExtractSymbolics (Identity a) where + extractSymbolics (Identity a) = extractSymbolics a + +-- IdentityT +instance (ExtractSymbolics (m a)) => ExtractSymbolics (IdentityT m a) where + extractSymbolics (IdentityT a) = extractSymbolics a + +#define EXTRACT_SYMBOLICS_SIMPLE(symtype) \ +instance ExtractSymbolics symtype where \ + extractSymbolics (symtype t) = SymbolSet $ extractSymbolicsTerm t + +#define EXTRACT_SYMBOLICS_BV(symtype) \ +instance (KnownNat n, 1 <= n) => ExtractSymbolics (symtype n) where \ + extractSymbolics (symtype t) = SymbolSet $ extractSymbolicsTerm t + +#define EXTRACT_SYMBOLICS_FUN(cop, op, cons) \ +instance (SupportedPrim (cop ca cb), LinkedRep ca sa, LinkedRep cb sb) => \ + ExtractSymbolics (op sa sb) where \ + extractSymbolics (cons t) = SymbolSet $ extractSymbolicsTerm t + +#if 1 +EXTRACT_SYMBOLICS_SIMPLE(SymBool) +EXTRACT_SYMBOLICS_SIMPLE(SymInteger) +EXTRACT_SYMBOLICS_BV(SymIntN) +EXTRACT_SYMBOLICS_BV(SymWordN) +EXTRACT_SYMBOLICS_FUN((=->), (=~>), SymTabularFun) +EXTRACT_SYMBOLICS_FUN((-->), (-~>), SymGeneralFun) +#endif + +-- Exception +deriving via (Default AssertionError) instance ExtractSymbolics AssertionError + +deriving via (Default VerificationConditions) instance ExtractSymbolics VerificationConditions + +instance (Generic a, ExtractSymbolics' (Rep a)) => ExtractSymbolics (Default a) where + extractSymbolics = extractSymbolics' . from . unDefault + +class ExtractSymbolics' a where + extractSymbolics' :: a c -> SymbolSet + +instance ExtractSymbolics' U1 where + extractSymbolics' _ = mempty + +instance ExtractSymbolics' V1 where + extractSymbolics' _ = mempty + +instance (ExtractSymbolics c) => ExtractSymbolics' (K1 i c) where + extractSymbolics' = extractSymbolics . unK1 + +instance (ExtractSymbolics' a) => ExtractSymbolics' (M1 i c a) where + extractSymbolics' = extractSymbolics' . unM1 + +instance + (ExtractSymbolics' a, ExtractSymbolics' b) => + ExtractSymbolics' (a :+: b) + where + extractSymbolics' (L1 l) = extractSymbolics' l + extractSymbolics' (R1 r) = extractSymbolics' r + +instance + (ExtractSymbolics' a, ExtractSymbolics' b) => + ExtractSymbolics' (a :*: b) + where + extractSymbolics' (l :*: r) = extractSymbolics' l <> extractSymbolics' r diff --git a/src/Grisette/Internal/Core/Data/Class/Function.hs b/src/Grisette/Internal/Core/Data/Class/Function.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Core/Data/Class/Function.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Grisette.Internal.Core.Data.Class.Function +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Core.Data.Class.Function + ( -- * Function operations + Function (..), + Apply (..), + ) +where + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim +-- >>> :set -XDataKinds +-- >>> :set -XBinaryLiterals +-- >>> :set -XFlexibleContexts +-- >>> :set -XFlexibleInstances +-- >>> :set -XFunctionalDependencies +-- >>> :set -XOverloadedStrings +-- >>> :set -XTypeOperators + +-- | Abstraction for function-like types. +class Function f arg ret | f -> arg ret where + -- | Function application operator. + -- + -- The operator is not right associated (like `($)`). It is left associated, + -- and you can provide many arguments with this operator once at a time. + -- + -- >>> (+1) # 2 + -- 3 + -- + -- >>> (+) # 2 # 3 + -- 5 + (#) :: f -> arg -> ret + + infixl 9 # + +instance Function (a -> b) a b where + f # a = f a + +-- | Applying an uninterpreted function. +-- +-- >>> let f = "f" :: SymInteger =~> SymInteger =~> SymInteger +-- >>> apply f "a" "b" +-- (apply (apply f a) b) +-- +-- Note that for implementation reasons, you can also use `apply` function on +-- a non-function symbolic value. In this case, the function is treated as an +-- `id` function. +class Apply uf where + type FunType uf + apply :: uf -> FunType uf + +instance (Apply b) => Apply (a -> b) where + type FunType (a -> b) = a -> FunType b + apply f a = apply (f a) diff --git a/src/Grisette/Internal/Core/Data/Class/GPretty.hs b/src/Grisette/Internal/Core/Data/Class/GPretty.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Core/Data/Class/GPretty.hs @@ -0,0 +1,456 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Grisette.Internal.Core.Data.Class.GPretty + ( GPretty (..), + groupedEnclose, + condEnclose, + ) +where + +import Control.Monad.Except (ExceptT (ExceptT)) +import Control.Monad.Identity + ( Identity (Identity), + IdentityT (IdentityT), + ) +import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as C +import Data.Functor.Sum (Sum) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.String (IsString (fromString)) +import qualified Data.Text as T +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.Generics + ( C, + C1, + Constructor (conFixity, conIsRecord, conName), + D, + Fixity (Infix, Prefix), + Generic (Rep, from), + K1 (K1), + M1 (M1), + S, + Selector (selName), + U1 (U1), + V1, + type (:*:) ((:*:)), + type (:+:) (L1, R1), + ) +import GHC.TypeLits (KnownNat, type (<=)) +import Generics.Deriving (Default (Default, unDefault)) +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.Prim.Term + ( LinkedRep, + SupportedPrim, + prettyPrintTerm, + ) +import Grisette.Internal.SymPrim.SymBV + ( SymIntN (SymIntN), + SymWordN (SymWordN), + ) +import Grisette.Internal.SymPrim.SymBool (SymBool (SymBool)) +import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>) (SymGeneralFun)) +import Grisette.Internal.SymPrim.SymInteger (SymInteger (SymInteger)) +import Grisette.Internal.SymPrim.SymTabularFun (type (=~>) (SymTabularFun)) + +#if MIN_VERSION_prettyprinter(1,7,0) +import Prettyprinter + ( (<+>), + align, + encloseSep, + flatAlt, + group, + nest, + vcat, + viaShow, + vsep, + Doc, + Pretty(pretty), + ) +#else +import Data.Text.Prettyprint.Doc + ( (<+>), + align, + encloseSep, + flatAlt, + group, + nest, + vcat, + viaShow, + vsep, + Doc, + Pretty(pretty), + ) +#endif + +glist :: [Doc ann] -> Doc ann +glist l + | null l = "[]" + | length l == 1 = "[" <> head l <> "]" + | otherwise = groupedEnclose "[" "]" $ encloseSep "" "" (flatAlt ", " ",") l + +class GPretty a where + gpretty :: a -> Doc ann + gprettyPrec :: Int -> a -> Doc ann + gprettyList :: [a] -> Doc ann + gprettyList = align . glist . map gpretty + + gpretty = gprettyPrec 0 + gprettyPrec _ = gpretty + + {-# MINIMAL gpretty | gprettyPrec #-} + +#define GPRETTY_SIMPLE(type) \ +instance GPretty type where gprettyPrec = viaShowsPrec showsPrec + +instance GPretty Char where + gpretty = viaShow + gprettyList v = pretty (fromString v :: T.Text) + +#if 1 +GPRETTY_SIMPLE(Bool) +GPRETTY_SIMPLE(Integer) +GPRETTY_SIMPLE(Int) +GPRETTY_SIMPLE(Int8) +GPRETTY_SIMPLE(Int16) +GPRETTY_SIMPLE(Int32) +GPRETTY_SIMPLE(Int64) +GPRETTY_SIMPLE(Word) +GPRETTY_SIMPLE(Word8) +GPRETTY_SIMPLE(Word16) +GPRETTY_SIMPLE(Word32) +GPRETTY_SIMPLE(Word64) +#endif + +instance GPretty B.ByteString where + gpretty = pretty . C.unpack + +instance GPretty T.Text where + gpretty = pretty + +instance (KnownNat n, 1 <= n) => GPretty (IntN n) where + gpretty = viaShow + +instance (KnownNat n, 1 <= n) => GPretty (WordN n) where + gpretty = viaShow + +-- () +instance GPretty () where + gpretty = viaShow + +-- Either +deriving via + (Default (Either a b)) + instance + (GPretty a, GPretty b) => GPretty (Either a b) + +-- Maybe +deriving via + (Default (Maybe a)) + instance + (GPretty a) => GPretty (Maybe a) + +-- List +instance (GPretty a) => GPretty [a] where + gpretty = gprettyList + +-- (,) +deriving via + (Default (a, b)) + instance + (GPretty a, GPretty b) => GPretty (a, b) + +-- (,,) +deriving via + (Default (a, b, c)) + instance + (GPretty a, GPretty b, GPretty c) => GPretty (a, b, c) + +-- (,,,) +deriving via + (Default (a, b, c, d)) + instance + ( GPretty a, + GPretty b, + GPretty c, + GPretty d + ) => + GPretty (a, b, c, d) + +-- (,,,,) +deriving via + (Default (a, b, c, d, e)) + instance + ( GPretty a, + GPretty b, + GPretty c, + GPretty d, + GPretty e + ) => + GPretty (a, b, c, d, e) + +-- (,,,,,) +deriving via + (Default (a, b, c, d, e, f)) + instance + ( GPretty a, + GPretty b, + GPretty c, + GPretty d, + GPretty e, + GPretty f + ) => + GPretty (a, b, c, d, e, f) + +-- (,,,,,,) +deriving via + (Default (a, b, c, d, e, f, g)) + instance + ( GPretty a, + GPretty b, + GPretty c, + GPretty d, + GPretty e, + GPretty f, + GPretty g + ) => + GPretty (a, b, c, d, e, f, g) + +-- (,,,,,,,) +deriving via + (Default (a, b, c, d, e, f, g, h)) + instance + ( GPretty a, + GPretty b, + GPretty c, + GPretty d, + GPretty e, + GPretty f, + GPretty g, + GPretty h + ) => + GPretty (a, b, c, d, e, f, g, h) + +-- Sum +deriving via + (Default (Sum f g a)) + instance + (GPretty (f a), GPretty (g a)) => + GPretty (Sum f g a) + +-- MaybeT +instance + (GPretty (m (Maybe a))) => + GPretty (MaybeT m a) + where + gprettyPrec _ (MaybeT a) = + group $ + nest 2 $ + vsep + [ "MaybeT", + gprettyPrec 11 a + ] + +-- ExceptT +instance + (GPretty (m (Either e a))) => + GPretty (ExceptT e m a) + where + gprettyPrec _ (ExceptT a) = + group $ + nest 2 $ + vsep + [ "ExceptT", + gprettyPrec 11 a + ] + +-- WriterT +instance + (GPretty (m (a, w))) => + GPretty (WriterLazy.WriterT w m a) + where + gprettyPrec _ (WriterLazy.WriterT a) = + group $ + nest 2 $ + vsep + [ "WriterT", + gprettyPrec 11 a + ] + +instance + (GPretty (m (a, w))) => + GPretty (WriterStrict.WriterT w m a) + where + gprettyPrec _ (WriterStrict.WriterT a) = + group $ + nest 2 $ + vsep + [ "WriterT", + gprettyPrec 11 a + ] + +-- Identity +instance (GPretty a) => GPretty (Identity a) where + gprettyPrec _ (Identity a) = + group $ + nest 2 $ + vsep + [ "Identity", + gprettyPrec 11 a + ] + +-- IdentityT +instance (GPretty (m a)) => GPretty (IdentityT m a) where + gprettyPrec _ (IdentityT a) = + group $ + nest 2 $ + vsep + [ "IdentityT", + gprettyPrec 11 a + ] + +-- Prettyprint +#define GPRETTY_SYM_SIMPLE(symtype) \ +instance GPretty symtype where \ + gpretty (symtype t) = prettyPrintTerm t + +#define GPRETTY_SYM_BV(symtype) \ +instance (KnownNat n, 1 <= n) => GPretty (symtype n) where \ + gpretty (symtype t) = prettyPrintTerm t + +#define GPRETTY_SYM_FUN(op, cons) \ +instance (SupportedPrim ca, SupportedPrim cb, LinkedRep ca sa, LinkedRep cb sb)\ + => GPretty (sa op sb) where \ + gpretty (cons t) = prettyPrintTerm t + +#if 1 +GPRETTY_SYM_SIMPLE(SymBool) +GPRETTY_SYM_SIMPLE(SymInteger) +GPRETTY_SYM_BV(SymIntN) +GPRETTY_SYM_BV(SymWordN) +GPRETTY_SYM_FUN(=~>, SymTabularFun) +GPRETTY_SYM_FUN(-~>, SymGeneralFun) +#endif + +instance (Generic a, GPretty' (Rep a)) => GPretty (Default a) where + gprettyPrec i v = gprettyPrec' Pref i $ from $ unDefault v + +data Type = Rec | Tup | Pref | Inf String Int + +class GPretty' a where + gprettyPrec' :: Type -> Int -> a c -> Doc ann + isNullary :: a c -> Bool + isNullary = error "generic gpretty (isNullary): unnecessary case" + +instance GPretty' V1 where + gprettyPrec' _ _ x = case x of {} + +instance GPretty' U1 where + gprettyPrec' _ _ U1 = "" + isNullary _ = True + +instance (GPretty c) => GPretty' (K1 i c) where + gprettyPrec' _ n (K1 a) = gprettyPrec n a + isNullary _ = False + +groupedEnclose :: Doc ann -> Doc ann -> Doc ann -> Doc ann +groupedEnclose l r d = group $ align $ vcat [l <> flatAlt " " "" <> d, r] + +condEnclose :: Bool -> Doc ann -> Doc ann -> Doc ann -> Doc ann +condEnclose b = if b then groupedEnclose else const $ const id + +instance (GPretty' a, Constructor c) => GPretty' (M1 C c a) where + gprettyPrec' _ n c@(M1 x) = + case t of + Tup -> + prettyBraces t (gprettyPrec' t 0 x) + Inf _ m -> + group $ condEnclose (n > m) "(" ")" $ gprettyPrec' t m x + _ -> + if isNullary x + then pretty (conName c) + else + group $ + condEnclose (n > 10) "(" ")" $ + align $ + nest 2 $ + vsep + [ pretty (conName c), + prettyBraces t (gprettyPrec' t 11 x) + ] + where + prettyBraces :: Type -> Doc ann -> Doc ann + prettyBraces Rec = groupedEnclose "{" "}" + prettyBraces Tup = groupedEnclose "(" ")" + prettyBraces Pref = id + prettyBraces (Inf _ _) = id + fixity = conFixity c + t + | conIsRecord c = Rec + | conIsTuple c = Tup + | otherwise = case fixity of + Prefix -> Pref + Infix _ i -> Inf (conName c) i + conIsTuple :: C1 c f p -> Bool + conIsTuple y = tupleName (conName y) + where + tupleName ('(' : ',' : _) = True + tupleName _ = False + +instance (Selector s, GPretty' a) => GPretty' (M1 S s a) where + gprettyPrec' t n s@(M1 x) + | selName s == "" = + case t of + Pref -> gprettyPrec' t (n + 1) x + _ -> gprettyPrec' t (n + 1) x + | otherwise = + pretty (selName s) <+> "=" <+> gprettyPrec' t 0 x + isNullary (M1 x) = isNullary x + +instance (GPretty' a) => GPretty' (M1 D d a) where + gprettyPrec' t n (M1 x) = gprettyPrec' t n x + +instance (GPretty' a, GPretty' b) => GPretty' (a :+: b) where + gprettyPrec' t n (L1 x) = gprettyPrec' t n x + gprettyPrec' t n (R1 x) = gprettyPrec' t n x + +instance (GPretty' a, GPretty' b) => GPretty' (a :*: b) where + gprettyPrec' t@Rec n (a :*: b) = + vcat + [ gprettyPrec' t n a, + "," <+> gprettyPrec' t n b + ] + gprettyPrec' t@(Inf s _) n (a :*: b) = + align $ + nest 2 $ + vsep + [ gprettyPrec' t n a, + pretty s <+> gprettyPrec' t n b + ] + gprettyPrec' t@Tup _ (a :*: b) = + vcat + [ gprettyPrec' t 0 a, + "," <> flatAlt " " "" <> gprettyPrec' t 0 b + ] + gprettyPrec' t@Pref n (a :*: b) = + vsep + [ gprettyPrec' t (n + 1) a, + gprettyPrec' t (n + 1) b + ] + isNullary _ = False + +viaShowsPrec :: (Int -> a -> ShowS) -> Int -> a -> Doc ann +viaShowsPrec f n a = pretty (f n a "") diff --git a/src/Grisette/Internal/Core/Data/Class/GenSym.hs b/src/Grisette/Internal/Core/Data/Class/GenSym.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Core/Data/Class/GenSym.hs @@ -0,0 +1,1708 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Core.Data.Class.GenSym +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Core.Data.Class.GenSym + ( -- * Indices and identifiers for fresh symbolic value generation + FreshIndex (..), + + -- * Monad for fresh symbolic value generation + MonadFresh (..), + nextFreshIndex, + liftFresh, + FreshT (FreshT, runFreshTFromIndex), + Fresh, + runFreshT, + runFresh, + mrgRunFreshT, + freshString, + + -- * Symbolic value generation + GenSym (..), + GenSymSimple (..), + genSym, + genSymSimple, + derivedNoSpecFresh, + derivedNoSpecSimpleFresh, + derivedSameShapeSimpleFresh, + + -- * Symbolic choices + chooseFresh, + chooseSimpleFresh, + chooseUnionFresh, + choose, + chooseSimple, + chooseUnion, + + -- * Some common GenSym specifications + ListSpec (..), + SimpleListSpec (..), + EnumGenBound (..), + EnumGenUpperBound (..), + ) +where + +import Control.Monad.Except + ( ExceptT (ExceptT), + MonadError (catchError, throwError), + ) +import Control.Monad.Identity (Identity (runIdentity)) +import Control.Monad.RWS.Class + ( MonadRWS, + MonadReader (ask, local), + MonadState (get, put), + MonadWriter (listen, pass, writer), + asks, + gets, + ) +import qualified Control.Monad.RWS.Lazy as RWSLazy +import qualified Control.Monad.RWS.Strict as RWSStrict +import Control.Monad.Reader (ReaderT (ReaderT)) +import Control.Monad.Signatures (Catch) +import qualified Control.Monad.State.Lazy as StateLazy +import qualified Control.Monad.State.Strict as StateStrict +import Control.Monad.Trans.Class + ( MonadTrans (lift), + ) +import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import Data.Bifunctor (Bifunctor (first)) +import qualified Data.ByteString as B +import Data.Int (Int16, Int32, Int64, Int8) +import Data.String (IsString (fromString)) +import qualified Data.Text as T +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.TypeNats (KnownNat, type (<=)) +import Generics.Deriving + ( Generic (Rep, from, to), + K1 (K1), + M1 (M1), + U1 (U1), + type (:*:) ((:*:)), + type (:+:) (L1, R1), + ) +import Grisette.Internal.Core.Control.Monad.UnionM (UnionM, isMerged, underlyingUnion) +import Grisette.Internal.Core.Data.Class.Mergeable + ( Mergeable (rootStrategy), + Mergeable1 (liftRootStrategy), + Mergeable2 (liftRootStrategy2), + MergingStrategy (SimpleStrategy), + rootStrategy1, + wrapStrategy, + ) +import Grisette.Internal.Core.Data.Class.SimpleMergeable + ( SimpleMergeable (mrgIte), + SimpleMergeable1 (liftMrgIte), + UnionMergeable1 (mrgIfPropagatedStrategy, mrgIfWithStrategy), + mrgIf, + ) +import Grisette.Internal.Core.Data.Class.Solvable (Solvable (isym)) +import Grisette.Internal.Core.Data.Class.TryMerge + ( TryMerge (tryMergeWithStrategy), + mrgSingle, + tryMerge, + ) +import Grisette.Internal.Core.Data.Symbol (Identifier) +import Grisette.Internal.Core.Data.Union (Union (UnionIf, UnionSingle)) +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.GeneralFun (type (-->)) +import Grisette.Internal.SymPrim.Prim.Term + ( LinkedRep, + SupportedPrim, + ) +import Grisette.Internal.SymPrim.SymBV + ( SymIntN, + SymWordN, + ) +import Grisette.Internal.SymPrim.SymBool (SymBool) +import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>)) +import Grisette.Internal.SymPrim.SymInteger (SymInteger) +import Grisette.Internal.SymPrim.SymTabularFun (type (=~>)) +import Grisette.Internal.SymPrim.TabularFun (type (=->)) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim +-- >>> :set -XOverloadedStrings +-- >>> :set -XTypeApplications + +-- | Index type used for 'GenSym'. +-- +-- To generate fresh variables, a monadic stateful context will be maintained. +-- The index should be increased every time a new symbolic constant is +-- generated. +newtype FreshIndex = FreshIndex Int + deriving (Show) + deriving (Eq, Ord, Num) via Int + +instance Mergeable FreshIndex where + rootStrategy = SimpleStrategy $ \_ t f -> max t f + +instance SimpleMergeable FreshIndex where + mrgIte _ = max + +-- | Monad class for fresh symbolic value generation. +-- +-- The monad should be a reader monad for the 'Identifier' and a state monad for +-- the 'FreshIndex'. +class (Monad m) => MonadFresh m where + -- | Get the current index for fresh variable generation. + getFreshIndex :: m FreshIndex + + -- | Set the current index for fresh variable generation. + setFreshIndex :: FreshIndex -> m () + + -- | Get the identifier. + getIdentifier :: m Identifier + + -- | Change the identifier locally and use a new index from 0 locally. + localIdentifier :: (Identifier -> Identifier) -> m a -> m a + +-- | Get the next fresh index and increase the current index. +nextFreshIndex :: (MonadFresh m) => m FreshIndex +nextFreshIndex = do + curr <- getFreshIndex + let new = curr + 1 + setFreshIndex new + return curr + +-- | Lifts an @`Fresh` a@ into any `MonadFresh`. +liftFresh :: (MonadFresh m) => Fresh a -> m a +liftFresh (FreshT f) = do + index <- nextFreshIndex + ident <- getIdentifier + let (a, newIdx) = runIdentity $ f ident index + setFreshIndex newIdx + return a + +-- | Generate a fresh string with the given postfix. +-- +-- >>> runFresh (freshString "b") "a" :: String +-- "a@0[b]" +freshString :: (MonadFresh m, IsString s) => String -> m s +freshString postfix = do + ident <- getIdentifier + FreshIndex index <- nextFreshIndex + return $ + fromString $ + show ident <> "@" <> show index <> "[" <> postfix <> "]" + +-- | A symbolic generation monad transformer. +-- +-- It is a reader monad transformer for an identifier and a state monad +-- transformer for indices. +-- +-- Each time a fresh symbolic variable is generated, the index should be +-- increased. +newtype FreshT m a = FreshT + { runFreshTFromIndex :: Identifier -> FreshIndex -> m (a, FreshIndex) + } + +instance + (Mergeable a, Mergeable1 m) => + Mergeable (FreshT m a) + where + rootStrategy = + wrapStrategy + (liftRootStrategy (liftRootStrategy rootStrategy1)) + FreshT + runFreshTFromIndex + +instance (Mergeable1 m) => Mergeable1 (FreshT m) where + liftRootStrategy m = + wrapStrategy + ( liftRootStrategy . liftRootStrategy . liftRootStrategy $ + liftRootStrategy2 m rootStrategy + ) + FreshT + runFreshTFromIndex + +instance + (UnionMergeable1 m, Mergeable a) => + SimpleMergeable (FreshT m a) + where + mrgIte = mrgIf + +instance + (UnionMergeable1 m) => + SimpleMergeable1 (FreshT m) + where + liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) + +instance (TryMerge m) => TryMerge (FreshT m) where + tryMergeWithStrategy s (FreshT f) = + FreshT $ \ident index -> + tryMergeWithStrategy (liftRootStrategy2 s rootStrategy) $ f ident index + +instance + (UnionMergeable1 m) => + UnionMergeable1 (FreshT m) + where + mrgIfWithStrategy s cond (FreshT t) (FreshT f) = + FreshT $ \ident index -> + mrgIfWithStrategy + (liftRootStrategy2 s rootStrategy) + cond + (t ident index) + (f ident index) + mrgIfPropagatedStrategy cond (FreshT t) (FreshT f) = + FreshT $ \ident index -> + mrgIfPropagatedStrategy cond (t ident index) (f ident index) + +-- | Run the symbolic generation with the given identifier and 0 as the initial +-- index. +runFreshT :: (Monad m) => FreshT m a -> Identifier -> m a +runFreshT m ident = fst <$> runFreshTFromIndex m ident (FreshIndex 0) + +mrgRunFreshT :: + (Monad m, TryMerge m, Mergeable a) => + FreshT m a -> + Identifier -> + m a +mrgRunFreshT m ident = tryMerge $ runFreshT m ident + +instance (Functor f) => Functor (FreshT f) where + fmap f (FreshT s) = FreshT $ \ident idx -> first f <$> s ident idx + +instance (Applicative m, Monad m) => Applicative (FreshT m) where + pure a = FreshT $ \_ idx -> pure (a, idx) + FreshT fs <*> FreshT as = FreshT $ \ident idx -> do + (f, idx') <- fs ident idx + (a, idx'') <- as ident idx' + return (f a, idx'') + +instance (Monad m) => Monad (FreshT m) where + (FreshT s) >>= f = FreshT $ \ident idx -> do + (a, idx') <- s ident idx + runFreshTFromIndex (f a) ident idx' + +instance MonadTrans FreshT where + lift x = FreshT $ \_ index -> (,index) <$> x + +liftFreshTCache :: (Functor m) => Catch e m (a, FreshIndex) -> Catch e (FreshT m) a +liftFreshTCache catchE (FreshT m) h = + FreshT $ \ident index -> m ident index `catchE` \e -> runFreshTFromIndex (h e) ident index + +instance (MonadError e m) => MonadError e (FreshT m) where + throwError = lift . throwError + catchError = liftFreshTCache catchError + +instance (MonadWriter w m) => MonadWriter w (FreshT m) where + writer p = FreshT $ \_ index -> (,index) <$> writer p + listen (FreshT r) = FreshT $ \ident index -> (\((a, b), c) -> ((a, c), b)) <$> listen (r ident index) + pass (FreshT r) = FreshT $ \ident index -> pass $ (\((a, b), c) -> ((a, c), b)) <$> r ident index + +instance (MonadState s m) => MonadState s (FreshT m) where + get = FreshT $ \_ index -> gets (,index) + put s = FreshT $ \_ index -> (,index) <$> put s + +instance (MonadReader r m) => MonadReader r (FreshT m) where + local t (FreshT r) = FreshT $ \ident index -> local t (r ident index) + ask = FreshT $ \_ index -> asks (,index) + +instance (MonadRWS r w s m) => MonadRWS r w s (FreshT m) + +instance (MonadFresh m) => MonadFresh (ExceptT e m) where + getFreshIndex = lift getFreshIndex + setFreshIndex newIdx = lift $ setFreshIndex newIdx + getIdentifier = lift getIdentifier + localIdentifier f (ExceptT m) = ExceptT $ localIdentifier f m + +instance (MonadFresh m, Monoid w) => MonadFresh (WriterLazy.WriterT w m) where + getFreshIndex = lift getFreshIndex + setFreshIndex newIdx = lift $ setFreshIndex newIdx + getIdentifier = lift getIdentifier + localIdentifier f (WriterLazy.WriterT m) = + WriterLazy.WriterT $ localIdentifier f m + +instance (MonadFresh m, Monoid w) => MonadFresh (WriterStrict.WriterT w m) where + getFreshIndex = lift getFreshIndex + setFreshIndex newIdx = lift $ setFreshIndex newIdx + getIdentifier = lift getIdentifier + localIdentifier f (WriterStrict.WriterT m) = + WriterStrict.WriterT $ localIdentifier f m + +instance (MonadFresh m) => MonadFresh (StateLazy.StateT s m) where + getFreshIndex = lift getFreshIndex + setFreshIndex newIdx = lift $ setFreshIndex newIdx + getIdentifier = lift getIdentifier + localIdentifier f (StateLazy.StateT m) = + StateLazy.StateT $ \s -> localIdentifier f (m s) + +instance (MonadFresh m) => MonadFresh (StateStrict.StateT s m) where + getFreshIndex = lift getFreshIndex + setFreshIndex newIdx = lift $ setFreshIndex newIdx + getIdentifier = lift getIdentifier + localIdentifier f (StateStrict.StateT m) = + StateStrict.StateT $ \s -> localIdentifier f (m s) + +instance (MonadFresh m) => MonadFresh (ReaderT r m) where + getFreshIndex = lift getFreshIndex + setFreshIndex newIdx = lift $ setFreshIndex newIdx + getIdentifier = lift getIdentifier + localIdentifier f (ReaderT m) = ReaderT $ localIdentifier f . m + +instance (MonadFresh m, Monoid w) => MonadFresh (RWSLazy.RWST r w s m) where + getFreshIndex = lift getFreshIndex + setFreshIndex newIdx = lift $ setFreshIndex newIdx + getIdentifier = lift getIdentifier + localIdentifier f (RWSLazy.RWST m) = + RWSLazy.RWST $ \r s -> localIdentifier f (m r s) + +instance (MonadFresh m, Monoid w) => MonadFresh (RWSStrict.RWST r w s m) where + getFreshIndex = lift getFreshIndex + setFreshIndex newIdx = lift $ setFreshIndex newIdx + getIdentifier = lift getIdentifier + localIdentifier f (RWSStrict.RWST m) = + RWSStrict.RWST $ \r s -> localIdentifier f (m r s) + +-- | 'FreshT' specialized with Identity. +type Fresh = FreshT Identity + +-- | Run the symbolic generation with the given identifier and 0 as the initial +-- index. +runFresh :: Fresh a -> Identifier -> a +runFresh m ident = runIdentity $ runFreshT m ident + +instance (Monad m) => MonadFresh (FreshT m) where + getFreshIndex = FreshT $ \_ idx -> return (idx, idx) + setFreshIndex newIdx = FreshT $ \_ _ -> return ((), newIdx) + getIdentifier = FreshT $ curry return + localIdentifier f (FreshT m) = FreshT $ \ident idx -> do + let newIdent = f ident + (r, _) <- m newIdent 0 + return (r, idx) + +-- | Class of types in which symbolic values can be generated with respect to +-- some specification. +-- +-- The result will be wrapped in a union-like monad. +-- This ensures that we can generate those types with complex merging rules. +-- +-- The uniqueness of symbolic constants is managed with the a monadic context. +-- 'Fresh' and 'FreshT' can be useful. +class (Mergeable a) => GenSym spec a where + -- | Generate a symbolic value given some specification. Within a single + -- `MonadFresh` context, calls to `fresh` would generate unique symbolic + -- constants. + -- + -- The following example generates a symbolic boolean. No specification is + -- needed. + -- + -- >>> runFresh (fresh ()) "a" :: UnionM SymBool + -- {a@0} + -- + -- The following example generates booleans, which cannot be merged into a + -- single value with type 'Bool'. No specification is needed. + -- + -- >>> runFresh (fresh ()) "a" :: UnionM Bool + -- {If a@0 False True} + -- + -- The following example generates @Maybe Bool@s. + -- There are more than one symbolic constants introduced, and their uniqueness + -- is ensured. No specification is needed. + -- + -- >>> runFresh (fresh ()) "a" :: UnionM (Maybe Bool) + -- {If a@0 Nothing (If a@1 (Just False) (Just True))} + -- + -- The following example generates lists of symbolic booleans with length 1 to 2. + -- + -- >>> runFresh (fresh (ListSpec 1 2 ())) "a" :: UnionM [SymBool] + -- {If a@2 [a@1] [a@0,a@1]} + -- + -- When multiple symbolic values are generated, there will not be any + -- identifier collision + -- + -- >>> runFresh (do; a <- fresh (); b <- fresh (); return (a, b)) "a" :: (UnionM SymBool, UnionM SymBool) + -- ({a@0},{a@1}) + fresh :: + (MonadFresh m) => + spec -> + m (UnionM a) + default fresh :: + (GenSymSimple spec a) => + ( MonadFresh m + ) => + spec -> + m (UnionM a) + fresh spec = mrgSingle <$> simpleFresh spec + +-- | Generate a symbolic variable wrapped in a Union without the monadic context. +-- A globally unique identifier should be supplied to ensure the uniqueness of +-- symbolic constants in the generated symbolic values. +-- +-- >>> genSym (ListSpec 1 2 ()) "a" :: UnionM [SymBool] +-- {If a@2 [a@1] [a@0,a@1]} +genSym :: (GenSym spec a) => spec -> Identifier -> UnionM a +genSym = runFresh . fresh + +-- | Class of types in which symbolic values can be generated with respect to some specification. +-- +-- The result will __/not/__ be wrapped in a union-like monad. +-- +-- The uniqueness of symbolic constants is managed with the a monadic context. +-- 'Fresh' and 'FreshT' can be useful. +class GenSymSimple spec a where + -- | Generate a symbolic value given some specification. The uniqueness is ensured. + -- + -- The following example generates a symbolic boolean. No specification is needed. + -- + -- >>> runFresh (simpleFresh ()) "a" :: SymBool + -- a@0 + -- + -- The following code generates list of symbolic boolean with length 2. + -- As the length is fixed, we don't have to wrap the result in unions. + -- + -- >>> runFresh (simpleFresh (SimpleListSpec 2 ())) "a" :: [SymBool] + -- [a@0,a@1] + simpleFresh :: + ( MonadFresh m + ) => + spec -> + m a + +-- | Generate a simple symbolic variable wrapped in a Union without the monadic context. +-- A globally unique identifier should be supplied to ensure the uniqueness of +-- symbolic constants in the generated symbolic values. +-- +-- >>> genSymSimple (SimpleListSpec 2 ()) "a" :: [SymBool] +-- [a@0,a@1] +genSymSimple :: forall spec a. (GenSymSimple spec a) => spec -> Identifier -> a +genSymSimple = runFresh . simpleFresh + +class GenSymNoSpec a where + freshNoSpec :: + ( MonadFresh m + ) => + m (UnionM (a c)) + +instance GenSymNoSpec U1 where + freshNoSpec = return $ mrgSingle U1 + +instance (GenSym () c) => GenSymNoSpec (K1 i c) where + freshNoSpec = fmap K1 <$> fresh () + +instance (GenSymNoSpec a) => GenSymNoSpec (M1 i c a) where + freshNoSpec = fmap M1 <$> freshNoSpec + +instance + ( GenSymNoSpec a, + GenSymNoSpec b, + forall x. Mergeable (a x), + forall x. Mergeable (b x) + ) => + GenSymNoSpec (a :+: b) + where + freshNoSpec :: + forall m c. + ( MonadFresh m + ) => + m (UnionM ((a :+: b) c)) + freshNoSpec = do + cond :: bool <- simpleFresh () + l :: UnionM (a c) <- freshNoSpec + r :: UnionM (b c) <- freshNoSpec + return $ mrgIf cond (fmap L1 l) (fmap R1 r) + +instance + (GenSymNoSpec a, GenSymNoSpec b) => + GenSymNoSpec (a :*: b) + where + freshNoSpec :: + forall m c. + ( MonadFresh m + ) => + m (UnionM ((a :*: b) c)) + freshNoSpec = do + l :: UnionM (a c) <- freshNoSpec + r :: UnionM (b c) <- freshNoSpec + return $ do + l1 <- l + r1 <- r + return $ l1 :*: r1 + +-- | We cannot provide DerivingVia style derivation for 'GenSym', while you can +-- use this 'fresh' implementation to implement 'GenSym' for your own types. +-- +-- This 'fresh' implementation is for the types that does not need any specification. +-- It will generate product types by generating each fields with @()@ as specification, +-- and generate all possible values for a sum type. +-- +-- __Note:__ __Never__ use on recursive types. +derivedNoSpecFresh :: + forall a m. + ( Generic a, + GenSymNoSpec (Rep a), + Mergeable a, + MonadFresh m + ) => + () -> + m (UnionM a) +derivedNoSpecFresh _ = tryMerge . fmap to <$> freshNoSpec + +class GenSymSimpleNoSpec a where + simpleFreshNoSpec :: (MonadFresh m) => m (a c) + +instance GenSymSimpleNoSpec U1 where + simpleFreshNoSpec = return U1 + +instance (GenSymSimple () c) => GenSymSimpleNoSpec (K1 i c) where + simpleFreshNoSpec = K1 <$> simpleFresh () + +instance (GenSymSimpleNoSpec a) => GenSymSimpleNoSpec (M1 i c a) where + simpleFreshNoSpec = M1 <$> simpleFreshNoSpec + +instance + (GenSymSimpleNoSpec a, GenSymSimpleNoSpec b) => + GenSymSimpleNoSpec (a :*: b) + where + simpleFreshNoSpec = do + l :: a c <- simpleFreshNoSpec + r :: b c <- simpleFreshNoSpec + return $ l :*: r + +-- | We cannot provide DerivingVia style derivation for 'GenSymSimple', while +-- you can use this 'simpleFresh' implementation to implement 'GenSymSimple' fo +-- your own types. +-- +-- This 'simpleFresh' implementation is for the types that does not need any specification. +-- It will generate product types by generating each fields with '()' as specification. +-- It will not work on sum types. +-- +-- __Note:__ __Never__ use on recursive types. +derivedNoSpecSimpleFresh :: + forall a m. + ( Generic a, + GenSymSimpleNoSpec (Rep a), + MonadFresh m + ) => + () -> + m a +derivedNoSpecSimpleFresh _ = to <$> simpleFreshNoSpec + +class GenSymSameShape a where + genSymSameShapeFresh :: + ( MonadFresh m + ) => + a c -> + m (a c) + +instance GenSymSameShape U1 where + genSymSameShapeFresh _ = return U1 + +instance (GenSymSimple c c) => GenSymSameShape (K1 i c) where + genSymSameShapeFresh (K1 c) = K1 <$> simpleFresh c + +instance (GenSymSameShape a) => GenSymSameShape (M1 i c a) where + genSymSameShapeFresh (M1 a) = M1 <$> genSymSameShapeFresh a + +instance + (GenSymSameShape a, GenSymSameShape b) => + GenSymSameShape (a :+: b) + where + genSymSameShapeFresh (L1 a) = L1 <$> genSymSameShapeFresh a + genSymSameShapeFresh (R1 a) = R1 <$> genSymSameShapeFresh a + +instance + (GenSymSameShape a, GenSymSameShape b) => + GenSymSameShape (a :*: b) + where + genSymSameShapeFresh (a :*: b) = do + l :: a c <- genSymSameShapeFresh a + r :: b c <- genSymSameShapeFresh b + return $ l :*: r + +-- | We cannot provide DerivingVia style derivation for 'GenSymSimple', while +-- you can use this 'simpleFresh' implementation to implement 'GenSymSimple' fo +-- your own types. +-- +-- This 'simpleFresh' implementation is for the types that can be generated with +-- a reference value of the same type. +-- +-- For sum types, it will generate the result with the same data constructor. +-- For product types, it will generate the result by generating each field with +-- the corresponding reference value. +-- +-- __Note:__ __Can__ be used on recursive types. +derivedSameShapeSimpleFresh :: + forall a m. + ( Generic a, + GenSymSameShape (Rep a), + MonadFresh m + ) => + a -> + m a +derivedSameShapeSimpleFresh a = to <$> genSymSameShapeFresh (from a) + +-- | Symbolically chooses one of the provided values. +-- The procedure creates @n - 1@ fresh symbolic boolean variables every time it +-- is evaluated, and use these variables to conditionally select one of the @n@ +-- provided expressions. +-- +-- The result will be wrapped in a union-like monad, and also a monad +-- maintaining the 'MonadFresh' context. +-- +-- >>> runFresh (chooseFresh [1,2,3]) "a" :: UnionM Integer +-- {If a@0 1 (If a@1 2 3)} +chooseFresh :: + forall a m. + ( Mergeable a, + MonadFresh m + ) => + [a] -> + m (UnionM a) +chooseFresh [x] = return $ mrgSingle x +chooseFresh (r : rs) = do + b <- simpleFresh () + res <- chooseFresh rs + return $ mrgIf b (mrgSingle r) res +chooseFresh [] = error "chooseFresh expects at least one value" + +-- | A wrapper for `chooseFresh` that executes the `MonadFresh` context. +-- A globally unique identifier should be supplied to ensure the uniqueness of +-- symbolic constants in the generated symbolic values. +choose :: + forall a. + ( Mergeable a + ) => + [a] -> + Identifier -> + UnionM a +choose = runFresh . chooseFresh + +-- | Symbolically chooses one of the provided values. +-- The procedure creates @n - 1@ fresh symbolic boolean variables every time it is evaluated, and use +-- these variables to conditionally select one of the @n@ provided expressions. +-- +-- The result will __/not/__ be wrapped in a union-like monad, but will be +-- wrapped in a monad maintaining the 'Fresh' context. +-- +-- >>> import Data.Proxy +-- >>> runFresh (chooseSimpleFresh [ssym "b", ssym "c", ssym "d"]) "a" :: SymInteger +-- (ite a@0 b (ite a@1 c d)) +chooseSimpleFresh :: + forall a m. + ( SimpleMergeable a, + MonadFresh m + ) => + [a] -> + m a +chooseSimpleFresh [x] = return x +chooseSimpleFresh (r : rs) = do + b :: bool <- simpleFresh () + res <- chooseSimpleFresh rs + return $ mrgIte b r res +chooseSimpleFresh [] = error "chooseSimpleFresh expects at least one value" + +-- | A wrapper for `chooseSimpleFresh` that executes the `MonadFresh` context. +-- A globally unique identifier should be supplied to ensure the uniqueness of +-- symbolic constants in the generated symbolic values. +chooseSimple :: + forall a. + ( SimpleMergeable a + ) => + [a] -> + Identifier -> + a +chooseSimple = runFresh . chooseSimpleFresh + +-- | Symbolically chooses one of the provided values wrapped in union-like +-- monads. The procedure creates @n - 1@ fresh symbolic boolean variables every +-- time it is evaluated, and use these variables to conditionally select one of +-- the @n@ provided expressions. +-- +-- The result will be wrapped in a union-like monad, and also a monad +-- maintaining the 'Fresh' context. +-- +-- >>> let a = runFresh (chooseFresh [1, 2]) "a" :: UnionM Integer +-- >>> let b = runFresh (chooseFresh [2, 3]) "b" :: UnionM Integer +-- >>> runFresh (chooseUnionFresh [a, b]) "c" :: UnionM Integer +-- {If (&& c@0 a@0) 1 (If (|| c@0 b@0) 2 3)} +chooseUnionFresh :: + forall a m. + ( Mergeable a, + MonadFresh m + ) => + [UnionM a] -> + m (UnionM a) +chooseUnionFresh [x] = return x +chooseUnionFresh (r : rs) = do + b <- simpleFresh () + res <- chooseUnionFresh rs + return $ mrgIf b r res +chooseUnionFresh [] = error "chooseUnionFresh expects at least one value" + +-- | A wrapper for `chooseUnionFresh` that executes the `MonadFresh` context. +-- A globally unique identifier should be supplied to ensure the uniqueness of +-- symbolic constants in the generated symbolic values. +chooseUnion :: + forall a. + ( Mergeable a + ) => + [UnionM a] -> + Identifier -> + UnionM a +chooseUnion = runFresh . chooseUnionFresh + +#define CONCRETE_GENSYM_SAME_SHAPE(type) \ +instance GenSym type type where fresh = return . mrgSingle + +#define CONCRETE_GENSYMSIMPLE_SAME_SHAPE(type) \ +instance GenSymSimple type type where simpleFresh = return + +#define CONCRETE_GENSYM_SAME_SHAPE_BV(type) \ +instance (KnownNat n, 1 <= n) => GenSym (type n) (type n) where fresh = return . mrgSingle + +#define CONCRETE_GENSYMSIMPLE_SAME_SHAPE_BV(type) \ +instance (KnownNat n, 1 <= n) => GenSymSimple (type n) (type n) where simpleFresh = return + +#if 1 +CONCRETE_GENSYM_SAME_SHAPE(Bool) +CONCRETE_GENSYM_SAME_SHAPE(Integer) +CONCRETE_GENSYM_SAME_SHAPE(Char) +CONCRETE_GENSYM_SAME_SHAPE(Int) +CONCRETE_GENSYM_SAME_SHAPE(Int8) +CONCRETE_GENSYM_SAME_SHAPE(Int16) +CONCRETE_GENSYM_SAME_SHAPE(Int32) +CONCRETE_GENSYM_SAME_SHAPE(Int64) +CONCRETE_GENSYM_SAME_SHAPE(Word) +CONCRETE_GENSYM_SAME_SHAPE(Word8) +CONCRETE_GENSYM_SAME_SHAPE(Word16) +CONCRETE_GENSYM_SAME_SHAPE(Word32) +CONCRETE_GENSYM_SAME_SHAPE(Word64) +CONCRETE_GENSYM_SAME_SHAPE(B.ByteString) +CONCRETE_GENSYM_SAME_SHAPE(T.Text) +CONCRETE_GENSYM_SAME_SHAPE_BV(WordN) +CONCRETE_GENSYM_SAME_SHAPE_BV(IntN) + +CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Bool) +CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Integer) +CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Char) +CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Int) +CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Int8) +CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Int16) +CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Int32) +CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Int64) +CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Word) +CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Word8) +CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Word16) +CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Word32) +CONCRETE_GENSYMSIMPLE_SAME_SHAPE(Word64) +CONCRETE_GENSYMSIMPLE_SAME_SHAPE(B.ByteString) +CONCRETE_GENSYMSIMPLE_SAME_SHAPE(T.Text) +CONCRETE_GENSYMSIMPLE_SAME_SHAPE_BV(WordN) +CONCRETE_GENSYMSIMPLE_SAME_SHAPE_BV(IntN) +#endif + +-- Bool +instance GenSym () Bool where + fresh = derivedNoSpecFresh + +-- Enums + +-- | Specification for enum values with upper bound (exclusive). The result would chosen from [0 .. upperbound]. +-- +-- >>> runFresh (fresh (EnumGenUpperBound @Integer 4)) "c" :: UnionM Integer +-- {If c@0 0 (If c@1 1 (If c@2 2 3))} +newtype EnumGenUpperBound a = EnumGenUpperBound a + +instance (Enum v, Mergeable v) => GenSym (EnumGenUpperBound v) v where + fresh (EnumGenUpperBound u) = chooseFresh (toEnum <$> [0 .. fromEnum u - 1]) + +-- | Specification for numbers with lower bound (inclusive) and upper bound (exclusive) +-- +-- >>> runFresh (fresh (EnumGenBound @Integer 0 4)) "c" :: UnionM Integer +-- {If c@0 0 (If c@1 1 (If c@2 2 3))} +data EnumGenBound a = EnumGenBound a a + +instance (Enum v, Mergeable v) => GenSym (EnumGenBound v) v where + fresh (EnumGenBound l u) = chooseFresh (toEnum <$> [fromEnum l .. fromEnum u - 1]) + +-- Either +instance + ( GenSym aspec a, + Mergeable a, + GenSym bspec b, + Mergeable b + ) => + GenSym (Either aspec bspec) (Either a b) + where + fresh (Left aspec) = (tryMerge . fmap Left) <$> fresh aspec + fresh (Right bspec) = (tryMerge . fmap Right) <$> fresh bspec + +instance + ( GenSymSimple aspec a, + GenSymSimple bspec b + ) => + GenSymSimple (Either aspec bspec) (Either a b) + where + simpleFresh (Left a) = Left <$> simpleFresh a + simpleFresh (Right b) = Right <$> simpleFresh b + +instance + (GenSym () a, Mergeable a, GenSym () b, Mergeable b) => + GenSym () (Either a b) + where + fresh = derivedNoSpecFresh + +instance + ( GenSym aspec a, + Mergeable a, + GenSym bspec b, + Mergeable b + ) => + GenSym (aspec, bspec) (Either a b) + where + fresh (aspec, bspec) = do + l :: UnionM a <- fresh aspec + r :: UnionM b <- fresh bspec + chooseUnionFresh [Left <$> l, Right <$> r] + +-- Maybe +instance + {-# OVERLAPPING #-} + (GenSym aspec a, Mergeable a) => + GenSym (Maybe aspec) (Maybe a) + where + fresh Nothing = return $ mrgSingle Nothing + fresh (Just aspec) = (tryMerge . fmap Just) <$> fresh aspec + +instance + (GenSymSimple aspec a) => + GenSymSimple (Maybe aspec) (Maybe a) + where + simpleFresh Nothing = return Nothing + simpleFresh (Just aspec) = Just <$> simpleFresh aspec + +instance + {-# OVERLAPPABLE #-} + (GenSym aspec a, Mergeable a) => + GenSym aspec (Maybe a) + where + fresh aspec = do + cond <- simpleFresh () + a :: UnionM a <- fresh aspec + return $ mrgIf cond (mrgSingle Nothing) (Just <$> a) + +-- List +instance + (GenSym () a, Mergeable a) => + GenSym Integer [a] + where + fresh v = do + l <- gl v + let xs = reverse $ scanr (:) [] l + chooseUnionFresh $ tryMerge . sequence <$> xs + where + gl :: (MonadFresh m) => Integer -> m [UnionM a] + gl v1 + | v1 <= 0 = return [] + | otherwise = do + l <- fresh () + r <- gl (v1 - 1) + return $ l : r + +-- | Specification for list generation. +-- +-- >>> runFresh (fresh (ListSpec 0 2 ())) "c" :: UnionM [SymBool] +-- {If c@2 [] (If c@3 [c@1] [c@0,c@1])} +-- +-- >>> runFresh (fresh (ListSpec 0 2 (SimpleListSpec 1 ()))) "c" :: UnionM [[SymBool]] +-- {If c@2 [] (If c@3 [[c@1]] [[c@0],[c@1]])} +data ListSpec spec = ListSpec + { -- | The minimum length of the generated lists + genListMinLength :: Int, + -- | The maximum length of the generated lists + genListMaxLength :: Int, + -- | Each element in the lists will be generated with the sub-specification + genListSubSpec :: spec + } + deriving (Show) + +instance + (GenSym spec a, Mergeable a) => + GenSym (ListSpec spec) [a] + where + fresh (ListSpec minLen maxLen subSpec) = + if minLen < 0 || maxLen < 0 || minLen >= maxLen + then error $ "Bad lengths: " ++ show (minLen, maxLen) + else do + l <- gl maxLen + let xs = drop minLen $ reverse $ scanr (:) [] l + chooseUnionFresh $ tryMerge . sequence <$> xs + where + gl :: (MonadFresh m) => Int -> m [UnionM a] + gl currLen + | currLen <= 0 = return [] + | otherwise = do + l <- fresh subSpec + r <- gl (currLen - 1) + return $ l : r + +instance + (GenSym a a, Mergeable a) => + GenSym [a] [a] + where + fresh l = do + r :: [UnionM a] <- traverse fresh l + return $ tryMerge $ sequence r + +instance + (GenSymSimple a a) => + GenSymSimple [a] [a] + where + simpleFresh = derivedSameShapeSimpleFresh + +-- | Specification for list generation of a specific length. +-- +-- >>> runFresh (simpleFresh (SimpleListSpec 2 ())) "c" :: [SymBool] +-- [c@0,c@1] +data SimpleListSpec spec = SimpleListSpec + { -- | The length of the generated list + genSimpleListLength :: Int, + -- | Each element in the list will be generated with the sub-specification + genSimpleListSubSpec :: spec + } + deriving (Show) + +instance + (GenSym spec a, Mergeable a) => + GenSym (SimpleListSpec spec) [a] + where + fresh (SimpleListSpec len subSpec) = + if len < 0 + then error $ "Bad lengths: " ++ show len + else do + tryMerge . sequence <$> gl len + where + gl :: (MonadFresh m) => Int -> m [UnionM a] + gl currLen + | currLen <= 0 = return [] + | otherwise = do + l <- fresh subSpec + r <- gl (currLen - 1) + return $ l : r + +instance + (GenSymSimple spec a) => + GenSymSimple (SimpleListSpec spec) [a] + where + simpleFresh (SimpleListSpec len subSpec) = + if len < 0 + then error $ "Bad lengths: " ++ show len + else do + gl len + where + gl :: (MonadFresh m) => Int -> m [a] + gl currLen + | currLen <= 0 = return [] + | otherwise = do + l <- simpleFresh subSpec + r <- gl (currLen - 1) + return $ l : r + +-- () +instance GenSym () () + +instance GenSymSimple () () where + simpleFresh = derivedNoSpecSimpleFresh + +-- (,) +instance + ( GenSym aspec a, + Mergeable a, + GenSym bspec b, + Mergeable b + ) => + GenSym (aspec, bspec) (a, b) + where + fresh (aspec, bspec) = do + a1 <- fresh aspec + b1 <- fresh bspec + return $ do + ax <- a1 + bx <- b1 + mrgSingle (ax, bx) + +instance + ( GenSymSimple aspec a, + GenSymSimple bspec b + ) => + GenSymSimple (aspec, bspec) (a, b) + where + simpleFresh (aspec, bspec) = do + (,) + <$> simpleFresh aspec + <*> simpleFresh bspec + +instance + (GenSym () a, Mergeable a, GenSym () b, Mergeable b) => + GenSym () (a, b) + where + fresh = derivedNoSpecFresh + +instance + ( GenSymSimple () a, + GenSymSimple () b + ) => + GenSymSimple () (a, b) + where + simpleFresh = derivedNoSpecSimpleFresh + +-- (,,) +instance + ( GenSym aspec a, + Mergeable a, + GenSym bspec b, + Mergeable b, + GenSym cspec c, + Mergeable c + ) => + GenSym (aspec, bspec, cspec) (a, b, c) + where + fresh (aspec, bspec, cspec) = do + a1 <- fresh aspec + b1 <- fresh bspec + c1 <- fresh cspec + return $ do + ax <- a1 + bx <- b1 + cx <- c1 + mrgSingle (ax, bx, cx) + +instance + ( GenSymSimple aspec a, + GenSymSimple bspec b, + GenSymSimple cspec c + ) => + GenSymSimple (aspec, bspec, cspec) (a, b, c) + where + simpleFresh (aspec, bspec, cspec) = do + (,,) + <$> simpleFresh aspec + <*> simpleFresh bspec + <*> simpleFresh cspec + +instance + ( GenSym () a, + Mergeable a, + GenSym () b, + Mergeable b, + GenSym () c, + Mergeable c + ) => + GenSym () (a, b, c) + where + fresh = derivedNoSpecFresh + +instance + ( GenSymSimple () a, + GenSymSimple () b, + GenSymSimple () c + ) => + GenSymSimple () (a, b, c) + where + simpleFresh = derivedNoSpecSimpleFresh + +-- (,,,) +instance + ( GenSym aspec a, + Mergeable a, + GenSym bspec b, + Mergeable b, + GenSym cspec c, + Mergeable c, + GenSym dspec d, + Mergeable d + ) => + GenSym (aspec, bspec, cspec, dspec) (a, b, c, d) + where + fresh (aspec, bspec, cspec, dspec) = do + a1 <- fresh aspec + b1 <- fresh bspec + c1 <- fresh cspec + d1 <- fresh dspec + return $ do + ax <- a1 + bx <- b1 + cx <- c1 + dx <- d1 + mrgSingle (ax, bx, cx, dx) + +instance + ( GenSymSimple aspec a, + GenSymSimple bspec b, + GenSymSimple cspec c, + GenSymSimple dspec d + ) => + GenSymSimple (aspec, bspec, cspec, dspec) (a, b, c, d) + where + simpleFresh (aspec, bspec, cspec, dspec) = do + (,,,) + <$> simpleFresh aspec + <*> simpleFresh bspec + <*> simpleFresh cspec + <*> simpleFresh dspec + +instance + ( GenSym () a, + Mergeable a, + GenSym () b, + Mergeable b, + GenSym () c, + Mergeable c, + GenSym () d, + Mergeable d + ) => + GenSym () (a, b, c, d) + where + fresh = derivedNoSpecFresh + +instance + ( GenSymSimple () a, + GenSymSimple () b, + GenSymSimple () c, + GenSymSimple () d + ) => + GenSymSimple () (a, b, c, d) + where + simpleFresh = derivedNoSpecSimpleFresh + +-- (,,,,) +instance + ( GenSym aspec a, + Mergeable a, + GenSym bspec b, + Mergeable b, + GenSym cspec c, + Mergeable c, + GenSym dspec d, + Mergeable d, + GenSym espec e, + Mergeable e + ) => + GenSym (aspec, bspec, cspec, dspec, espec) (a, b, c, d, e) + where + fresh (aspec, bspec, cspec, dspec, espec) = do + a1 <- fresh aspec + b1 <- fresh bspec + c1 <- fresh cspec + d1 <- fresh dspec + e1 <- fresh espec + return $ do + ax <- a1 + bx <- b1 + cx <- c1 + dx <- d1 + ex <- e1 + mrgSingle (ax, bx, cx, dx, ex) + +instance + ( GenSymSimple aspec a, + GenSymSimple bspec b, + GenSymSimple cspec c, + GenSymSimple dspec d, + GenSymSimple espec e + ) => + GenSymSimple (aspec, bspec, cspec, dspec, espec) (a, b, c, d, e) + where + simpleFresh (aspec, bspec, cspec, dspec, espec) = do + (,,,,) + <$> simpleFresh aspec + <*> simpleFresh bspec + <*> simpleFresh cspec + <*> simpleFresh dspec + <*> simpleFresh espec + +instance + ( GenSym () a, + Mergeable a, + GenSym () b, + Mergeable b, + GenSym () c, + Mergeable c, + GenSym () d, + Mergeable d, + GenSym () e, + Mergeable e + ) => + GenSym () (a, b, c, d, e) + where + fresh = derivedNoSpecFresh + +instance + ( GenSymSimple () a, + GenSymSimple () b, + GenSymSimple () c, + GenSymSimple () d, + GenSymSimple () e + ) => + GenSymSimple () (a, b, c, d, e) + where + simpleFresh = derivedNoSpecSimpleFresh + +-- (,,,,,) +instance + ( GenSym aspec a, + Mergeable a, + GenSym bspec b, + Mergeable b, + GenSym cspec c, + Mergeable c, + GenSym dspec d, + Mergeable d, + GenSym espec e, + Mergeable e, + GenSym fspec f, + Mergeable f + ) => + GenSym (aspec, bspec, cspec, dspec, espec, fspec) (a, b, c, d, e, f) + where + fresh (aspec, bspec, cspec, dspec, espec, fspec) = do + a1 <- fresh aspec + b1 <- fresh bspec + c1 <- fresh cspec + d1 <- fresh dspec + e1 <- fresh espec + f1 <- fresh fspec + return $ do + ax <- a1 + bx <- b1 + cx <- c1 + dx <- d1 + ex <- e1 + fx <- f1 + mrgSingle (ax, bx, cx, dx, ex, fx) + +instance + ( GenSymSimple aspec a, + GenSymSimple bspec b, + GenSymSimple cspec c, + GenSymSimple dspec d, + GenSymSimple espec e, + GenSymSimple fspec f + ) => + GenSymSimple (aspec, bspec, cspec, dspec, espec, fspec) (a, b, c, d, e, f) + where + simpleFresh (aspec, bspec, cspec, dspec, espec, fspec) = do + (,,,,,) + <$> simpleFresh aspec + <*> simpleFresh bspec + <*> simpleFresh cspec + <*> simpleFresh dspec + <*> simpleFresh espec + <*> simpleFresh fspec + +instance + ( GenSym () a, + Mergeable a, + GenSym () b, + Mergeable b, + GenSym () c, + Mergeable c, + GenSym () d, + Mergeable d, + GenSym () e, + Mergeable e, + GenSym () f, + Mergeable f + ) => + GenSym () (a, b, c, d, e, f) + where + fresh = derivedNoSpecFresh + +instance + ( GenSymSimple () a, + GenSymSimple () b, + GenSymSimple () c, + GenSymSimple () d, + GenSymSimple () e, + GenSymSimple () f + ) => + GenSymSimple () (a, b, c, d, e, f) + where + simpleFresh = derivedNoSpecSimpleFresh + +-- (,,,,,,) +instance + ( GenSym aspec a, + Mergeable a, + GenSym bspec b, + Mergeable b, + GenSym cspec c, + Mergeable c, + GenSym dspec d, + Mergeable d, + GenSym espec e, + Mergeable e, + GenSym fspec f, + Mergeable f, + GenSym gspec g, + Mergeable g + ) => + GenSym (aspec, bspec, cspec, dspec, espec, fspec, gspec) (a, b, c, d, e, f, g) + where + fresh (aspec, bspec, cspec, dspec, espec, fspec, gspec) = do + a1 <- fresh aspec + b1 <- fresh bspec + c1 <- fresh cspec + d1 <- fresh dspec + e1 <- fresh espec + f1 <- fresh fspec + g1 <- fresh gspec + return $ do + ax <- a1 + bx <- b1 + cx <- c1 + dx <- d1 + ex <- e1 + fx <- f1 + gx <- g1 + mrgSingle (ax, bx, cx, dx, ex, fx, gx) + +instance + ( GenSymSimple aspec a, + GenSymSimple bspec b, + GenSymSimple cspec c, + GenSymSimple dspec d, + GenSymSimple espec e, + GenSymSimple fspec f, + GenSymSimple gspec g + ) => + GenSymSimple (aspec, bspec, cspec, dspec, espec, fspec, gspec) (a, b, c, d, e, f, g) + where + simpleFresh (aspec, bspec, cspec, dspec, espec, fspec, gspec) = do + (,,,,,,) + <$> simpleFresh aspec + <*> simpleFresh bspec + <*> simpleFresh cspec + <*> simpleFresh dspec + <*> simpleFresh espec + <*> simpleFresh fspec + <*> simpleFresh gspec + +instance + ( GenSym () a, + Mergeable a, + GenSym () b, + Mergeable b, + GenSym () c, + Mergeable c, + GenSym () d, + Mergeable d, + GenSym () e, + Mergeable e, + GenSym () f, + Mergeable f, + GenSym () g, + Mergeable g + ) => + GenSym () (a, b, c, d, e, f, g) + where + fresh = derivedNoSpecFresh + +instance + ( GenSymSimple () a, + GenSymSimple () b, + GenSymSimple () c, + GenSymSimple () d, + GenSymSimple () e, + GenSymSimple () f, + GenSymSimple () g + ) => + GenSymSimple () (a, b, c, d, e, f, g) + where + simpleFresh = derivedNoSpecSimpleFresh + +-- (,,,,,,,) +instance + ( GenSym aspec a, + Mergeable a, + GenSym bspec b, + Mergeable b, + GenSym cspec c, + Mergeable c, + GenSym dspec d, + Mergeable d, + GenSym espec e, + Mergeable e, + GenSym fspec f, + Mergeable f, + GenSym gspec g, + Mergeable g, + GenSym hspec h, + Mergeable h + ) => + GenSym (aspec, bspec, cspec, dspec, espec, fspec, gspec, hspec) (a, b, c, d, e, f, g, h) + where + fresh (aspec, bspec, cspec, dspec, espec, fspec, gspec, hspec) = do + a1 <- fresh aspec + b1 <- fresh bspec + c1 <- fresh cspec + d1 <- fresh dspec + e1 <- fresh espec + f1 <- fresh fspec + g1 <- fresh gspec + h1 <- fresh hspec + return $ do + ax <- a1 + bx <- b1 + cx <- c1 + dx <- d1 + ex <- e1 + fx <- f1 + gx <- g1 + hx <- h1 + mrgSingle (ax, bx, cx, dx, ex, fx, gx, hx) + +instance + ( GenSymSimple aspec a, + GenSymSimple bspec b, + GenSymSimple cspec c, + GenSymSimple dspec d, + GenSymSimple espec e, + GenSymSimple fspec f, + GenSymSimple gspec g, + GenSymSimple hspec h + ) => + GenSymSimple (aspec, bspec, cspec, dspec, espec, fspec, gspec, hspec) (a, b, c, d, e, f, g, h) + where + simpleFresh (aspec, bspec, cspec, dspec, espec, fspec, gspec, hspec) = do + (,,,,,,,) + <$> simpleFresh aspec + <*> simpleFresh bspec + <*> simpleFresh cspec + <*> simpleFresh dspec + <*> simpleFresh espec + <*> simpleFresh fspec + <*> simpleFresh gspec + <*> simpleFresh hspec + +instance + ( GenSym () a, + Mergeable a, + GenSym () b, + Mergeable b, + GenSym () c, + Mergeable c, + GenSym () d, + Mergeable d, + GenSym () e, + Mergeable e, + GenSym () f, + Mergeable f, + GenSym () g, + Mergeable g, + GenSym () h, + Mergeable h + ) => + GenSym () (a, b, c, d, e, f, g, h) + where + fresh = derivedNoSpecFresh + +instance + ( GenSymSimple () a, + GenSymSimple () b, + GenSymSimple () c, + GenSymSimple () d, + GenSymSimple () e, + GenSymSimple () f, + GenSymSimple () g, + GenSymSimple () h + ) => + GenSymSimple () (a, b, c, d, e, f, g, h) + where + simpleFresh = derivedNoSpecSimpleFresh + +-- MaybeT +instance + {-# OVERLAPPABLE #-} + ( GenSym spec (m (Maybe a)), + Mergeable1 m, + Mergeable a + ) => + GenSym spec (MaybeT m a) + where + fresh v = do + x <- fresh v + return $ tryMerge . fmap MaybeT $ x + +instance + {-# OVERLAPPABLE #-} + ( GenSymSimple spec (m (Maybe a)) + ) => + GenSymSimple spec (MaybeT m a) + where + simpleFresh v = MaybeT <$> simpleFresh v + +instance + {-# OVERLAPPING #-} + ( GenSymSimple (m (Maybe a)) (m (Maybe a)) + ) => + GenSymSimple (MaybeT m a) (MaybeT m a) + where + simpleFresh (MaybeT v) = MaybeT <$> simpleFresh v + +instance + {-# OVERLAPPING #-} + ( GenSymSimple (m (Maybe a)) (m (Maybe a)), + Mergeable1 m, + Mergeable a + ) => + GenSym (MaybeT m a) (MaybeT m a) + +-- ExceptT +instance + {-# OVERLAPPABLE #-} + ( GenSym spec (m (Either a b)), + Mergeable1 m, + Mergeable a, + Mergeable b + ) => + GenSym spec (ExceptT a m b) + where + fresh v = do + x <- fresh v + return $ tryMerge . fmap ExceptT $ x + +instance + {-# OVERLAPPABLE #-} + ( GenSymSimple spec (m (Either a b)) + ) => + GenSymSimple spec (ExceptT a m b) + where + simpleFresh v = ExceptT <$> simpleFresh v + +instance + {-# OVERLAPPING #-} + ( GenSymSimple (m (Either e a)) (m (Either e a)) + ) => + GenSymSimple (ExceptT e m a) (ExceptT e m a) + where + simpleFresh (ExceptT v) = ExceptT <$> simpleFresh v + +instance + {-# OVERLAPPING #-} + ( GenSymSimple (m (Either e a)) (m (Either e a)), + Mergeable1 m, + Mergeable e, + Mergeable a + ) => + GenSym (ExceptT e m a) (ExceptT e m a) + +#define GENSYM_SIMPLE(symtype) \ +instance GenSym symtype symtype +#define GENSYM_SIMPLE_SIMPLE(symtype) \ +instance GenSymSimple symtype symtype where \ + simpleFresh _ = simpleFresh () +#define GENSYM_UNIT_SIMPLE(symtype) \ +instance GenSym () symtype where \ + fresh _ = mrgSingle <$> simpleFresh () +#define GENSYM_UNIT_SIMPLE_SIMPLE(symtype) \ +instance GenSymSimple () symtype where \ + simpleFresh _ = do; \ + ident <- getIdentifier; \ + FreshIndex index <- nextFreshIndex; \ + return $ isym ident index + +#define GENSYM_BV(symtype) \ +instance (KnownNat n, 1 <= n) => GenSym (symtype n) (symtype n) +#define GENSYM_SIMPLE_BV(symtype) \ +instance (KnownNat n, 1 <= n) => GenSymSimple (symtype n) (symtype n) where \ + simpleFresh _ = simpleFresh () +#define GENSYM_UNIT_BV(symtype) \ +instance (KnownNat n, 1 <= n) => GenSym () (symtype n) where \ + fresh _ = mrgSingle <$> simpleFresh () +#define GENSYM_UNIT_SIMPLE_BV(symtype) \ +instance (KnownNat n, 1 <= n) => GenSymSimple () (symtype n) where \ + simpleFresh _ = do; \ + ident <- getIdentifier; \ + FreshIndex index <- nextFreshIndex; \ + return $ isym ident index + +#define GENSYM_FUN(cop, op) \ +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_UNIT_FUN(cop, op) \ +instance (SupportedPrim (cop ca cb), 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) => \ + GenSymSimple () (op sa sb) where \ + simpleFresh _ = do; \ + ident <- getIdentifier; \ + FreshIndex index <- nextFreshIndex; \ + return $ isym ident index + +#if 1 +GENSYM_SIMPLE(SymBool) +GENSYM_SIMPLE_SIMPLE(SymBool) +GENSYM_UNIT_SIMPLE(SymBool) +GENSYM_UNIT_SIMPLE_SIMPLE(SymBool) +GENSYM_SIMPLE(SymInteger) +GENSYM_SIMPLE_SIMPLE(SymInteger) +GENSYM_UNIT_SIMPLE(SymInteger) +GENSYM_UNIT_SIMPLE_SIMPLE(SymInteger) + +GENSYM_BV(SymIntN) +GENSYM_SIMPLE_BV(SymIntN) +GENSYM_UNIT_BV(SymIntN) +GENSYM_UNIT_SIMPLE_BV(SymIntN) +GENSYM_BV(SymWordN) +GENSYM_SIMPLE_BV(SymWordN) +GENSYM_UNIT_BV(SymWordN) +GENSYM_UNIT_SIMPLE_BV(SymWordN) + +GENSYM_FUN((=->), (=~>)) +GENSYM_SIMPLE_FUN((=->), (=~>)) +GENSYM_UNIT_FUN((=->), (=~>)) +GENSYM_UNIT_SIMPLE_FUN((=->), (=~>)) +GENSYM_FUN((-->), (-~>)) +GENSYM_SIMPLE_FUN((-->), (-~>)) +GENSYM_UNIT_FUN((-->), (-~>)) +GENSYM_UNIT_SIMPLE_FUN((-->), (-~>)) +#endif + +instance (GenSym spec a, Mergeable a) => GenSym spec (UnionM a) + +instance (GenSym spec a) => GenSymSimple spec (UnionM a) where + simpleFresh spec = do + res <- fresh spec + if not (isMerged res) then error "Not merged" else return res + +instance + (GenSym a a, Mergeable a) => + GenSym (UnionM a) a + where + fresh spec = go (underlyingUnion $ tryMerge spec) + where + go (UnionSingle x) = fresh x + go (UnionIf _ _ _ t f) = mrgIf <$> simpleFresh () <*> go t <*> go f diff --git a/src/Grisette/Internal/Core/Data/Class/ITEOp.hs b/src/Grisette/Internal/Core/Data/Class/ITEOp.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Core/Data/Class/ITEOp.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Core.Data.Class.ITEOp +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Core.Data.Class.ITEOp + ( ITEOp (..), + ) +where + +import GHC.TypeNats (KnownNat, type (<=)) +import Grisette.Internal.SymPrim.GeneralFun (type (-->)) +import Grisette.Internal.SymPrim.Prim.Term + ( LinkedRep, + SupportedPrim (pevalITETerm), + ) +import Grisette.Internal.SymPrim.SymBV + ( SymIntN (SymIntN), + SymWordN (SymWordN), + ) +import Grisette.Internal.SymPrim.SymBool (SymBool (SymBool)) +import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>) (SymGeneralFun)) +import Grisette.Internal.SymPrim.SymInteger (SymInteger (SymInteger)) +import Grisette.Internal.SymPrim.SymTabularFun (type (=~>) (SymTabularFun)) +import Grisette.Internal.SymPrim.TabularFun (type (=->)) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim +-- >>> :set -XDataKinds +-- >>> :set -XBinaryLiterals +-- >>> :set -XFlexibleContexts +-- >>> :set -XFlexibleInstances +-- >>> :set -XFunctionalDependencies + +-- | ITE operator for solvable (see "Grisette.Core#solvable")s, including symbolic boolean, integer, etc. +-- +-- >>> let a = "a" :: SymBool +-- >>> let b = "b" :: SymBool +-- >>> let c = "c" :: SymBool +-- >>> symIte a b c +-- (ite a b c) +class ITEOp v where + symIte :: SymBool -> v -> v -> v + +-- ITEOp instances +#define ITEOP_SIMPLE(type) \ +instance ITEOp type where \ + symIte (SymBool c) (type t) (type f) = type $ pevalITETerm c t f; \ + {-# INLINE symIte #-} + +#define ITEOP_BV(type) \ +instance (KnownNat n, 1 <= n) => ITEOp (type n) where \ + symIte (SymBool c) (type t) (type f) = type $ pevalITETerm c t f; \ + {-# INLINE symIte #-} + +#define ITEOP_FUN(cop, op, cons) \ +instance (SupportedPrim (cop ca cb), LinkedRep ca sa, LinkedRep cb sb) => ITEOp (op sa sb) where \ + symIte (SymBool c) (cons t) (cons f) = cons $ pevalITETerm c t f; \ + {-# INLINE symIte #-} + +#if 1 +ITEOP_SIMPLE(SymBool) +ITEOP_SIMPLE(SymInteger) +ITEOP_BV(SymIntN) +ITEOP_BV(SymWordN) +ITEOP_FUN((=->), (=~>), SymTabularFun) +ITEOP_FUN((-->), (-~>), SymGeneralFun) +#endif diff --git a/src/Grisette/Internal/Core/Data/Class/LogicalOp.hs b/src/Grisette/Internal/Core/Data/Class/LogicalOp.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Core/Data/Class/LogicalOp.hs @@ -0,0 +1,106 @@ +module Grisette.Internal.Core.Data.Class.LogicalOp + ( LogicalOp (..), + ) +where + +import Grisette.Internal.SymPrim.Prim.Term + ( pevalAndTerm, + pevalImplyTerm, + pevalNotTerm, + pevalOrTerm, + pevalXorTerm, + ) +import Grisette.Internal.SymPrim.SymBool (SymBool (SymBool)) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim +-- >>> :set -XDataKinds +-- >>> :set -XBinaryLiterals +-- >>> :set -XFlexibleContexts +-- >>> :set -XFlexibleInstances +-- >>> :set -XFunctionalDependencies + +-- | Symbolic logical operators for symbolic booleans. +-- +-- >>> let t = con True :: SymBool +-- >>> let f = con False :: SymBool +-- >>> let a = "a" :: SymBool +-- >>> let b = "b" :: SymBool +-- >>> t .|| f +-- true +-- >>> a .|| t +-- true +-- >>> a .|| f +-- a +-- >>> a .|| b +-- (|| a b) +-- >>> t .&& f +-- false +-- >>> a .&& t +-- a +-- >>> a .&& f +-- false +-- >>> a .&& b +-- (&& a b) +-- >>> symNot t +-- false +-- >>> symNot f +-- true +-- >>> symNot a +-- (! a) +-- >>> t `symXor` f +-- true +-- >>> t `symXor` t +-- false +-- >>> a `symXor` t +-- (! a) +-- >>> a `symXor` f +-- a +-- >>> a `symXor` b +-- (|| (&& (! a) b) (&& a (! b))) +class LogicalOp b where + -- | Symbolic disjunction + (.||) :: b -> b -> b + a .|| b = symNot $ symNot a .&& symNot b + {-# INLINE (.||) #-} + + infixr 2 .|| + + -- | Symbolic conjunction + (.&&) :: b -> b -> b + a .&& b = symNot $ symNot a .|| symNot b + {-# INLINE (.&&) #-} + + infixr 3 .&& + + -- | Symbolic negation + symNot :: b -> b + + -- | Symbolic exclusive disjunction + symXor :: b -> b -> b + a `symXor` b = (a .&& symNot b) .|| (symNot a .&& b) + {-# INLINE symXor #-} + + -- | Symbolic implication + symImplies :: b -> b -> b + a `symImplies` b = symNot a .|| b + {-# INLINE symImplies #-} + + {-# MINIMAL (.||), symNot | (.&&), symNot #-} + +-- LogicalOp instances +instance LogicalOp Bool where + (.||) = (||) + {-# INLINE (.||) #-} + (.&&) = (&&) + {-# INLINE (.&&) #-} + symNot = not + {-# INLINE symNot #-} + +instance LogicalOp SymBool where + (SymBool l) .|| (SymBool r) = SymBool $ pevalOrTerm l r + (SymBool l) .&& (SymBool r) = SymBool $ pevalAndTerm l r + symNot (SymBool v) = SymBool $ pevalNotTerm v + (SymBool l) `symXor` (SymBool r) = SymBool $ pevalXorTerm l r + (SymBool l) `symImplies` (SymBool r) = SymBool $ pevalImplyTerm l r diff --git a/src/Grisette/Internal/Core/Data/Class/Mergeable.hs b/src/Grisette/Internal/Core/Data/Class/Mergeable.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Core/Data/Class/Mergeable.hs @@ -0,0 +1,1040 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Core.Data.Class.Mergeable +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Core.Data.Class.Mergeable + ( -- * Merging strategy + MergingStrategy (..), + + -- * Mergeable + Mergeable (..), + Mergeable1 (..), + rootStrategy1, + Mergeable2 (..), + rootStrategy2, + Mergeable3 (..), + rootStrategy3, + Mergeable' (..), + derivedRootStrategy, + + -- * Combinators for manually building merging strategies + wrapStrategy, + product2Strategy, + DynamicSortedIdx (..), + StrategyList (..), + buildStrategyList, + resolveStrategy, + resolveStrategy', + ) +where + +import Control.Exception + ( ArithException + ( Denormal, + DivideByZero, + LossOfPrecision, + Overflow, + RatioZeroDenominator, + Underflow + ), + ) +import Control.Monad.Cont (ContT (ContT)) +import Control.Monad.Except (ExceptT (ExceptT), runExceptT) +import Control.Monad.Identity + ( Identity (Identity, runIdentity), + IdentityT (IdentityT, runIdentityT), + ) +import qualified Control.Monad.RWS.Lazy as RWSLazy +import qualified Control.Monad.RWS.Strict as RWSStrict +import Control.Monad.Reader (ReaderT (ReaderT, runReaderT)) +import qualified Control.Monad.State.Lazy as StateLazy +import qualified Control.Monad.State.Strict as StateStrict +import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import qualified Data.ByteString as B +import Data.Functor.Classes + ( Eq1, + Ord1, + Show1, + compare1, + eq1, + showsPrec1, + ) +import Data.Functor.Sum (Sum (InL, InR)) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Kind (Type) +import qualified Data.Monoid as Monoid +import qualified Data.Text as T +import Data.Typeable + ( Typeable, + eqT, + type (:~:) (Refl), + ) +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.TypeNats (KnownNat, type (<=)) +import Generics.Deriving + ( Default (Default), + Default1 (Default1), + Generic (Rep, from, to), + Generic1 (Rep1, from1, to1), + K1 (K1, unK1), + M1 (M1, unM1), + Par1 (Par1, unPar1), + Rec1 (Rec1, unRec1), + U1, + V1, + type (:*:) ((:*:)), + type (:+:) (L1, R1), + ) +import Grisette.Internal.Core.Control.Exception (AssertionError, VerificationConditions) +import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp (symIte)) +import Grisette.Internal.SymPrim.BV + ( BitwidthMismatch, + IntN, + WordN, + ) +import Grisette.Internal.SymPrim.GeneralFun (type (-->)) +import Grisette.Internal.SymPrim.Prim.Term + ( LinkedRep, + SupportedPrim, + ) +import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN) +import Grisette.Internal.SymPrim.SymBool (SymBool) +import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>)) +import Grisette.Internal.SymPrim.SymInteger (SymInteger) +import Grisette.Internal.SymPrim.SymTabularFun (type (=~>)) +import Grisette.Internal.SymPrim.TabularFun (type (=->)) +import Unsafe.Coerce (unsafeCoerce) + +-- | Helper type for combining arbitrary number of indices into one. +-- Useful when trying to write efficient merge strategy for lists/vectors. +data DynamicSortedIdx where + DynamicSortedIdx :: forall idx. (Show idx, Ord idx, Typeable idx) => idx -> DynamicSortedIdx + +instance Eq DynamicSortedIdx where + (DynamicSortedIdx (a :: a)) == (DynamicSortedIdx (b :: b)) = case eqT @a @b of + Just Refl -> a == b + _ -> False + {-# INLINE (==) #-} + +instance Ord DynamicSortedIdx where + compare (DynamicSortedIdx (a :: a)) (DynamicSortedIdx (b :: b)) = case eqT @a @b of + Just Refl -> compare a b + _ -> error "This Ord is incomplete" + {-# INLINE compare #-} + +instance Show DynamicSortedIdx where + show (DynamicSortedIdx a) = show a + +-- | Resolves the indices and the terminal merge strategy for a value of some 'Mergeable' type. +resolveStrategy :: forall x. MergingStrategy x -> x -> ([DynamicSortedIdx], MergingStrategy x) +resolveStrategy s x = resolveStrategy' x s +{-# INLINE resolveStrategy #-} + +-- | Resolves the indices and the terminal merge strategy for a value given a merge strategy for its type. +resolveStrategy' :: forall x. x -> MergingStrategy x -> ([DynamicSortedIdx], MergingStrategy x) +resolveStrategy' x = go + where + go :: MergingStrategy x -> ([DynamicSortedIdx], MergingStrategy x) + go (SortedStrategy idxFun subStrategy) = case go ss of + (idxs, r) -> (DynamicSortedIdx idx : idxs, r) + where + idx = idxFun x + ss = subStrategy idx + go s = ([], s) +{-# INLINE resolveStrategy' #-} + +-- | Merging strategies. +-- +-- __You probably do not need to know the details of this type if you are only going__ +-- __to use algebraic data types. You can get merging strategies for them with type__ +-- __derivation.__ +-- +-- In Grisette, a merged union (if-then-else tree) follows the __/hierarchical/__ +-- __/sorted representation invariant/__ with regards to some merging strategy. +-- +-- A merging strategy encodes how to merge a __/subset/__ of the values of a +-- given type. We have three types of merging strategies: +-- +-- * Simple strategy +-- * Sorted strategy +-- * No strategy +-- +-- The 'SimpleStrategy' merges values with a simple merge function. +-- For example, +-- +-- * the symbolic boolean values can be directly merged with 'symIte'. +-- +-- * the set @{1}@, which is a subset of the values of the type @Integer@, +-- can be simply merged as the set contains only a single value. +-- +-- * all the 'Just' values of the type @Maybe SymBool@ can be simply merged +-- by merging the wrapped symbolic boolean with 'symIte'. +-- +-- The 'SortedStrategy' merges values by first grouping the values with an +-- indexing function, and the values with the same index will be organized as +-- a sub-tree in the if-then-else structure of 'Grisette.Core.Data.UnionBase.UnionBase'. +-- Each group (sub-tree) will be further merged with a sub-strategy for the +-- index. +-- The index type should be a totally ordered type (with the 'Ord' +-- type class). Grisette will use the indexing function to partition the values +-- into sub-trees, and organize them in a sorted way. The sub-trees will further +-- be merged with the sub-strategies. For example, +-- +-- * all the integers can be merged with 'SortedStrategy' by indexing with +-- the identity function and use the 'SimpleStrategy' shown before as the +-- sub-strategies. +-- +-- * all the @Maybe SymBool@ values can be merged with 'SortedStrategy' by +-- indexing with 'Data.Maybe.isJust', the 'Nothing' and 'Just' values can then +-- then be merged with different simple strategies as sub-strategies. +-- +-- The 'NoStrategy' does not perform any merging. +-- For example, we cannot merge values with function types that returns concrete +-- lists. +-- +-- For ADTs, we can automatically derive the 'Mergeable' type class, which +-- provides a merging strategy. +-- +-- If the derived version does not work for you, you should determine +-- if your type can be directly merged with a merging function. If so, you can +-- implement the merging strategy as a 'SimpleStrategy'. +-- If the type cannot be directly merged with a merging function, but could be +-- partitioned into subsets of values that can be simply merged with a function, +-- you should implement the merging strategy as a 'SortedStrategy'. +-- For easier building of the merging strategies, check out the combinators +-- like `wrapStrategy`. +-- +-- For more details, please see the documents of the constructors, or refer to +-- [Grisette's paper](https://lsrcz.github.io/files/POPL23.pdf). +data MergingStrategy a where + -- | Simple mergeable strategy. + -- + -- For symbolic booleans, we can implement its merge strategy as follows: + -- + -- > SimpleStrategy symIte :: MergingStrategy SymBool + SimpleStrategy :: + -- | Merge function. + (SymBool -> a -> a -> a) -> + MergingStrategy a + -- | Sorted mergeable strategy. + -- + -- For Integers, we can implement its merge strategy as follows: + -- + -- > SortedStrategy id (\_ -> SimpleStrategy $ \_ t _ -> t) + -- + -- For @Maybe SymBool@, we can implement its merge strategy as follows: + -- + -- > SortedStrategy + -- > (\case; Nothing -> False; Just _ -> True) + -- > (\idx -> + -- > if idx + -- > then SimpleStrategy $ \_ t _ -> t + -- > else SimpleStrategy $ \cond (Just l) (Just r) -> Just $ symIte cond l r) + SortedStrategy :: + (Ord idx, Typeable idx, Show idx) => + -- | Indexing function + (a -> idx) -> + -- | Sub-strategy function + (idx -> MergingStrategy a) -> + MergingStrategy a + -- | For preventing the merging intentionally. This could be + -- useful for keeping some value concrete and may help generate more efficient + -- formulas. + -- + -- See [Grisette's paper](https://lsrcz.github.io/files/POPL23.pdf) for + -- details. + NoStrategy :: MergingStrategy a + +-- | Useful utility function for building merge strategies manually. +-- +-- For example, to build the merge strategy for the just branch of @Maybe a@, +-- one could write +-- +-- > wrapStrategy Just fromMaybe rootStrategy :: MergingStrategy (Maybe a) +wrapStrategy :: + -- | The merge strategy to be wrapped + MergingStrategy a -> + -- | The wrap function + (a -> b) -> + -- | The unwrap function, which does not have to be defined for every value + (b -> a) -> + MergingStrategy b +wrapStrategy (SimpleStrategy m) wrap unwrap = + SimpleStrategy + ( \cond ifTrue ifFalse -> + wrap $ m cond (unwrap ifTrue) (unwrap ifFalse) + ) +wrapStrategy (SortedStrategy idxFun substrategy) wrap unwrap = + SortedStrategy + (idxFun . unwrap) + (\idx -> wrapStrategy (substrategy idx) wrap unwrap) +wrapStrategy NoStrategy _ _ = NoStrategy +{-# INLINE wrapStrategy #-} + +-- | Each type is associated with a root merge strategy given by 'rootStrategy'. +-- The root merge strategy should be able to merge every value of the type. +-- Grisette will use the root merge strategy to merge the values of the type in +-- a union. +-- +-- __Note 1:__ This type class can be derived for algebraic data types. +-- You may need the @DerivingVia@ and @DerivingStrategies@ extensions. +-- +-- > data X = ... deriving Generic deriving Mergeable via (Default X) +class Mergeable a where + -- | The root merging strategy for the type. + rootStrategy :: MergingStrategy a + +-- | Lifting of the 'Mergeable' class to unary type constructors. +class Mergeable1 (u :: Type -> Type) where + -- | Lift merge strategy through the type constructor. + liftRootStrategy :: MergingStrategy a -> MergingStrategy (u a) + +-- | Lift the root merge strategy through the unary type constructor. +rootStrategy1 :: (Mergeable a, Mergeable1 u) => MergingStrategy (u a) +rootStrategy1 = liftRootStrategy rootStrategy +{-# INLINE rootStrategy1 #-} + +-- | Lifting of the 'Mergeable' class to binary type constructors. +class Mergeable2 (u :: Type -> Type -> Type) where + -- | Lift merge strategy through the type constructor. + liftRootStrategy2 :: MergingStrategy a -> MergingStrategy b -> MergingStrategy (u a b) + +-- | Lift the root merge strategy through the binary type constructor. +rootStrategy2 :: (Mergeable a, Mergeable b, Mergeable2 u) => MergingStrategy (u a b) +rootStrategy2 = liftRootStrategy2 rootStrategy rootStrategy +{-# INLINE rootStrategy2 #-} + +-- | Lifting of the 'Mergeable' class to ternary type constructors. +class Mergeable3 (u :: Type -> Type -> Type -> Type) where + -- | Lift merge strategy through the type constructor. + liftRootStrategy3 :: MergingStrategy a -> MergingStrategy b -> MergingStrategy c -> MergingStrategy (u a b c) + +-- | Lift the root merge strategy through the binary type constructor. +rootStrategy3 :: (Mergeable a, Mergeable b, Mergeable c, Mergeable3 u) => MergingStrategy (u a b c) +rootStrategy3 = liftRootStrategy3 rootStrategy rootStrategy rootStrategy +{-# INLINE rootStrategy3 #-} + +-- | Useful utility function for building merge strategies for product types +-- manually. +-- +-- For example, to build the merge strategy for the following product type, +-- one could write +-- +-- > data X = X { x1 :: Int, x2 :: Bool } +-- > product2Strategy X (\(X a b) -> (a, b)) rootStrategy rootStrategy +-- > :: MergingStrategy X +product2Strategy :: + -- | The wrap function + (a -> b -> r) -> + -- | The unwrap function, which does not have to be defined for every value + (r -> (a, b)) -> + -- | The first merge strategy to be wrapped + MergingStrategy a -> + -- | The second merge strategy to be wrapped + MergingStrategy b -> + MergingStrategy r +product2Strategy wrap unwrap strategy1 strategy2 = + case (strategy1, strategy2) of + (NoStrategy, _) -> NoStrategy + (_, NoStrategy) -> NoStrategy + (SimpleStrategy m1, SimpleStrategy m2) -> + SimpleStrategy $ \cond t f -> case (unwrap t, unwrap f) of + ((hdt, tlt), (hdf, tlf)) -> + wrap (m1 cond hdt hdf) (m2 cond tlt tlf) + (s1@(SimpleStrategy _), SortedStrategy idxf subf) -> + SortedStrategy (idxf . snd . unwrap) (product2Strategy wrap unwrap s1 . subf) + (SortedStrategy idxf subf, s2) -> + SortedStrategy (idxf . fst . unwrap) (\idx -> product2Strategy wrap unwrap (subf idx) s2) +{-# INLINE product2Strategy #-} + +instance (Mergeable' a, Mergeable' b) => Mergeable' (a :*: b) where + rootStrategy' = product2Strategy (:*:) (\(a :*: b) -> (a, b)) rootStrategy' rootStrategy' + {-# INLINE rootStrategy' #-} + +-- instances + +#define CONCRETE_ORD_MERGEABLE(type) \ +instance Mergeable type where \ + rootStrategy = \ + let sub = SimpleStrategy $ \_ t _ -> t \ + in SortedStrategy id $ const sub + +#define CONCRETE_ORD_MERGEABLE_BV(type) \ +instance (KnownNat n, 1 <= n) => Mergeable (type n) where \ + rootStrategy = \ + let sub = SimpleStrategy $ \_ t _ -> t \ + in SortedStrategy id $ const sub + +#if 1 +CONCRETE_ORD_MERGEABLE(Bool) +CONCRETE_ORD_MERGEABLE(Integer) +CONCRETE_ORD_MERGEABLE(Char) +CONCRETE_ORD_MERGEABLE(Int) +CONCRETE_ORD_MERGEABLE(Int8) +CONCRETE_ORD_MERGEABLE(Int16) +CONCRETE_ORD_MERGEABLE(Int32) +CONCRETE_ORD_MERGEABLE(Int64) +CONCRETE_ORD_MERGEABLE(Word) +CONCRETE_ORD_MERGEABLE(Word8) +CONCRETE_ORD_MERGEABLE(Word16) +CONCRETE_ORD_MERGEABLE(Word32) +CONCRETE_ORD_MERGEABLE(Word64) +CONCRETE_ORD_MERGEABLE(B.ByteString) +CONCRETE_ORD_MERGEABLE(T.Text) +CONCRETE_ORD_MERGEABLE_BV(WordN) +CONCRETE_ORD_MERGEABLE_BV(IntN) +#endif + +-- () +deriving via (Default ()) instance Mergeable () + +-- Either +deriving via (Default (Either e a)) instance (Mergeable e, Mergeable a) => Mergeable (Either e a) + +deriving via (Default1 (Either e)) instance (Mergeable e) => Mergeable1 (Either e) + +instance Mergeable2 Either where + liftRootStrategy2 m1 m2 = + SortedStrategy + ( \case + Left _ -> False + Right _ -> True + ) + ( \case + False -> wrapStrategy m1 Left (\case (Left v) -> v; _ -> undefined) + True -> wrapStrategy m2 Right (\case (Right v) -> v; _ -> undefined) + ) + {-# INLINE liftRootStrategy2 #-} + +-- Maybe +deriving via (Default (Maybe a)) instance (Mergeable a) => Mergeable (Maybe a) + +deriving via (Default1 Maybe) instance Mergeable1 Maybe + +-- | Helper type for building efficient merge strategy for list-like containers. +data StrategyList container where + StrategyList :: + forall a container. + container [DynamicSortedIdx] -> + container (MergingStrategy a) -> + StrategyList container + +-- | Helper function for building efficient merge strategy for list-like containers. +buildStrategyList :: + forall a container. + (Functor container) => + MergingStrategy a -> + container a -> + StrategyList container +buildStrategyList s l = StrategyList idxs strategies + where + r = resolveStrategy s <$> l + idxs = fst <$> r + strategies = snd <$> r +{-# INLINE buildStrategyList #-} + +instance (Eq1 container) => Eq (StrategyList container) where + (StrategyList idxs1 _) == (StrategyList idxs2 _) = eq1 idxs1 idxs2 + {-# INLINE (==) #-} + +instance (Ord1 container) => Ord (StrategyList container) where + compare (StrategyList idxs1 _) (StrategyList idxs2 _) = compare1 idxs1 idxs2 + {-# INLINE compare #-} + +instance (Show1 container) => Show (StrategyList container) where + showsPrec i (StrategyList idxs1 _) = showsPrec1 i idxs1 + +-- List +instance (Mergeable a) => Mergeable [a] where + rootStrategy = case rootStrategy :: MergingStrategy a of + SimpleStrategy m -> + SortedStrategy length $ \_ -> + SimpleStrategy $ \cond -> zipWith (m cond) + NoStrategy -> + SortedStrategy length $ const NoStrategy + _ -> SortedStrategy length $ \_ -> + SortedStrategy (buildStrategyList rootStrategy) $ \(StrategyList _ strategies) -> + let s :: [MergingStrategy a] = unsafeCoerce strategies + allSimple = all (\case SimpleStrategy _ -> True; _ -> False) s + in if allSimple + then SimpleStrategy $ \cond l r -> + (\case (SimpleStrategy f, l1, r1) -> f cond l1 r1; _ -> error "impossible") <$> zip3 s l r + else NoStrategy + {-# INLINE rootStrategy #-} + +instance Mergeable1 [] where + liftRootStrategy (ms :: MergingStrategy a) = case ms of + SimpleStrategy m -> + SortedStrategy length $ \_ -> + SimpleStrategy $ \cond -> zipWith (m cond) + NoStrategy -> + SortedStrategy length $ const NoStrategy + _ -> SortedStrategy length $ \_ -> + SortedStrategy (buildStrategyList ms) $ \(StrategyList _ strategies) -> + let s :: [MergingStrategy a] = unsafeCoerce strategies + allSimple = all (\case SimpleStrategy _ -> True; _ -> False) s + in if allSimple + then SimpleStrategy $ \cond l r -> + (\case (SimpleStrategy f, l1, r1) -> f cond l1 r1; _ -> error "impossible") <$> zip3 s l r + else NoStrategy + {-# INLINE liftRootStrategy #-} + +-- (,) +deriving via (Default (a, b)) instance (Mergeable a, Mergeable b) => Mergeable (a, b) + +deriving via (Default1 ((,) a)) instance (Mergeable a) => Mergeable1 ((,) a) + +instance Mergeable2 (,) where + liftRootStrategy2 = product2Strategy (,) id + {-# INLINE liftRootStrategy2 #-} + +-- (,,) +deriving via + (Default (a, b, c)) + instance + (Mergeable a, Mergeable b, Mergeable c) => Mergeable (a, b, c) + +deriving via + (Default1 ((,,) a b)) + instance + (Mergeable a, Mergeable b) => Mergeable1 ((,,) a b) + +instance (Mergeable a) => Mergeable2 ((,,) a) where + liftRootStrategy2 = liftRootStrategy3 rootStrategy + {-# INLINE liftRootStrategy2 #-} + +instance Mergeable3 (,,) where + liftRootStrategy3 m1 m2 m3 = + product2Strategy + (\a (b, c) -> (a, b, c)) + (\(a, b, c) -> (a, (b, c))) + m1 + (liftRootStrategy2 m2 m3) + {-# INLINE liftRootStrategy3 #-} + +-- (,,,) +deriving via + (Default (a, b, c, d)) + instance + (Mergeable a, Mergeable b, Mergeable c, Mergeable d) => + Mergeable (a, b, c, d) + +deriving via + (Default1 ((,,,) a b c)) + instance + (Mergeable a, Mergeable b, Mergeable c) => + Mergeable1 ((,,,) a b c) + +-- (,,,,) +deriving via + (Default (a, b, c, d, e)) + instance + (Mergeable a, Mergeable b, Mergeable c, Mergeable d, Mergeable e) => + Mergeable (a, b, c, d, e) + +deriving via + (Default1 ((,,,,) a b c d)) + instance + (Mergeable a, Mergeable b, Mergeable c, Mergeable d) => + Mergeable1 ((,,,,) a b c d) + +-- (,,,,,) +deriving via + (Default (a, b, c, d, e, f)) + instance + ( Mergeable a, + Mergeable b, + Mergeable c, + Mergeable d, + Mergeable e, + Mergeable f + ) => + Mergeable (a, b, c, d, e, f) + +deriving via + (Default1 ((,,,,,) a b c d e)) + instance + (Mergeable a, Mergeable b, Mergeable c, Mergeable d, Mergeable e) => + Mergeable1 ((,,,,,) a b c d e) + +-- (,,,,,,) +deriving via + (Default (a, b, c, d, e, f, g)) + instance + ( Mergeable a, + Mergeable b, + Mergeable c, + Mergeable d, + Mergeable e, + Mergeable f, + Mergeable g + ) => + Mergeable (a, b, c, d, e, f, g) + +deriving via + (Default1 ((,,,,,,) a b c d e f)) + instance + ( Mergeable a, + Mergeable b, + Mergeable c, + Mergeable d, + Mergeable e, + Mergeable f + ) => + Mergeable1 ((,,,,,,) a b c d e f) + +-- (,,,,,,,) +deriving via + (Default (a, b, c, d, e, f, g, h)) + instance + ( Mergeable a, + Mergeable b, + Mergeable c, + Mergeable d, + Mergeable e, + Mergeable f, + Mergeable g, + Mergeable h + ) => + Mergeable (a, b, c, d, e, f, g, h) + +deriving via + (Default1 ((,,,,,,,) a b c d e f g)) + instance + ( Mergeable a, + Mergeable b, + Mergeable c, + Mergeable d, + Mergeable e, + Mergeable f, + Mergeable g + ) => + Mergeable1 ((,,,,,,,) a b c d e f g) + +-- function +instance (Mergeable b) => Mergeable (a -> b) where + rootStrategy = case rootStrategy @b of + SimpleStrategy m -> SimpleStrategy $ \cond t f v -> m cond (t v) (f v) + _ -> NoStrategy + {-# INLINE rootStrategy #-} + +instance Mergeable1 ((->) a) where + liftRootStrategy ms = case ms of + SimpleStrategy m -> SimpleStrategy $ \cond t f v -> m cond (t v) (f v) + _ -> NoStrategy + {-# INLINE liftRootStrategy #-} + +-- MaybeT +instance (Mergeable1 m, Mergeable a) => Mergeable (MaybeT m a) where + rootStrategy = wrapStrategy rootStrategy1 MaybeT runMaybeT + {-# INLINE rootStrategy #-} + +instance (Mergeable1 m) => Mergeable1 (MaybeT m) where + liftRootStrategy m = wrapStrategy (liftRootStrategy (liftRootStrategy m)) MaybeT runMaybeT + {-# INLINE liftRootStrategy #-} + +-- ExceptT +instance + (Mergeable1 m, Mergeable e, Mergeable a) => + Mergeable (ExceptT e m a) + where + rootStrategy = wrapStrategy rootStrategy1 ExceptT runExceptT + {-# INLINE rootStrategy #-} + +instance (Mergeable1 m, Mergeable e) => Mergeable1 (ExceptT e m) where + liftRootStrategy m = wrapStrategy (liftRootStrategy (liftRootStrategy m)) ExceptT runExceptT + {-# INLINE liftRootStrategy #-} + +-- state +instance + (Mergeable s, Mergeable a, Mergeable1 m) => + Mergeable (StateLazy.StateT s m a) + where + rootStrategy = wrapStrategy (liftRootStrategy rootStrategy1) StateLazy.StateT StateLazy.runStateT + {-# INLINE rootStrategy #-} + +instance (Mergeable s, Mergeable1 m) => Mergeable1 (StateLazy.StateT s m) where + liftRootStrategy m = + wrapStrategy + (liftRootStrategy (liftRootStrategy (liftRootStrategy2 m rootStrategy))) + StateLazy.StateT + StateLazy.runStateT + {-# INLINE liftRootStrategy #-} + +instance + (Mergeable s, Mergeable a, Mergeable1 m) => + Mergeable (StateStrict.StateT s m a) + where + rootStrategy = + wrapStrategy (liftRootStrategy rootStrategy1) StateStrict.StateT StateStrict.runStateT + {-# INLINE rootStrategy #-} + +instance (Mergeable s, Mergeable1 m) => Mergeable1 (StateStrict.StateT s m) where + liftRootStrategy m = + wrapStrategy + (liftRootStrategy (liftRootStrategy (liftRootStrategy2 m rootStrategy))) + StateStrict.StateT + StateStrict.runStateT + {-# INLINE liftRootStrategy #-} + +-- writer +instance + (Mergeable s, Mergeable a, Mergeable1 m) => + Mergeable (WriterLazy.WriterT s m a) + where + rootStrategy = wrapStrategy (liftRootStrategy rootStrategy1) WriterLazy.WriterT WriterLazy.runWriterT + {-# INLINE rootStrategy #-} + +instance (Mergeable s, Mergeable1 m) => Mergeable1 (WriterLazy.WriterT s m) where + liftRootStrategy m = + wrapStrategy + (liftRootStrategy (liftRootStrategy2 m rootStrategy)) + WriterLazy.WriterT + WriterLazy.runWriterT + {-# INLINE liftRootStrategy #-} + +instance + (Mergeable s, Mergeable a, Mergeable1 m) => + Mergeable (WriterStrict.WriterT s m a) + where + rootStrategy = wrapStrategy (liftRootStrategy rootStrategy1) WriterStrict.WriterT WriterStrict.runWriterT + {-# INLINE rootStrategy #-} + +instance (Mergeable s, Mergeable1 m) => Mergeable1 (WriterStrict.WriterT s m) where + liftRootStrategy m = + wrapStrategy + (liftRootStrategy (liftRootStrategy2 m rootStrategy)) + WriterStrict.WriterT + WriterStrict.runWriterT + {-# INLINE liftRootStrategy #-} + +-- reader +instance + (Mergeable a, Mergeable1 m) => + Mergeable (ReaderT s m a) + where + rootStrategy = wrapStrategy (liftRootStrategy rootStrategy1) ReaderT runReaderT + {-# INLINE rootStrategy #-} + +instance (Mergeable1 m) => Mergeable1 (ReaderT s m) where + liftRootStrategy m = + wrapStrategy + (liftRootStrategy (liftRootStrategy m)) + ReaderT + runReaderT + {-# INLINE liftRootStrategy #-} + +-- Sum +instance + (Mergeable1 l, Mergeable1 r, Mergeable x) => + Mergeable (Sum l r x) + where + rootStrategy = + SortedStrategy + ( \case + InL _ -> False + InR _ -> True + ) + ( \case + False -> wrapStrategy rootStrategy1 InL (\case (InL v) -> v; _ -> error "impossible") + True -> wrapStrategy rootStrategy1 InR (\case (InR v) -> v; _ -> error "impossible") + ) + {-# INLINE rootStrategy #-} + +instance (Mergeable1 l, Mergeable1 r) => Mergeable1 (Sum l r) where + liftRootStrategy m = + SortedStrategy + ( \case + InL _ -> False + InR _ -> True + ) + ( \case + False -> wrapStrategy (liftRootStrategy m) InL (\case (InL v) -> v; _ -> error "impossible") + True -> wrapStrategy (liftRootStrategy m) InR (\case (InR v) -> v; _ -> error "impossible") + ) + {-# INLINE liftRootStrategy #-} + +-- Ordering +deriving via + (Default Ordering) + instance + Mergeable Ordering + +-- Generic +deriving via + (Default (U1 x)) + instance + Mergeable (U1 x) + +deriving via + (Default (V1 x)) + instance + Mergeable (V1 x) + +deriving via + (Default (K1 i c x)) + instance + (Mergeable c) => Mergeable (K1 i c x) + +deriving via + (Default (M1 i c a x)) + instance + (Mergeable (a x)) => Mergeable (M1 i c a x) + +deriving via + (Default ((a :+: b) x)) + instance + (Mergeable (a x), Mergeable (b x)) => Mergeable ((a :+: b) x) + +deriving via + (Default ((a :*: b) x)) + instance + (Mergeable (a x), Mergeable (b x)) => Mergeable ((a :*: b) x) + +-- Identity +instance (Mergeable a) => Mergeable (Identity a) where + rootStrategy = wrapStrategy rootStrategy Identity runIdentity + {-# INLINE rootStrategy #-} + +instance Mergeable1 Identity where + liftRootStrategy m = wrapStrategy m Identity runIdentity + {-# INLINE liftRootStrategy #-} + +-- IdentityT +instance (Mergeable1 m, Mergeable a) => Mergeable (IdentityT m a) where + rootStrategy = wrapStrategy rootStrategy1 IdentityT runIdentityT + {-# INLINE rootStrategy #-} + +instance (Mergeable1 m) => Mergeable1 (IdentityT m) where + liftRootStrategy m = wrapStrategy (liftRootStrategy m) IdentityT runIdentityT + {-# INLINE liftRootStrategy #-} + +-- ContT +instance (Mergeable1 m, Mergeable r) => Mergeable (ContT r m a) where + rootStrategy = + wrapStrategy + (liftRootStrategy rootStrategy1) + ContT + (\(ContT v) -> v) + {-# INLINE rootStrategy #-} + +instance (Mergeable1 m, Mergeable r) => Mergeable1 (ContT r m) where + liftRootStrategy _ = + wrapStrategy + (liftRootStrategy rootStrategy1) + ContT + (\(ContT v) -> v) + {-# INLINE liftRootStrategy #-} + +-- RWS +instance + (Mergeable s, Mergeable w, Mergeable a, Mergeable1 m) => + Mergeable (RWSLazy.RWST r w s m a) + where + rootStrategy = wrapStrategy (liftRootStrategy (liftRootStrategy rootStrategy1)) RWSLazy.RWST (\(RWSLazy.RWST m) -> m) + {-# INLINE rootStrategy #-} + +instance + (Mergeable s, Mergeable w, Mergeable1 m) => + Mergeable1 (RWSLazy.RWST r w s m) + where + liftRootStrategy m = + wrapStrategy + (liftRootStrategy (liftRootStrategy (liftRootStrategy (liftRootStrategy3 m rootStrategy rootStrategy)))) + RWSLazy.RWST + (\(RWSLazy.RWST rws) -> rws) + {-# INLINE liftRootStrategy #-} + +instance + (Mergeable s, Mergeable w, Mergeable a, Mergeable1 m) => + Mergeable (RWSStrict.RWST r w s m a) + where + rootStrategy = wrapStrategy (liftRootStrategy (liftRootStrategy rootStrategy1)) RWSStrict.RWST (\(RWSStrict.RWST m) -> m) + {-# INLINE rootStrategy #-} + +instance + (Mergeable s, Mergeable w, Mergeable1 m) => + Mergeable1 (RWSStrict.RWST r w s m) + where + liftRootStrategy m = + wrapStrategy + (liftRootStrategy (liftRootStrategy (liftRootStrategy (liftRootStrategy3 m rootStrategy rootStrategy)))) + RWSStrict.RWST + (\(RWSStrict.RWST rws) -> rws) + {-# INLINE liftRootStrategy #-} + +-- Data.Monoid module +deriving via + (Default (Monoid.Sum a)) + instance + (Mergeable a) => Mergeable (Monoid.Sum a) + +deriving via (Default1 Monoid.Sum) instance Mergeable1 Monoid.Sum + +#define MERGEABLE_SIMPLE(symtype) \ +instance Mergeable symtype where \ + rootStrategy = SimpleStrategy symIte + +#define MERGEABLE_BV(symtype) \ +instance (KnownNat n, 1 <= n) => Mergeable (symtype n) where \ + rootStrategy = SimpleStrategy symIte + +#define MERGEABLE_FUN(cop, op) \ +instance (SupportedPrim (cop ca cb), LinkedRep ca sa, LinkedRep cb sb) => \ + Mergeable (op sa sb) where \ + rootStrategy = SimpleStrategy symIte + +#if 1 +MERGEABLE_SIMPLE(SymBool) +MERGEABLE_SIMPLE(SymInteger) +MERGEABLE_BV(SymIntN) +MERGEABLE_BV(SymWordN) +MERGEABLE_FUN((=->), (=~>)) +MERGEABLE_FUN((-->), (-~>)) +#endif + +-- Exceptions +instance Mergeable ArithException where + rootStrategy = + SortedStrategy + ( \case + Overflow -> 0 :: Int + Underflow -> 1 :: Int + LossOfPrecision -> 2 :: Int + DivideByZero -> 3 :: Int + Denormal -> 4 :: Int + RatioZeroDenominator -> 5 :: Int + ) + (const $ SimpleStrategy $ \_ l _ -> l) + +deriving via (Default BitwidthMismatch) instance (Mergeable BitwidthMismatch) + +deriving via (Default AssertionError) instance Mergeable AssertionError + +deriving via (Default VerificationConditions) instance Mergeable VerificationConditions + +instance (Generic a, Mergeable' (Rep a)) => Mergeable (Default a) where + rootStrategy = unsafeCoerce (derivedRootStrategy :: MergingStrategy a) + {-# NOINLINE rootStrategy #-} + +-- | Generic derivation for the 'Mergeable' class. +-- +-- Usually you can derive the merging strategy with the @DerivingVia@ and +-- @DerivingStrategies@ extension. +-- +-- > data X = ... deriving (Generic) deriving Mergeable via (Default X) +derivedRootStrategy :: (Generic a, Mergeable' (Rep a)) => MergingStrategy a +derivedRootStrategy = wrapStrategy rootStrategy' to from +{-# INLINE derivedRootStrategy #-} + +instance (Generic1 u, Mergeable1' (Rep1 u)) => Mergeable1 (Default1 u) where + liftRootStrategy = unsafeCoerce (derivedLiftMergingStrategy :: MergingStrategy a -> MergingStrategy (u a)) + {-# NOINLINE liftRootStrategy #-} + +class Mergeable1' (u :: Type -> Type) where + liftRootStrategy' :: MergingStrategy a -> MergingStrategy (u a) + +instance Mergeable1' U1 where + liftRootStrategy' _ = SimpleStrategy (\_ t _ -> t) + {-# INLINE liftRootStrategy' #-} + +instance Mergeable1' V1 where + liftRootStrategy' _ = SimpleStrategy (\_ t _ -> t) + {-# INLINE liftRootStrategy' #-} + +instance Mergeable1' Par1 where + liftRootStrategy' m = wrapStrategy m Par1 unPar1 + {-# INLINE liftRootStrategy' #-} + +instance (Mergeable1 f) => Mergeable1' (Rec1 f) where + liftRootStrategy' m = wrapStrategy (liftRootStrategy m) Rec1 unRec1 + {-# INLINE liftRootStrategy' #-} + +instance (Mergeable c) => Mergeable1' (K1 i c) where + liftRootStrategy' _ = wrapStrategy rootStrategy K1 unK1 + {-# INLINE liftRootStrategy' #-} + +instance (Mergeable1' a) => Mergeable1' (M1 i c a) where + liftRootStrategy' m = wrapStrategy (liftRootStrategy' m) M1 unM1 + {-# INLINE liftRootStrategy' #-} + +instance (Mergeable1' a, Mergeable1' b) => Mergeable1' (a :+: b) where + liftRootStrategy' m = + SortedStrategy + ( \case + L1 _ -> False + R1 _ -> True + ) + ( \idx -> + if not idx + then wrapStrategy (liftRootStrategy' m) L1 (\case (L1 v) -> v; _ -> error "impossible") + else wrapStrategy (liftRootStrategy' m) R1 (\case (R1 v) -> v; _ -> error "impossible") + ) + {-# INLINE liftRootStrategy' #-} + +instance (Mergeable1' a, Mergeable1' b) => Mergeable1' (a :*: b) where + liftRootStrategy' m = product2Strategy (:*:) (\(a :*: b) -> (a, b)) (liftRootStrategy' m) (liftRootStrategy' m) + {-# INLINE liftRootStrategy' #-} + +-- | Generic derivation for the 'Mergeable' class. +derivedLiftMergingStrategy :: (Generic1 u, Mergeable1' (Rep1 u)) => MergingStrategy a -> MergingStrategy (u a) +derivedLiftMergingStrategy m = wrapStrategy (liftRootStrategy' m) to1 from1 +{-# INLINE derivedLiftMergingStrategy #-} + +-- | Auxiliary class for the generic derivation for the 'Mergeable' class. +class Mergeable' f where + rootStrategy' :: MergingStrategy (f a) + +instance Mergeable' U1 where + rootStrategy' = SimpleStrategy (\_ t _ -> t) + {-# INLINE rootStrategy' #-} + +instance Mergeable' V1 where + rootStrategy' = SimpleStrategy (\_ t _ -> t) + {-# INLINE rootStrategy' #-} + +instance (Mergeable c) => Mergeable' (K1 i c) where + rootStrategy' = wrapStrategy rootStrategy K1 unK1 + {-# INLINE rootStrategy' #-} + +instance (Mergeable' a) => Mergeable' (M1 i c a) where + rootStrategy' = wrapStrategy rootStrategy' M1 unM1 + {-# INLINE rootStrategy' #-} + +instance (Mergeable' a, Mergeable' b) => Mergeable' (a :+: b) where + rootStrategy' = + SortedStrategy + ( \case + L1 _ -> False + R1 _ -> True + ) + ( \idx -> + if not idx + then wrapStrategy rootStrategy' L1 (\case (L1 v) -> v; _ -> undefined) + else wrapStrategy rootStrategy' R1 (\case (R1 v) -> v; _ -> undefined) + ) + {-# INLINE rootStrategy' #-} diff --git a/src/Grisette/Internal/Core/Data/Class/ModelOps.hs b/src/Grisette/Internal/Core/Data/Class/ModelOps.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Core/Data/Class/ModelOps.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Grisette.Internal.Core.Data.Class.ModelOps +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Core.Data.Class.ModelOps + ( -- * Model and symbolic set operations + SymbolSetOps (..), + SymbolSetRep (..), + ModelOps (..), + ModelRep (..), + ) +where + +import Data.Kind (Type) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim + +-- | The operations on symbolic constant sets +-- +-- Note that symbolic constants with different types are considered different. +-- +-- >>> let aBool = "a" :: TypedSymbol Bool +-- >>> let bBool = "b" :: TypedSymbol Bool +-- >>> let cBool = "c" :: TypedSymbol Bool +-- >>> let aInteger = "a" :: TypedSymbol Integer +-- >>> emptySet :: SymbolSet +-- SymbolSet {} +-- >>> containsSymbol aBool (buildSymbolSet aBool :: SymbolSet) +-- True +-- >>> containsSymbol bBool (buildSymbolSet aBool :: SymbolSet) +-- False +-- >>> insertSymbol aBool (buildSymbolSet aBool :: SymbolSet) +-- SymbolSet {a :: Bool} +-- >>> insertSymbol aInteger (buildSymbolSet aBool :: SymbolSet) +-- SymbolSet {a :: Bool, a :: Integer} +-- >>> let abSet = buildSymbolSet (aBool, bBool) :: SymbolSet +-- >>> let acSet = buildSymbolSet (aBool, cBool) :: SymbolSet +-- >>> intersectionSet abSet acSet +-- SymbolSet {a :: Bool} +-- >>> unionSet abSet acSet +-- SymbolSet {a :: Bool, b :: Bool, c :: Bool} +-- >>> differenceSet abSet acSet +-- SymbolSet {b :: Bool} +class + (Monoid symbolSet) => + SymbolSetOps symbolSet (typedSymbol :: Type -> Type) + | symbolSet -> typedSymbol + where + -- | Construct an empty set + emptySet :: symbolSet + + -- | Check if the set is empty + isEmptySet :: symbolSet -> Bool + + -- | Check if the set contains the given symbol + containsSymbol :: forall a. typedSymbol a -> symbolSet -> Bool + + -- | Insert a symbol into the set + insertSymbol :: forall a. typedSymbol a -> symbolSet -> symbolSet + + -- | Set intersection + intersectionSet :: symbolSet -> symbolSet -> symbolSet + + -- | Set union + unionSet :: symbolSet -> symbolSet -> symbolSet + + -- | Set difference + differenceSet :: symbolSet -> symbolSet -> symbolSet + +-- | A type class for building a symbolic constant set manually from a symbolic +-- constant set representation +-- +-- >>> buildSymbolSet ("a" :: TypedSymbol Bool, "b" :: TypedSymbol Bool) :: SymbolSet +-- SymbolSet {a :: Bool, b :: Bool} +class + (SymbolSetOps symbolSet typedSymbol) => + SymbolSetRep rep symbolSet (typedSymbol :: Type -> Type) + where + -- | Build a symbolic constant set + buildSymbolSet :: rep -> symbolSet + +-- | The operations on Models. +-- +-- Note that symbolic constants with different types are considered different. +-- +-- >>> let aBool = "a" :: TypedSymbol Bool +-- >>> let bBool = "b" :: TypedSymbol Bool +-- >>> let cBool = "c" :: TypedSymbol Bool +-- >>> let aInteger = "a" :: TypedSymbol Integer +-- >>> emptyModel :: Model +-- Model {} +-- >>> valueOf aBool (buildModel (aBool ::= True) :: Model) +-- Just True +-- >>> valueOf bBool (buildModel (aBool ::= True) :: Model) +-- Nothing +-- >>> insertValue bBool False (buildModel (aBool ::= True) :: Model) +-- Model {a -> True :: Bool, b -> False :: Bool} +-- >>> let abModel = buildModel (aBool ::= True, bBool ::= False) :: Model +-- >>> let acSet = buildSymbolSet (aBool, cBool) :: SymbolSet +-- >>> exceptFor acSet abModel +-- Model {b -> False :: Bool} +-- >>> restrictTo acSet abModel +-- Model {a -> True :: Bool} +-- >>> extendTo acSet abModel +-- Model {a -> True :: Bool, b -> False :: Bool, c -> False :: Bool} +-- >>> exact acSet abModel +-- Model {a -> True :: Bool, c -> False :: Bool} +class + (SymbolSetOps symbolSet typedSymbol) => + ModelOps model symbolSet typedSymbol + | model -> symbolSet typedSymbol + where + -- | Construct an empty model + emptyModel :: model + + -- | Check if the model is empty + isEmptyModel :: model -> Bool + + -- | Check if the model contains the given symbol + modelContains :: typedSymbol a -> model -> Bool + + -- | Extract the assigned value for a given symbolic constant + valueOf :: typedSymbol t -> model -> Maybe t + + -- | Insert an assignment into the model + insertValue :: typedSymbol t -> t -> model -> model + + -- | Returns a model that removed all the assignments for the symbolic + -- constants in the set + exceptFor :: symbolSet -> model -> model + + -- | Returns a model that removed the assignments for the symbolic constants + exceptFor' :: typedSymbol t -> model -> model + + -- | Returns a model that only keeps the assignments for the symbolic + -- constants in the set + restrictTo :: symbolSet -> model -> model + + -- | Returns a model that extends the assignments for the symbolic constants + -- in the set by assigning default values to them + extendTo :: symbolSet -> model -> model + + -- | Returns a model that contains the assignments for exactly the symbolic + -- constants in the set by removing assignments for the symbolic constants that + -- are not in the set and add assignments for the missing symbolic constants + -- by assigning default values to them. + exact :: symbolSet -> model -> model + exact s = restrictTo s . extendTo s + +-- | A type class for building a model manually from a model representation +class ModelRep rep model | rep -> model where + -- | Build a model + -- + -- >>> let aBool = "a" :: TypedSymbol Bool + -- >>> let bBool = "b" :: TypedSymbol Bool + -- >>> buildModel (aBool ::= True, bBool ::= False) :: Model + -- Model {a -> True :: Bool, b -> False :: Bool} + buildModel :: rep -> model diff --git a/src/Grisette/Internal/Core/Data/Class/PlainUnion.hs b/src/Grisette/Internal/Core/Data/Class/PlainUnion.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Core/Data/Class/PlainUnion.hs @@ -0,0 +1,206 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- Module : Grisette.Internal.Core.Data.Class.PlainUnion +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Core.Data.Class.PlainUnion + ( PlainUnion (..), + pattern Single, + pattern If, + simpleMerge, + symIteMerge, + (.#), + onUnion, + onUnion2, + onUnion3, + onUnion4, + ) +where + +import Data.Bifunctor (Bifunctor (first)) +import Data.Kind (Type) +import Grisette.Internal.Core.Data.Class.Function (Function ((#))) +import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp (symIte)) +import Grisette.Internal.Core.Data.Class.LogicalOp + ( LogicalOp (symNot, (.&&)), + ) +import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) +import Grisette.Internal.Core.Data.Class.SimpleMergeable + ( SimpleMergeable, + UnionMergeable1, + mrgIf, + ) +import Grisette.Internal.Core.Data.Class.Solvable (Solvable (con)) +import Grisette.Internal.Core.Data.Class.TryMerge + ( mrgSingle, + tryMerge, + ) +import Grisette.Internal.SymPrim.SymBool (SymBool) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim + +-- | Plain union containers that can be projected back into single value or +-- if-guarded values. +class (Applicative u, UnionMergeable1 u) => PlainUnion (u :: Type -> Type) where + -- | Pattern match to extract single values. + -- + -- >>> singleView (return 1 :: UnionM Integer) + -- Just 1 + -- >>> singleView (mrgIfPropagatedStrategy "a" (return 1) (return 2) :: UnionM Integer) + -- Nothing + singleView :: u a -> Maybe a + + -- | Pattern match to extract if values. + -- + -- >>> ifView (return 1 :: UnionM Integer) + -- Nothing + -- >>> ifView (mrgIfPropagatedStrategy "a" (return 1) (return 2) :: UnionM Integer) + -- Just (a,<1>,<2>) + -- >>> ifView (mrgIf "a" (return 1) (return 2) :: UnionM Integer) + -- Just (a,{1},{2}) + ifView :: u a -> Maybe (SymBool, u a, u a) + + -- | Convert the union to a guarded list. + -- + -- >>> toGuardedList (mrgIf "a" (return 1) (mrgIf "b" (return 2) (return 3)) :: UnionM Integer) + -- [(a,1),((&& b (! a)),2),((! (|| b a)),3)] + toGuardedList :: u a -> [(SymBool, a)] + toGuardedList u = + case (singleView u, ifView u) of + (Just x, _) -> [(con True, x)] + (_, Just (c, l, r)) -> + fmap (first (.&& c)) (toGuardedList l) + ++ fmap (first (.&& symNot c)) (toGuardedList r) + _ -> error "Should not happen" + +-- | Pattern match to extract single values with 'singleView'. +-- +-- >>> case (return 1 :: UnionM Integer) of Single v -> v +-- 1 +pattern Single :: (PlainUnion u, Mergeable a) => a -> u a +pattern Single x <- + (singleView -> Just x) + where + Single x = mrgSingle x + +-- | Pattern match to extract guard values with 'ifView' +-- >>> case (mrgIfPropagatedStrategy "a" (return 1) (return 2) :: UnionM Integer) of If c t f -> (c,t,f) +-- (a,<1>,<2>) +pattern If :: (PlainUnion u, Mergeable a) => SymBool -> u a -> u a -> u a +pattern If c t f <- + (ifView -> Just (c, t, f)) + where + If c t f = mrgIf c t f + +-- | Merge the simply mergeable values in a union, and extract the merged value. +-- +-- In the following example, 'mrgIfPropagatedStrategy' will not merge the results, and +-- 'simpleMerge' will merge it and extract the single merged value. +-- +-- >>> mrgIfPropagatedStrategy (ssym "a") (return $ ssym "b") (return $ ssym "c") :: UnionM SymBool +-- +-- >>> simpleMerge $ (mrgIfPropagatedStrategy (ssym "a") (return $ ssym "b") (return $ ssym "c") :: UnionM SymBool) +-- (ite a b c) +simpleMerge :: forall u a. (SimpleMergeable a, PlainUnion u) => u a -> a +simpleMerge u = case tryMerge u of + Single x -> x + _ -> error "Should not happen" +{-# INLINE simpleMerge #-} + +-- | Merge the mergeable values in a union, using `symIte`, and extract the +-- merged value. +-- +-- The reason why we provide this class is that for some types, we only have +-- `ITEOp` (which may throw an error), and we don't have a `SimpleMergeable` +-- instance. In this case, we can use `symIteMerge` to merge the values. +symIteMerge :: (ITEOp a, Mergeable a, PlainUnion u) => u a -> a +symIteMerge (Single x) = x +symIteMerge (If cond l r) = symIte cond (symIteMerge l) (symIteMerge r) +symIteMerge _ = error "Should not happen" +{-# INLINE symIteMerge #-} + +-- | Helper for applying functions on 'UnionLike' and 'SimpleMergeable'. +-- +-- >>> let f :: Integer -> UnionM Integer = \x -> mrgIf (ssym "a") (mrgSingle $ x + 1) (mrgSingle $ x + 2) +-- >>> f .# (mrgIf (ssym "b" :: SymBool) (mrgSingle 0) (mrgSingle 2) :: UnionM Integer) +-- {If (&& b a) 1 (If b 2 (If a 3 4))} +(.#) :: + (Function f a r, SimpleMergeable r, PlainUnion u) => + f -> + u a -> + r +(.#) f u = simpleMerge $ fmap (f #) u +{-# INLINE (.#) #-} + +infixl 9 .# + +-- | Lift a function to work on union values. +-- +-- >>> sumU = onUnion sum +-- >>> sumU (mrgIfPropagatedStrategy "cond" (return ["a"]) (return ["b","c"]) :: UnionM [SymInteger]) +-- (ite cond a (+ b c)) +onUnion :: + forall u a r. + (SimpleMergeable r, UnionMergeable1 u, PlainUnion u, Mergeable a) => + (a -> r) -> + (u a -> r) +onUnion f = simpleMerge . fmap f . tryMerge + +-- | Lift a function to work on union values. +onUnion2 :: + forall u a b r. + ( SimpleMergeable r, + UnionMergeable1 u, + PlainUnion u, + Mergeable a, + Mergeable b + ) => + (a -> b -> r) -> + (u a -> u b -> r) +onUnion2 f ua ub = simpleMerge $ f <$> tryMerge ua <*> tryMerge ub + +-- | Lift a function to work on union values. +onUnion3 :: + forall u a b c r. + ( SimpleMergeable r, + UnionMergeable1 u, + PlainUnion u, + Mergeable a, + Mergeable b, + Mergeable c + ) => + (a -> b -> c -> r) -> + (u a -> u b -> u c -> r) +onUnion3 f ua ub uc = + simpleMerge $ f <$> tryMerge ua <*> tryMerge ub <*> tryMerge uc + +-- | Lift a function to work on union values. +onUnion4 :: + forall u a b c d r. + ( SimpleMergeable r, + UnionMergeable1 u, + PlainUnion u, + Mergeable a, + Mergeable b, + Mergeable c, + Mergeable d + ) => + (a -> b -> c -> d -> r) -> + (u a -> u b -> u c -> u d -> r) +onUnion4 f ua ub uc ud = + simpleMerge $ + f <$> tryMerge ua <*> tryMerge ub <*> tryMerge uc <*> tryMerge ud diff --git a/src/Grisette/Internal/Core/Data/Class/SEq.hs b/src/Grisette/Internal/Core/Data/Class/SEq.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Core/Data/Class/SEq.hs @@ -0,0 +1,284 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Core.Data.Class.Bool +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Core.Data.Class.SEq + ( -- * Symbolic equality + SEq (..), + SEq' (..), + ) +where + +import Control.Monad.Except (ExceptT (ExceptT)) +import Control.Monad.Identity + ( Identity (Identity), + IdentityT (IdentityT), + ) +import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import qualified Data.ByteString as B +import Data.Functor.Sum (Sum) +import Data.Int (Int16, Int32, Int64, Int8) +import qualified Data.Text as T +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.TypeNats (KnownNat, type (<=)) +import Generics.Deriving + ( Default (Default), + Generic (Rep, from), + K1 (K1), + M1 (M1), + U1, + V1, + type (:*:) ((:*:)), + type (:+:) (L1, R1), + ) +import Grisette.Internal.Core.Control.Exception (AssertionError, VerificationConditions) +import Grisette.Internal.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.&&))) +import Grisette.Internal.Core.Data.Class.Solvable (Solvable (con)) +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.Prim.Term (pevalEqTerm) +import Grisette.Internal.SymPrim.SymBV + ( SymIntN (SymIntN), + SymWordN (SymWordN), + ) +import Grisette.Internal.SymPrim.SymBool (SymBool (SymBool)) +import Grisette.Internal.SymPrim.SymInteger (SymInteger (SymInteger)) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim +-- >>> :set -XDataKinds +-- >>> :set -XBinaryLiterals +-- >>> :set -XFlexibleContexts +-- >>> :set -XFlexibleInstances +-- >>> :set -XFunctionalDependencies + +-- | Symbolic equality. Note that we can't use Haskell's 'Eq' class since +-- symbolic comparison won't necessarily return a concrete 'Bool' value. +-- +-- >>> let a = 1 :: SymInteger +-- >>> let b = 2 :: SymInteger +-- >>> a .== b +-- false +-- >>> a ./= b +-- true +-- +-- >>> let a = "a" :: SymInteger +-- >>> let b = "b" :: SymInteger +-- >>> a ./= b +-- (! (= a b)) +-- >>> a ./= b +-- (! (= a b)) +-- +-- __Note:__ This type class can be derived for algebraic data types. +-- You may need the @DerivingVia@ and @DerivingStrategies@ extensions. +-- +-- > data X = ... deriving Generic deriving SEq via (Default X) +class SEq a where + (.==) :: a -> a -> SymBool + a .== b = symNot $ a ./= b + {-# INLINE (.==) #-} + infix 4 .== + + (./=) :: a -> a -> SymBool + a ./= b = symNot $ a .== b + {-# INLINE (./=) #-} + infix 4 ./= + {-# MINIMAL (.==) | (./=) #-} + +-- SEq instances +#define CONCRETE_SEQ(type) \ +instance SEq type where \ + l .== r = con $ l == r; \ + {-# INLINE (.==) #-} + +#define CONCRETE_SEQ_BV(type) \ +instance (KnownNat n, 1 <= n) => SEq (type n) where \ + l .== r = con $ l == r; \ + {-# INLINE (.==) #-} + +#if 1 +CONCRETE_SEQ(Bool) +CONCRETE_SEQ(Integer) +CONCRETE_SEQ(Char) +CONCRETE_SEQ(Int) +CONCRETE_SEQ(Int8) +CONCRETE_SEQ(Int16) +CONCRETE_SEQ(Int32) +CONCRETE_SEQ(Int64) +CONCRETE_SEQ(Word) +CONCRETE_SEQ(Word8) +CONCRETE_SEQ(Word16) +CONCRETE_SEQ(Word32) +CONCRETE_SEQ(Word64) +CONCRETE_SEQ(B.ByteString) +CONCRETE_SEQ(T.Text) +CONCRETE_SEQ_BV(WordN) +CONCRETE_SEQ_BV(IntN) +#endif + +-- List +deriving via (Default [a]) instance (SEq a) => SEq [a] + +-- Maybe +deriving via (Default (Maybe a)) instance (SEq a) => SEq (Maybe a) + +-- Either +deriving via (Default (Either e a)) instance (SEq e, SEq a) => SEq (Either e a) + +-- ExceptT +instance (SEq (m (Either e a))) => SEq (ExceptT e m a) where + (ExceptT a) .== (ExceptT b) = a .== b + {-# INLINE (.==) #-} + +-- MaybeT +instance (SEq (m (Maybe a))) => SEq (MaybeT m a) where + (MaybeT a) .== (MaybeT b) = a .== b + {-# INLINE (.==) #-} + +-- () +instance SEq () where + _ .== _ = con True + {-# INLINE (.==) #-} + +-- (,) +deriving via (Default (a, b)) instance (SEq a, SEq b) => SEq (a, b) + +-- (,,) +deriving via (Default (a, b, c)) instance (SEq a, SEq b, SEq c) => SEq (a, b, c) + +-- (,,,) +deriving via + (Default (a, b, c, d)) + instance + (SEq a, SEq b, SEq c, SEq d) => + SEq (a, b, c, d) + +-- (,,,,) +deriving via + (Default (a, b, c, d, e)) + instance + (SEq a, SEq b, SEq c, SEq d, SEq e) => + SEq (a, b, c, d, e) + +-- (,,,,,) +deriving via + (Default (a, b, c, d, e, f)) + instance + (SEq a, SEq b, SEq c, SEq d, SEq e, SEq f) => + SEq (a, b, c, d, e, f) + +-- (,,,,,,) +deriving via + (Default (a, b, c, d, e, f, g)) + instance + (SEq a, SEq b, SEq c, SEq d, SEq e, SEq f, SEq g) => + SEq (a, b, c, d, e, f, g) + +-- (,,,,,,,) +deriving via + (Default (a, b, c, d, e, f, g, h)) + instance + (SEq a, SEq b, SEq c, SEq d, SEq e, SEq f, SEq g, SEq h) => + SEq (a, b, c, d, e, f, g, h) + +-- Sum +deriving via + (Default (Sum f g a)) + instance + (SEq (f a), SEq (g a)) => SEq (Sum f g a) + +-- Writer +instance (SEq (m (a, s))) => SEq (WriterLazy.WriterT s m a) where + (WriterLazy.WriterT l) .== (WriterLazy.WriterT r) = l .== r + {-# INLINE (.==) #-} + +instance (SEq (m (a, s))) => SEq (WriterStrict.WriterT s m a) where + (WriterStrict.WriterT l) .== (WriterStrict.WriterT r) = l .== r + {-# INLINE (.==) #-} + +-- Identity +instance (SEq a) => SEq (Identity a) where + (Identity l) .== (Identity r) = l .== r + {-# INLINE (.==) #-} + +-- IdentityT +instance (SEq (m a)) => SEq (IdentityT m a) where + (IdentityT l) .== (IdentityT r) = l .== r + {-# INLINE (.==) #-} + +-- Symbolic types +#define SEQ_SIMPLE(symtype) \ +instance SEq symtype where \ + (symtype l) .== (symtype r) = SymBool $ pevalEqTerm l r + +#define SEQ_BV(symtype) \ +instance (KnownNat n, 1 <= n) => SEq (symtype n) where \ + (symtype l) .== (symtype r) = SymBool $ pevalEqTerm l r + +#if 1 +SEQ_SIMPLE(SymBool) +SEQ_SIMPLE(SymInteger) +SEQ_BV(SymIntN) +SEQ_BV(SymWordN) +#endif + +-- Exceptions +deriving via (Default AssertionError) instance SEq AssertionError + +deriving via (Default VerificationConditions) instance SEq VerificationConditions + +-- | Auxiliary class for 'SEq' instance derivation +class SEq' f where + -- | Auxiliary function for '(..==) derivation + (..==) :: f a -> f a -> SymBool + + infix 4 ..== + +instance SEq' U1 where + _ ..== _ = con True + {-# INLINE (..==) #-} + +instance SEq' V1 where + _ ..== _ = con True + {-# INLINE (..==) #-} + +instance (SEq c) => SEq' (K1 i c) where + (K1 a) ..== (K1 b) = a .== b + {-# INLINE (..==) #-} + +instance (SEq' a) => SEq' (M1 i c a) where + (M1 a) ..== (M1 b) = a ..== b + {-# INLINE (..==) #-} + +instance (SEq' a, SEq' b) => SEq' (a :+: b) where + (L1 a) ..== (L1 b) = a ..== b + (R1 a) ..== (R1 b) = a ..== b + _ ..== _ = con False + {-# INLINE (..==) #-} + +instance (SEq' a, SEq' b) => SEq' (a :*: b) where + (a1 :*: b1) ..== (a2 :*: b2) = (a1 ..== a2) .&& (b1 ..== b2) + {-# INLINE (..==) #-} + +instance (Generic a, SEq' (Rep a)) => SEq (Default a) where + Default l .== Default r = from l ..== from r + {-# INLINE (.==) #-} diff --git a/src/Grisette/Internal/Core/Data/Class/SOrd.hs b/src/Grisette/Internal/Core/Data/Class/SOrd.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Core/Data/Class/SOrd.hs @@ -0,0 +1,516 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Core.Data.Class.SOrd +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Core.Data.Class.SOrd + ( -- * Symbolic total order relation + SOrd (..), + SOrd' (..), + symMax, + symMin, + mrgMax, + mrgMin, + ) +where + +import Control.Monad.Except (ExceptT (ExceptT)) +import Control.Monad.Identity + ( Identity (Identity), + IdentityT (IdentityT), + ) +import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import qualified Data.ByteString as B +import Data.Functor.Sum (Sum) +import Data.Int (Int16, Int32, Int64, Int8) +import qualified Data.Text as T +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.TypeLits (KnownNat, type (<=)) +import Generics.Deriving + ( Default (Default), + Generic (Rep, from), + K1 (K1), + M1 (M1), + U1, + V1, + type (:*:) ((:*:)), + type (:+:) (L1, R1), + ) +import Grisette.Internal.Core.Control.Exception (AssertionError, VerificationConditions) +import Grisette.Internal.Core.Control.Monad.UnionM (UnionM, liftToMonadUnion) +import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp, symIte) +import Grisette.Internal.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.&&), (.||))) +import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) +import Grisette.Internal.Core.Data.Class.PlainUnion + ( simpleMerge, + ) +import Grisette.Internal.Core.Data.Class.SEq (SEq ((./=), (.==)), SEq' ((..==))) +import Grisette.Internal.Core.Data.Class.SimpleMergeable + ( UnionMergeable1, + mrgIf, + ) +import Grisette.Internal.Core.Data.Class.Solvable (Solvable (con)) +import Grisette.Internal.Core.Data.Class.TryMerge + ( mrgSingle, + tryMerge, + ) +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.Prim.Term + ( PEvalOrdTerm + ( pevalLeOrdTerm, + pevalLtOrdTerm + ), + pevalGeOrdTerm, + pevalGtOrdTerm, + ) +import Grisette.Internal.SymPrim.SymBV + ( SymIntN (SymIntN), + SymWordN (SymWordN), + ) +import Grisette.Internal.SymPrim.SymBool (SymBool (SymBool)) +import Grisette.Internal.SymPrim.SymInteger (SymInteger (SymInteger)) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim +-- >>> :set -XDataKinds +-- >>> :set -XBinaryLiterals +-- >>> :set -XFlexibleContexts +-- >>> :set -XFlexibleInstances +-- >>> :set -XFunctionalDependencies + +-- | Symbolic total order. Note that we can't use Haskell's 'Ord' class since +-- symbolic comparison won't necessarily return a concrete 'Bool' or 'Ordering' +-- value. +-- +-- >>> let a = 1 :: SymInteger +-- >>> let b = 2 :: SymInteger +-- >>> a .< b +-- true +-- >>> a .> b +-- false +-- +-- >>> let a = "a" :: SymInteger +-- >>> let b = "b" :: SymInteger +-- >>> a .< b +-- (< a b) +-- >>> a .<= b +-- (<= a b) +-- >>> a .> b +-- (< b a) +-- >>> a .>= b +-- (<= b a) +-- +-- For `symCompare`, `Ordering` is not a solvable type, and the result would +-- be wrapped in a union-like monad. See `Grisette.Core.Control.Monad.UnionMBase` and `PlainUnion` for more +-- information. +-- +-- >>> a `symCompare` b :: UnionM Ordering -- UnionM is UnionMBase specialized with SymBool +-- {If (< a b) LT (If (= a b) EQ GT)} +-- +-- __Note:__ This type class can be derived for algebraic data types. +-- You may need the @DerivingVia@ and @DerivingStrategies@ extensions. +-- +-- > data X = ... deriving Generic deriving SOrd via (Default X) +class (SEq a) => SOrd a where + (.<) :: a -> a -> SymBool + infix 4 .< + (.<=) :: a -> a -> SymBool + infix 4 .<= + (.>) :: a -> a -> SymBool + infix 4 .> + (.>=) :: a -> a -> SymBool + infix 4 .>= + x .< y = x .<= y .&& x ./= y + x .> y = y .< x + x .>= y = y .<= x + symCompare :: a -> a -> UnionM Ordering + symCompare l r = + mrgIf + (l .< r) + (mrgSingle LT) + (mrgIf (l .== r) (mrgSingle EQ) (mrgSingle GT)) + {-# MINIMAL (.<=) #-} + +instance (SEq a, Generic a, SOrd' (Rep a)) => SOrd (Default a) where + (Default l) .<= (Default r) = l `derivedSymLe` r + (Default l) .< (Default r) = l `derivedSymLt` r + (Default l) .>= (Default r) = l `derivedSymGe` r + (Default l) .> (Default r) = l `derivedSymGt` r + symCompare (Default l) (Default r) = derivedSymCompare l r + +#define CONCRETE_SORD(type) \ +instance SOrd type where \ + l .<= r = con $ l <= r; \ + l .< r = con $ l < r; \ + l .>= r = con $ l >= r; \ + l .> r = con $ l > r; \ + symCompare l r = mrgSingle $ compare l r + +#define CONCRETE_SORD_BV(type) \ +instance (KnownNat n, 1 <= n) => SOrd (type n) where \ + l .<= r = con $ l <= r; \ + l .< r = con $ l < r; \ + l .>= r = con $ l >= r; \ + l .> r = con $ l > r; \ + symCompare l r = mrgSingle $ compare l r + +#if 1 +CONCRETE_SORD(Bool) +CONCRETE_SORD(Integer) +CONCRETE_SORD(Char) +CONCRETE_SORD(Int) +CONCRETE_SORD(Int8) +CONCRETE_SORD(Int16) +CONCRETE_SORD(Int32) +CONCRETE_SORD(Int64) +CONCRETE_SORD(Word) +CONCRETE_SORD(Word8) +CONCRETE_SORD(Word16) +CONCRETE_SORD(Word32) +CONCRETE_SORD(Word64) +CONCRETE_SORD(B.ByteString) +CONCRETE_SORD(T.Text) +CONCRETE_SORD_BV(WordN) +CONCRETE_SORD_BV(IntN) +#endif + +symCompareSingleList :: (SOrd a) => Bool -> Bool -> [a] -> [a] -> SymBool +symCompareSingleList isLess isStrict = go + where + go [] [] = con (not isStrict) + go (x : xs) (y : ys) = (if isLess then x .< y else x .> y) .|| (x .== y .&& go xs ys) + go [] _ = if isLess then con True else con False + go _ [] = if isLess then con False else con True + +symCompareList :: (SOrd a) => [a] -> [a] -> UnionM Ordering +symCompareList [] [] = mrgSingle EQ +symCompareList (x : xs) (y : ys) = do + oxy <- symCompare x y + case oxy of + LT -> mrgSingle LT + EQ -> symCompareList xs ys + GT -> mrgSingle GT +symCompareList [] _ = mrgSingle LT +symCompareList _ [] = mrgSingle GT + +instance (SOrd a) => SOrd [a] where + (.<=) = symCompareSingleList True False + (.<) = symCompareSingleList True True + (.>=) = symCompareSingleList False False + (.>) = symCompareSingleList False True + symCompare = symCompareList + +deriving via (Default (Maybe a)) instance (SOrd a) => SOrd (Maybe a) + +deriving via (Default (Either a b)) instance (SOrd a, SOrd b) => SOrd (Either a b) + +deriving via (Default ()) instance SOrd () + +deriving via (Default (a, b)) instance (SOrd a, SOrd b) => SOrd (a, b) + +deriving via (Default (a, b, c)) instance (SOrd a, SOrd b, SOrd c) => SOrd (a, b, c) + +deriving via + (Default (a, b, c, d)) + instance + (SOrd a, SOrd b, SOrd c, SOrd d) => + SOrd (a, b, c, d) + +deriving via + (Default (a, b, c, d, e)) + instance + (SOrd a, SOrd b, SOrd c, SOrd d, SOrd e) => + SOrd (a, b, c, d, e) + +deriving via + (Default (a, b, c, d, e, f)) + instance + (SOrd a, SOrd b, SOrd c, SOrd d, SOrd e, SOrd f) => + SOrd (a, b, c, d, e, f) + +deriving via + (Default (a, b, c, d, e, f, g)) + instance + (SOrd a, SOrd b, SOrd c, SOrd d, SOrd e, SOrd f, SOrd g) => + SOrd (a, b, c, d, e, f, g) + +deriving via + (Default (a, b, c, d, e, f, g, h)) + instance + ( SOrd a, + SOrd b, + SOrd c, + SOrd d, + SOrd e, + SOrd f, + SOrd g, + SOrd h + ) => + SOrd (a, b, c, d, e, f, g, h) + +deriving via + (Default (Sum f g a)) + instance + (SOrd (f a), SOrd (g a)) => SOrd (Sum f g a) + +instance (SOrd (m (Maybe a))) => SOrd (MaybeT m a) where + (MaybeT l) .<= (MaybeT r) = l .<= r + (MaybeT l) .< (MaybeT r) = l .< r + (MaybeT l) .>= (MaybeT r) = l .>= r + (MaybeT l) .> (MaybeT r) = l .> r + symCompare (MaybeT l) (MaybeT r) = symCompare l r + +instance (SOrd (m (Either e a))) => SOrd (ExceptT e m a) where + (ExceptT l) .<= (ExceptT r) = l .<= r + (ExceptT l) .< (ExceptT r) = l .< r + (ExceptT l) .>= (ExceptT r) = l .>= r + (ExceptT l) .> (ExceptT r) = l .> r + symCompare (ExceptT l) (ExceptT r) = symCompare l r + +instance (SOrd (m (a, s))) => SOrd (WriterLazy.WriterT s m a) where + (WriterLazy.WriterT l) .<= (WriterLazy.WriterT r) = l .<= r + (WriterLazy.WriterT l) .< (WriterLazy.WriterT r) = l .< r + (WriterLazy.WriterT l) .>= (WriterLazy.WriterT r) = l .>= r + (WriterLazy.WriterT l) .> (WriterLazy.WriterT r) = l .> r + symCompare (WriterLazy.WriterT l) (WriterLazy.WriterT r) = symCompare l r + +instance (SOrd (m (a, s))) => SOrd (WriterStrict.WriterT s m a) where + (WriterStrict.WriterT l) .<= (WriterStrict.WriterT r) = l .<= r + (WriterStrict.WriterT l) .< (WriterStrict.WriterT r) = l .< r + (WriterStrict.WriterT l) .>= (WriterStrict.WriterT r) = l .>= r + (WriterStrict.WriterT l) .> (WriterStrict.WriterT r) = l .> r + symCompare (WriterStrict.WriterT l) (WriterStrict.WriterT r) = symCompare l r + +instance (SOrd a) => SOrd (Identity a) where + (Identity l) .<= (Identity r) = l .<= r + (Identity l) .< (Identity r) = l .< r + (Identity l) .>= (Identity r) = l .>= r + (Identity l) .> (Identity r) = l .> r + (Identity l) `symCompare` (Identity r) = l `symCompare` r + +instance (SOrd (m a)) => SOrd (IdentityT m a) where + (IdentityT l) .<= (IdentityT r) = l .<= r + (IdentityT l) .< (IdentityT r) = l .< r + (IdentityT l) .>= (IdentityT r) = l .>= r + (IdentityT l) .> (IdentityT r) = l .> r + (IdentityT l) `symCompare` (IdentityT r) = l `symCompare` r + +-- SOrd +#define SORD_SIMPLE(symtype) \ +instance SOrd symtype where \ + (symtype a) .<= (symtype b) = SymBool $ pevalLeOrdTerm a b; \ + (symtype a) .< (symtype b) = SymBool $ pevalLtOrdTerm a b; \ + (symtype a) .>= (symtype b) = SymBool $ pevalGeOrdTerm a b; \ + (symtype a) .> (symtype b) = SymBool $ pevalGtOrdTerm a b; \ + a `symCompare` b = mrgIf \ + (a .< b) \ + (mrgSingle LT) \ + (mrgIf (a .== b) (mrgSingle EQ) (mrgSingle GT)) + +#define SORD_BV(symtype) \ +instance (KnownNat n, 1 <= n) => SOrd (symtype n) where \ + (symtype a) .<= (symtype b) = SymBool $ pevalLeOrdTerm a b; \ + (symtype a) .< (symtype b) = SymBool $ pevalLtOrdTerm a b; \ + (symtype a) .>= (symtype b) = SymBool $ pevalGeOrdTerm a b; \ + (symtype a) .> (symtype b) = SymBool $ pevalGtOrdTerm a b; \ + a `symCompare` b = mrgIf \ + (a .< b) \ + (mrgSingle LT) \ + (mrgIf (a .== b) (mrgSingle EQ) (mrgSingle GT)) + +instance SOrd SymBool where + l .<= r = symNot l .|| r + l .< r = symNot l .&& r + l .>= r = l .|| symNot r + l .> r = l .&& symNot r + symCompare l r = + mrgIf + (symNot l .&& r) + (mrgSingle LT) + (mrgIf (l .== r) (mrgSingle EQ) (mrgSingle GT)) + +#if 1 +SORD_SIMPLE(SymInteger) +SORD_BV(SymIntN) +SORD_BV(SymWordN) +#endif + +-- Exception +instance SOrd AssertionError where + _ .<= _ = con True + _ .< _ = con False + _ .>= _ = con True + _ .> _ = con False + _ `symCompare` _ = mrgSingle EQ + +instance SOrd VerificationConditions where + l .>= r = con $ l >= r + l .> r = con $ l > r + l .<= r = con $ l <= r + l .< r = con $ l < r + l `symCompare` r = mrgSingle $ l `compare` r + +-- UnionM +instance (SOrd a, Mergeable a) => SOrd (UnionM a) where + x .<= y = simpleMerge $ do + x1 <- tryMerge x + y1 <- tryMerge y + mrgSingle $ x1 .<= y1 + x .< y = simpleMerge $ do + x1 <- tryMerge x + y1 <- tryMerge y + mrgSingle $ x1 .< y1 + x .>= y = simpleMerge $ do + x1 <- tryMerge x + y1 <- tryMerge y + mrgSingle $ x1 .>= y1 + x .> y = simpleMerge $ do + x1 <- tryMerge x + y1 <- tryMerge y + mrgSingle $ x1 .> y1 + x `symCompare` y = liftToMonadUnion $ do + x1 <- tryMerge x + y1 <- tryMerge y + x1 `symCompare` y1 + +-- | Auxiliary class for 'SOrd' instance derivation +class (SEq' f) => SOrd' f where + -- | Auxiliary function for '(..<) derivation + (..<) :: f a -> f a -> SymBool + + infix 4 ..< + + -- | Auxiliary function for '(..<=) derivation + (..<=) :: f a -> f a -> SymBool + + infix 4 ..<= + + -- | Auxiliary function for '(..>) derivation + (..>) :: f a -> f a -> SymBool + + infix 4 ..> + + -- | Auxiliary function for '(..>=) derivation + (..>=) :: f a -> f a -> SymBool + + infix 4 ..>= + + -- | Auxiliary function for 'symCompare' derivation + symCompare' :: f a -> f a -> UnionM Ordering + +instance SOrd' U1 where + _ ..< _ = con False + _ ..<= _ = con True + _ ..> _ = con False + _ ..>= _ = con True + symCompare' _ _ = mrgSingle EQ + +instance SOrd' V1 where + _ ..< _ = con False + _ ..<= _ = con True + _ ..> _ = con False + _ ..>= _ = con True + symCompare' _ _ = mrgSingle EQ + +instance (SOrd c) => SOrd' (K1 i c) where + (K1 a) ..< (K1 b) = a .< b + (K1 a) ..<= (K1 b) = a .<= b + (K1 a) ..> (K1 b) = a .> b + (K1 a) ..>= (K1 b) = a .>= b + symCompare' (K1 a) (K1 b) = symCompare a b + +instance (SOrd' a) => SOrd' (M1 i c a) where + (M1 a) ..< (M1 b) = a ..< b + (M1 a) ..<= (M1 b) = a ..<= b + (M1 a) ..> (M1 b) = a ..> b + (M1 a) ..>= (M1 b) = a ..>= b + symCompare' (M1 a) (M1 b) = symCompare' a b + +instance (SOrd' a, SOrd' b) => SOrd' (a :+: b) where + (L1 _) ..< (R1 _) = con True + (L1 a) ..< (L1 b) = a ..< b + (R1 _) ..< (L1 _) = con False + (R1 a) ..< (R1 b) = a ..< b + (L1 _) ..<= (R1 _) = con True + (L1 a) ..<= (L1 b) = a ..<= b + (R1 _) ..<= (L1 _) = con False + (R1 a) ..<= (R1 b) = a ..<= b + + (L1 _) ..> (R1 _) = con False + (L1 a) ..> (L1 b) = a ..> b + (R1 _) ..> (L1 _) = con True + (R1 a) ..> (R1 b) = a ..> b + (L1 _) ..>= (R1 _) = con False + (L1 a) ..>= (L1 b) = a ..>= b + (R1 _) ..>= (L1 _) = con True + (R1 a) ..>= (R1 b) = a ..>= b + + symCompare' (L1 a) (L1 b) = symCompare' a b + symCompare' (L1 _) (R1 _) = mrgSingle LT + symCompare' (R1 a) (R1 b) = symCompare' a b + symCompare' (R1 _) (L1 _) = mrgSingle GT + +instance (SOrd' a, SOrd' b) => SOrd' (a :*: b) where + (a1 :*: b1) ..< (a2 :*: b2) = (a1 ..< a2) .|| ((a1 ..== a2) .&& (b1 ..< b2)) + (a1 :*: b1) ..<= (a2 :*: b2) = (a1 ..< a2) .|| ((a1 ..== a2) .&& (b1 ..<= b2)) + (a1 :*: b1) ..> (a2 :*: b2) = (a1 ..> a2) .|| ((a1 ..== a2) .&& (b1 ..> b2)) + (a1 :*: b1) ..>= (a2 :*: b2) = (a1 ..> a2) .|| ((a1 ..== a2) .&& (b1 ..>= b2)) + symCompare' (a1 :*: b1) (a2 :*: b2) = do + l <- symCompare' a1 a2 + case l of + EQ -> symCompare' b1 b2 + _ -> mrgSingle l + +derivedSymLt :: (Generic a, SOrd' (Rep a)) => a -> a -> SymBool +derivedSymLt x y = from x ..< from y + +derivedSymLe :: (Generic a, SOrd' (Rep a)) => a -> a -> SymBool +derivedSymLe x y = from x ..<= from y + +derivedSymGt :: (Generic a, SOrd' (Rep a)) => a -> a -> SymBool +derivedSymGt x y = from x ..> from y + +derivedSymGe :: (Generic a, SOrd' (Rep a)) => a -> a -> SymBool +derivedSymGe x y = from x ..>= from y + +derivedSymCompare :: (Generic a, SOrd' (Rep a)) => a -> a -> UnionM Ordering +derivedSymCompare x y = symCompare' (from x) (from y) + +symMax :: (SOrd a, ITEOp a) => a -> a -> a +symMax x y = symIte (x .>= y) x y + +symMin :: (SOrd a, ITEOp a) => a -> a -> a +symMin x y = symIte (x .>= y) y x + +mrgMax :: + (SOrd a, Mergeable a, UnionMergeable1 m, Applicative m) => + a -> + a -> + m a +mrgMax x y = mrgIf (x .>= y) (pure x) (pure y) + +mrgMin :: + (SOrd a, Mergeable a, UnionMergeable1 m, Applicative m) => + a -> + a -> + m a +mrgMin x y = mrgIf (x .>= y) (pure y) (pure x) diff --git a/src/Grisette/Internal/Core/Data/Class/SafeDivision.hs b/src/Grisette/Internal/Core/Data/Class/SafeDivision.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Core/Data/Class/SafeDivision.hs @@ -0,0 +1,290 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Core.Data.Class.SafeDivision +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Core.Data.Class.SafeDivision + ( ArithException (..), + SafeDivision (..), + ) +where + +import Control.Exception (ArithException (DivideByZero, Overflow, Underflow)) +import Control.Monad.Except (MonadError (throwError)) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.TypeNats (KnownNat, type (<=)) +import Grisette.Internal.Core.Control.Monad.Union (MonadUnion) +import Grisette.Internal.Core.Data.Class.LogicalOp (LogicalOp ((.&&))) +import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) +import Grisette.Internal.Core.Data.Class.SEq (SEq ((.==))) +import Grisette.Internal.Core.Data.Class.SimpleMergeable + ( mrgIf, + ) +import Grisette.Internal.Core.Data.Class.Solvable (Solvable (con)) +import Grisette.Internal.Core.Data.Class.TryMerge + ( TryMerge, + mrgSingle, + ) +import Grisette.Internal.SymPrim.BV + ( IntN, + WordN, + ) +import Grisette.Internal.SymPrim.Prim.Term + ( PEvalDivModIntegralTerm + ( pevalDivIntegralTerm, + pevalModIntegralTerm, + pevalQuotIntegralTerm, + pevalRemIntegralTerm + ), + ) +import Grisette.Internal.SymPrim.SymBV + ( SymIntN (SymIntN), + SymWordN (SymWordN), + ) +import Grisette.Internal.SymPrim.SymInteger (SymInteger (SymInteger)) +import Grisette.Lib.Control.Monad (mrgReturn) +import Grisette.Lib.Control.Monad.Except (mrgThrowError) +import Grisette.Lib.Data.Functor (mrgFmap) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim +-- >>> import Control.Monad.Except + +-- | Safe division with monadic error handling in multi-path +-- execution. These procedures throw an exception when the +-- divisor is zero. The result should be able to handle errors with +-- `MonadError`. +class (MonadError e m, TryMerge m, Mergeable a) => SafeDivision e a m where + -- | Safe signed 'div' with monadic error handling in multi-path execution. + -- + -- >>> safeDiv (ssym "a") (ssym "b") :: ExceptT ArithException UnionM SymInteger + -- ExceptT {If (= b 0) (Left divide by zero) (Right (div a b))} + safeDiv :: a -> a -> m a + safeDiv l r = mrgFmap fst $ safeDivMod l r + {-# INLINE safeDiv #-} + + -- | Safe signed 'mod' with monadic error handling in multi-path execution. + -- + -- >>> safeMod (ssym "a") (ssym "b") :: ExceptT ArithException UnionM SymInteger + -- ExceptT {If (= b 0) (Left divide by zero) (Right (mod a b))} + safeMod :: a -> a -> m a + safeMod l r = mrgFmap snd $ safeDivMod l r + {-# INLINE safeMod #-} + + -- | Safe signed 'divMod' with monadic error handling in multi-path execution. + -- + -- >>> safeDivMod (ssym "a") (ssym "b") :: ExceptT ArithException UnionM (SymInteger, SymInteger) + -- ExceptT {If (= b 0) (Left divide by zero) (Right ((div a b),(mod a b)))} + safeDivMod :: a -> a -> m (a, a) + safeDivMod l r = do + d <- safeDiv l r + m <- safeMod l r + mrgReturn (d, m) + {-# INLINE safeDivMod #-} + + -- | Safe signed 'quot' with monadic error handling in multi-path execution. + safeQuot :: a -> a -> m a + safeQuot l r = mrgFmap fst $ safeQuotRem l r + {-# INLINE safeQuot #-} + + -- | Safe signed 'rem' with monadic error handling in multi-path execution. + safeRem :: a -> a -> m a + safeRem l r = mrgFmap snd $ safeQuotRem l r + {-# INLINE safeRem #-} + + -- | Safe signed 'quotRem' with monadic error handling in multi-path execution. + safeQuotRem :: a -> a -> m (a, a) + safeQuotRem l r = do + q <- safeQuot l r + m <- safeRem l r + mrgReturn (q, m) + {-# INLINE safeQuotRem #-} + + {-# MINIMAL + ((safeDiv, safeMod) | safeDivMod), + ((safeQuot, safeRem) | safeQuotRem) + #-} + +concreteSafeDivisionHelper :: + (MonadError ArithException m, TryMerge m, Integral a, Mergeable r) => + (a -> a -> r) -> + a -> + a -> + m r +concreteSafeDivisionHelper f l r + | r == 0 = mrgThrowError DivideByZero + | otherwise = mrgReturn $ f l r + +concreteSignedBoundedSafeDivisionHelper :: + ( MonadError ArithException m, + TryMerge m, + Integral a, + Bounded a, + Mergeable r + ) => + (a -> a -> r) -> + a -> + a -> + m r +concreteSignedBoundedSafeDivisionHelper f l r + | r == 0 = mrgThrowError DivideByZero + | l == minBound && r == -1 = mrgThrowError Overflow + | otherwise = mrgReturn $ f l r + +#define QUOTE() ' +#define QID(a) a +#define QRIGHT(a) QID(a)' + +#define QRIGHTT(a) QID(a)' t' +#define QRIGHTU(a) QID(a)' _' + +#define SAFE_DIVISION_CONCRETE(type) \ +instance (MonadError ArithException m, TryMerge m) => \ + SafeDivision ArithException type m where \ + safeDiv = concreteSafeDivisionHelper div; \ + safeMod = concreteSafeDivisionHelper mod; \ + safeDivMod = concreteSafeDivisionHelper divMod; \ + safeQuot = concreteSafeDivisionHelper quot; \ + safeRem = concreteSafeDivisionHelper rem; \ + safeQuotRem = concreteSafeDivisionHelper quotRem + +#define SAFE_DIVISION_CONCRETE_SIGNED_BOUNDED(type) \ +instance (MonadError ArithException m, TryMerge m) => \ + SafeDivision ArithException type m where \ + safeDiv = concreteSignedBoundedSafeDivisionHelper div; \ + safeMod = concreteSafeDivisionHelper mod; \ + safeDivMod = concreteSignedBoundedSafeDivisionHelper divMod; \ + safeQuot = concreteSignedBoundedSafeDivisionHelper quot; \ + safeRem = concreteSafeDivisionHelper rem; \ + safeQuotRem = concreteSignedBoundedSafeDivisionHelper quotRem + +#define SAFE_DIVISION_CONCRETE_BV(type) \ +instance \ + (MonadError ArithException m, TryMerge m, KnownNat n, 1 <= n) => \ + SafeDivision ArithException (type n) m where \ + safeDiv = concreteSafeDivisionHelper div; \ + safeMod = concreteSafeDivisionHelper mod; \ + safeDivMod = concreteSafeDivisionHelper divMod; \ + safeQuot = concreteSafeDivisionHelper quot; \ + safeRem = concreteSafeDivisionHelper rem; \ + safeQuotRem = concreteSafeDivisionHelper quotRem + +#if 1 +SAFE_DIVISION_CONCRETE(Integer) +SAFE_DIVISION_CONCRETE_SIGNED_BOUNDED(Int8) +SAFE_DIVISION_CONCRETE_SIGNED_BOUNDED(Int16) +SAFE_DIVISION_CONCRETE_SIGNED_BOUNDED(Int32) +SAFE_DIVISION_CONCRETE_SIGNED_BOUNDED(Int64) +SAFE_DIVISION_CONCRETE_SIGNED_BOUNDED(Int) +SAFE_DIVISION_CONCRETE(Word8) +SAFE_DIVISION_CONCRETE(Word16) +SAFE_DIVISION_CONCRETE(Word32) +SAFE_DIVISION_CONCRETE(Word64) +SAFE_DIVISION_CONCRETE(Word) + +instance + (MonadError ArithException m, TryMerge m, KnownNat n, 1 <= n) => + SafeDivision ArithException (IntN n) m where + safeDiv = concreteSignedBoundedSafeDivisionHelper div + safeMod = concreteSafeDivisionHelper mod + safeDivMod = concreteSignedBoundedSafeDivisionHelper divMod + safeQuot = concreteSignedBoundedSafeDivisionHelper quot + safeRem = concreteSafeDivisionHelper rem + safeQuotRem = concreteSignedBoundedSafeDivisionHelper quotRem + +instance + (MonadError ArithException m, TryMerge m, KnownNat n, 1 <= n) => + SafeDivision ArithException (WordN n) m where + safeDiv = concreteSafeDivisionHelper div + safeMod = concreteSafeDivisionHelper mod + safeDivMod = concreteSafeDivisionHelper divMod + safeQuot = concreteSafeDivisionHelper quot + safeRem = concreteSafeDivisionHelper rem + safeQuotRem = concreteSafeDivisionHelper quotRem +#endif + +#define SAFE_DIVISION_SYMBOLIC_FUNC(name, type, op) \ +name (type l) rs@(type r) = \ + mrgIf \ + (rs .== con 0) \ + (throwError DivideByZero) \ + (mrgSingle $ type $ op l r); \ + +#define SAFE_DIVISION_SYMBOLIC_FUNC2(name, type, op1, op2) \ +name (type l) rs@(type r) = \ + mrgIf \ + (rs .== con 0) \ + (throwError DivideByZero) \ + (mrgSingle (type $ op1 l r, type $ op2 l r)); \ + +#if 1 +instance + (MonadUnion m, MonadError ArithException m) => + SafeDivision ArithException SymInteger m where + SAFE_DIVISION_SYMBOLIC_FUNC(safeDiv, SymInteger, pevalDivIntegralTerm) + SAFE_DIVISION_SYMBOLIC_FUNC(safeMod, SymInteger, pevalModIntegralTerm) + SAFE_DIVISION_SYMBOLIC_FUNC(safeQuot, SymInteger, pevalQuotIntegralTerm) + SAFE_DIVISION_SYMBOLIC_FUNC(safeRem, SymInteger, pevalRemIntegralTerm) + SAFE_DIVISION_SYMBOLIC_FUNC2(safeDivMod, SymInteger, pevalDivIntegralTerm, pevalModIntegralTerm) + SAFE_DIVISION_SYMBOLIC_FUNC2(safeQuotRem, SymInteger, pevalQuotIntegralTerm, pevalRemIntegralTerm) +#endif + +#define SAFE_DIVISION_SYMBOLIC_FUNC_BOUNDED_SIGNED(name, type, op) \ +name ls@(type l) rs@(type r) = \ + mrgIf \ + (rs .== con 0) \ + (throwError DivideByZero) \ + (mrgIf (rs .== con (-1) .&& ls .== con minBound) \ + (throwError Overflow) \ + (mrgSingle $ type $ op l r)); \ + +#define SAFE_DIVISION_SYMBOLIC_FUNC2_BOUNDED_SIGNED(name, type, op1, op2) \ +name ls@(type l) rs@(type r) = \ + mrgIf \ + (rs .== con 0) \ + (throwError DivideByZero) \ + (mrgIf (rs .== con (-1) .&& ls .== con minBound) \ + (throwError Overflow) \ + (mrgSingle (type $ op1 l r, type $ op2 l r))); \ + +#if 1 +instance + (MonadError ArithException m, MonadUnion m, KnownNat n, 1 <= n) => + SafeDivision ArithException (SymIntN n) m where + SAFE_DIVISION_SYMBOLIC_FUNC_BOUNDED_SIGNED(safeDiv, SymIntN, pevalDivIntegralTerm) + SAFE_DIVISION_SYMBOLIC_FUNC(safeMod, SymIntN, pevalModIntegralTerm) + SAFE_DIVISION_SYMBOLIC_FUNC_BOUNDED_SIGNED(safeQuot, SymIntN, pevalQuotIntegralTerm) + SAFE_DIVISION_SYMBOLIC_FUNC(safeRem, SymIntN, pevalRemIntegralTerm) + SAFE_DIVISION_SYMBOLIC_FUNC2_BOUNDED_SIGNED(safeDivMod, SymIntN, pevalDivIntegralTerm, pevalModIntegralTerm) + SAFE_DIVISION_SYMBOLIC_FUNC2_BOUNDED_SIGNED(safeQuotRem, SymIntN, pevalQuotIntegralTerm, pevalRemIntegralTerm) +#endif + +#if 1 +instance + (MonadError ArithException m, MonadUnion m, KnownNat n, 1 <= n) => + SafeDivision ArithException (SymWordN n) m where + SAFE_DIVISION_SYMBOLIC_FUNC(safeDiv, SymWordN, pevalDivIntegralTerm) + SAFE_DIVISION_SYMBOLIC_FUNC(safeMod, SymWordN, pevalModIntegralTerm) + SAFE_DIVISION_SYMBOLIC_FUNC(safeQuot, SymWordN, pevalQuotIntegralTerm) + SAFE_DIVISION_SYMBOLIC_FUNC(safeRem, SymWordN, pevalRemIntegralTerm) + SAFE_DIVISION_SYMBOLIC_FUNC2(safeDivMod, SymWordN, pevalDivIntegralTerm, pevalModIntegralTerm) + SAFE_DIVISION_SYMBOLIC_FUNC2(safeQuotRem, SymWordN, pevalQuotIntegralTerm, pevalRemIntegralTerm) +#endif diff --git a/src/Grisette/Internal/Core/Data/Class/SafeLinearArith.hs b/src/Grisette/Internal/Core/Data/Class/SafeLinearArith.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Core/Data/Class/SafeLinearArith.hs @@ -0,0 +1,226 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Core.Data.Class.SafeLinearArith +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Core.Data.Class.SafeLinearArith + ( ArithException (..), + SafeLinearArith (..), + ) +where + +import Control.Exception (ArithException (DivideByZero, Overflow, Underflow)) +import Control.Monad.Except (MonadError (throwError)) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.TypeNats (KnownNat, type (<=)) +import Grisette.Internal.Core.Control.Monad.Union (MonadUnion) +import Grisette.Internal.Core.Data.Class.LogicalOp + ( LogicalOp ((.&&), (.||)), + ) +import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) +import Grisette.Internal.Core.Data.Class.SEq (SEq ((./=), (.==))) +import Grisette.Internal.Core.Data.Class.SOrd (SOrd ((.<), (.>), (.>=))) +import Grisette.Internal.Core.Data.Class.SimpleMergeable + ( mrgIf, + ) +import Grisette.Internal.Core.Data.Class.Solvable (Solvable (con)) +import Grisette.Internal.Core.Data.Class.TryMerge + ( TryMerge, + mrgSingle, + ) +import Grisette.Internal.SymPrim.BV + ( IntN, + WordN, + ) +import Grisette.Internal.SymPrim.SymBV + ( SymIntN, + SymWordN, + ) +import Grisette.Internal.SymPrim.SymInteger (SymInteger) +import Grisette.Lib.Control.Monad (mrgReturn) +import Grisette.Lib.Control.Monad.Except (mrgThrowError) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim +-- >>> import Control.Monad.Except + +-- | Safe division with monadic error handling in multi-path +-- execution. These procedures throw an exception when overflow or underflow happens. +-- The result should be able to handle errors with `MonadError`. +class (MonadError e m, TryMerge m, Mergeable a) => SafeLinearArith e a m where + -- | Safe '+' with monadic error handling in multi-path execution. + -- Overflows or underflows are treated as errors. + -- + -- >>> safeAdd (ssym "a") (ssym "b") :: ExceptT ArithException UnionM SymInteger + -- ExceptT {Right (+ a b)} + -- >>> safeAdd (ssym "a") (ssym "b") :: ExceptT ArithException UnionM (SymIntN 4) + -- ExceptT {If (ite (< 0x0 a) (&& (< 0x0 b) (< (+ a b) 0x0)) (&& (< a 0x0) (&& (< b 0x0) (<= 0x0 (+ a b))))) (If (< 0x0 a) (Left arithmetic overflow) (Left arithmetic underflow)) (Right (+ a b))} + safeAdd :: a -> a -> m a + + -- | Safe 'negate' with monadic error handling in multi-path execution. + -- Overflows or underflows are treated as errors. + -- + -- >>> safeNeg (ssym "a") :: ExceptT ArithException UnionM SymInteger + -- ExceptT {Right (- a)} + -- >>> safeNeg (ssym "a") :: ExceptT ArithException UnionM (SymIntN 4) + -- ExceptT {If (= a 0x8) (Left arithmetic overflow) (Right (- a))} + safeNeg :: a -> m a + + -- | Safe '-' with monadic error handling in multi-path execution. + -- Overflows or underflows are treated as errors. + -- + -- >>> safeSub (ssym "a") (ssym "b") :: ExceptT ArithException UnionM SymInteger + -- ExceptT {Right (+ a (- b))} + -- >>> safeSub (ssym "a") (ssym "b") :: ExceptT ArithException UnionM (SymIntN 4) + -- ExceptT {If (ite (<= 0x0 a) (&& (< b 0x0) (< (+ a (- b)) 0x0)) (&& (< a 0x0) (&& (< 0x0 b) (< 0x0 (+ a (- b)))))) (If (<= 0x0 a) (Left arithmetic overflow) (Left arithmetic underflow)) (Right (+ a (- b)))} + safeSub :: a -> a -> m a + +instance + (MonadError ArithException m, TryMerge m) => + SafeLinearArith ArithException Integer m + where + safeAdd l r = mrgSingle (l + r) + safeNeg l = mrgSingle (-l) + safeSub l r = mrgSingle (l - r) + +#define SAFE_LINARITH_SIGNED_CONCRETE_BODY \ + safeAdd l r = let res = l + r in \ + if l > 0 && r > 0 && res < 0 \ + then mrgThrowError Overflow \ + else if l < 0 && r < 0 && res >= 0 \ + then mrgThrowError Underflow \ + else mrgReturn res;\ + safeSub l r = let res = l - r in \ + if l >= 0 && r < 0 && res < 0 \ + then mrgThrowError Overflow \ + else if l < 0 && r > 0 && res > 0 \ + then mrgThrowError Underflow \ + else mrgReturn res;\ + safeNeg v = if v == minBound then mrgThrowError Overflow else mrgReturn $ -v + +#define SAFE_LINARITH_SIGNED_CONCRETE(type) \ +instance \ + (MonadError ArithException m, TryMerge m) => \ + SafeLinearArith ArithException type m \ + where \ + SAFE_LINARITH_SIGNED_CONCRETE_BODY + +#define SAFE_LINARITH_SIGNED_BV_CONCRETE(type) \ +instance \ + (MonadError ArithException m, TryMerge m, KnownNat n, 1 <= n) => \ + SafeLinearArith ArithException (type n) m \ + where \ + SAFE_LINARITH_SIGNED_CONCRETE_BODY + +#define SAFE_LINARITH_UNSIGNED_CONCRETE_BODY \ + safeAdd l r = let res = l + r in \ + if l > res || r > res \ + then mrgThrowError Overflow \ + else mrgReturn res;\ + safeSub l r = \ + if r > l \ + then mrgThrowError Underflow \ + else mrgReturn $ l - r;\ + safeNeg v = if v /= 0 then mrgThrowError Underflow else mrgReturn $ -v + +#define SAFE_LINARITH_UNSIGNED_CONCRETE(type) \ +instance \ + (MonadError ArithException m, TryMerge m) => \ + SafeLinearArith ArithException type m \ + where \ + SAFE_LINARITH_UNSIGNED_CONCRETE_BODY + +#define SAFE_LINARITH_UNSIGNED_BV_CONCRETE(type) \ +instance \ + (MonadError ArithException m, TryMerge m, KnownNat n, 1 <= n) => \ + SafeLinearArith ArithException (type n) m \ + where \ + SAFE_LINARITH_UNSIGNED_CONCRETE_BODY + +#if 1 +SAFE_LINARITH_SIGNED_CONCRETE(Int8) +SAFE_LINARITH_SIGNED_CONCRETE(Int16) +SAFE_LINARITH_SIGNED_CONCRETE(Int32) +SAFE_LINARITH_SIGNED_CONCRETE(Int64) +SAFE_LINARITH_SIGNED_CONCRETE(Int) +SAFE_LINARITH_SIGNED_BV_CONCRETE(IntN) +SAFE_LINARITH_UNSIGNED_CONCRETE(Word8) +SAFE_LINARITH_UNSIGNED_CONCRETE(Word16) +SAFE_LINARITH_UNSIGNED_CONCRETE(Word32) +SAFE_LINARITH_UNSIGNED_CONCRETE(Word64) +SAFE_LINARITH_UNSIGNED_CONCRETE(Word) +SAFE_LINARITH_UNSIGNED_BV_CONCRETE(WordN) +#endif + +instance + (MonadError ArithException m, TryMerge m) => + SafeLinearArith ArithException SymInteger m + where + safeAdd ls rs = mrgSingle $ ls + rs + safeNeg v = mrgSingle $ -v + safeSub ls rs = mrgSingle $ ls - rs + +instance + (MonadError ArithException m, MonadUnion m, KnownNat n, 1 <= n) => + SafeLinearArith ArithException (SymIntN n) m + where + safeAdd ls rs = + mrgIf + (ls .> 0) + (mrgIf (rs .> 0 .&& res .< 0) (throwError Overflow) (return res)) + ( mrgIf + (ls .< 0 .&& rs .< 0 .&& res .>= 0) + (throwError Underflow) + (mrgSingle res) + ) + where + res = ls + rs + safeNeg v = mrgIf (v .== con minBound) (throwError Overflow) (mrgSingle $ -v) + safeSub ls rs = + mrgIf + (ls .>= 0) + (mrgIf (rs .< 0 .&& res .< 0) (throwError Overflow) (return res)) + ( mrgIf + (ls .< 0 .&& rs .> 0 .&& res .> 0) + (throwError Underflow) + (mrgSingle res) + ) + where + res = ls - rs + +instance + (MonadError ArithException m, MonadUnion m, KnownNat n, 1 <= n) => + SafeLinearArith ArithException (SymWordN n) m + where + safeAdd ls rs = + mrgIf + (ls .> res .|| rs .> res) + (throwError Overflow) + (mrgSingle res) + where + res = ls + rs + safeNeg v = mrgIf (v ./= 0) (throwError Underflow) (mrgSingle v) + safeSub ls rs = + mrgIf + (rs .> ls) + (throwError Underflow) + (mrgSingle res) + where + res = ls - rs diff --git a/src/Grisette/Internal/Core/Data/Class/SafeSymRotate.hs b/src/Grisette/Internal/Core/Data/Class/SafeSymRotate.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Core/Data/Class/SafeSymRotate.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Core.Data.Class.SafeSymRotate +-- Copyright : (c) Sirui Lu 2023-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Core.Data.Class.SafeSymRotate (SafeSymRotate (..)) where + +import Control.Exception (ArithException (Overflow)) +import Control.Monad.Error.Class (MonadError) +import Data.Bits (Bits (rotateL, rotateR), FiniteBits (finiteBitSize)) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.TypeLits (KnownNat, type (<=)) +import Grisette.Internal.Core.Control.Monad.Union (MonadUnion) +import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) +import Grisette.Internal.Core.Data.Class.SOrd (SOrd ((.<))) +import Grisette.Internal.Core.Data.Class.SimpleMergeable (mrgIf) +import Grisette.Internal.Core.Data.Class.TryMerge (TryMerge) +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.Prim.Term + ( PEvalRotateTerm + ( pevalRotateLeftTerm, + pevalRotateRightTerm + ), + ) +import Grisette.Internal.SymPrim.SymBV + ( SymIntN (SymIntN), + SymWordN (SymWordN), + ) +import Grisette.Lib.Control.Monad (mrgReturn) +import Grisette.Lib.Control.Monad.Except (mrgThrowError) + +-- | Safe rotation operations. The operators will reject negative shift amounts. +class (MonadError e m, TryMerge m, Mergeable a) => SafeSymRotate e a m where + safeSymRotateL :: a -> a -> m a + safeSymRotateR :: a -> a -> m a + +-- | This function handles the case when the shift amount is out the range of +-- `Int` correctly. +safeSymRotateLConcreteNum :: + ( MonadError ArithException m, + TryMerge m, + Integral a, + FiniteBits a, + Mergeable a + ) => + a -> + a -> + m a +safeSymRotateLConcreteNum _ s | s < 0 = mrgThrowError Overflow +safeSymRotateLConcreteNum a s = + mrgReturn $ rotateL a (fromIntegral $ s `rem` fromIntegral (finiteBitSize s)) + +-- | This function handles the case when the shift amount is out the range of +-- `Int` correctly. +safeSymRotateRConcreteNum :: + ( MonadError ArithException m, + TryMerge m, + Integral a, + FiniteBits a, + Mergeable a + ) => + a -> + a -> + m a +safeSymRotateRConcreteNum _ s | s < 0 = mrgThrowError Overflow +safeSymRotateRConcreteNum a s = + mrgReturn $ rotateR a (fromIntegral $ s `rem` fromIntegral (finiteBitSize s)) + +#define SAFE_SYM_ROTATE_CONCRETE(T) \ + instance (MonadError ArithException m, TryMerge m) => \ + SafeSymRotate ArithException T m where \ + safeSymRotateL = safeSymRotateLConcreteNum; \ + safeSymRotateR = safeSymRotateRConcreteNum \ + +#if 1 +SAFE_SYM_ROTATE_CONCRETE(Word8) +SAFE_SYM_ROTATE_CONCRETE(Word16) +SAFE_SYM_ROTATE_CONCRETE(Word32) +SAFE_SYM_ROTATE_CONCRETE(Word64) +SAFE_SYM_ROTATE_CONCRETE(Word) +SAFE_SYM_ROTATE_CONCRETE(Int8) +SAFE_SYM_ROTATE_CONCRETE(Int16) +SAFE_SYM_ROTATE_CONCRETE(Int32) +SAFE_SYM_ROTATE_CONCRETE(Int64) +SAFE_SYM_ROTATE_CONCRETE(Int) +#endif + +instance + (MonadError ArithException m, TryMerge m, KnownNat n, 1 <= n) => + SafeSymRotate ArithException (WordN n) m + where + safeSymRotateL = safeSymRotateLConcreteNum + safeSymRotateR = safeSymRotateRConcreteNum + +instance + (MonadError ArithException m, TryMerge m, KnownNat n, 1 <= n) => + SafeSymRotate ArithException (IntN n) m + where + safeSymRotateL = safeSymRotateLConcreteNum + safeSymRotateR = safeSymRotateRConcreteNum + +instance + (MonadError ArithException m, TryMerge m, KnownNat n, 1 <= n) => + SafeSymRotate ArithException (SymWordN n) m + where + safeSymRotateL (SymWordN ta) (SymWordN tr) = + mrgReturn $ SymWordN $ pevalRotateLeftTerm ta tr + safeSymRotateR (SymWordN ta) (SymWordN tr) = + mrgReturn $ SymWordN $ pevalRotateRightTerm ta tr + +instance + (MonadError ArithException m, MonadUnion m, KnownNat n, 1 <= n) => + SafeSymRotate ArithException (SymIntN n) m + where + safeSymRotateL (SymIntN ta) r@(SymIntN tr) = + mrgIf + (r .< 0) + (mrgThrowError Overflow) + (mrgReturn $ SymIntN $ pevalRotateLeftTerm ta tr) + safeSymRotateR (SymIntN ta) r@(SymIntN tr) = + mrgIf + (r .< 0) + (mrgThrowError Overflow) + (mrgReturn $ SymIntN $ pevalRotateRightTerm ta tr) diff --git a/src/Grisette/Internal/Core/Data/Class/SafeSymShift.hs b/src/Grisette/Internal/Core/Data/Class/SafeSymShift.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Core/Data/Class/SafeSymShift.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Grisette.Internal.Core.Data.Class.SafeSymShift + ( SafeSymShift (..), + ) +where + +import Control.Exception (ArithException (Overflow)) +import Control.Monad.Error.Class (MonadError) +import Data.Bits (Bits (shiftL, shiftR), FiniteBits (finiteBitSize)) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.TypeLits (KnownNat, type (<=)) +import Grisette.Internal.Core.Control.Monad.Union (MonadUnion) +import Grisette.Internal.Core.Data.Class.LogicalOp + ( LogicalOp ((.&&), (.||)), + ) +import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) +import Grisette.Internal.Core.Data.Class.SOrd + ( SOrd ((.<), (.>=)), + ) +import Grisette.Internal.Core.Data.Class.SimpleMergeable + ( mrgIf, + ) +import Grisette.Internal.Core.Data.Class.TryMerge (TryMerge) +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.Prim.Term + ( PEvalShiftTerm + ( pevalShiftLeftTerm, + pevalShiftRightTerm + ), + ) +import Grisette.Internal.SymPrim.SymBV (SymIntN (SymIntN), SymWordN (SymWordN)) +import Grisette.Lib.Control.Monad (mrgReturn) +import Grisette.Lib.Control.Monad.Except (mrgThrowError) + +-- | Safe version for `shiftL` or `shiftR`. +-- +-- The `safeSymShiftL` and `safeSymShiftR` are defined for all non-negative +-- shift amounts. +-- +-- * Shifting by negative shift amounts is an error. +-- * The result is defined to be 0 when shifting left by more than or equal to +-- the bit size of the number. +-- * The result is defined to be 0 when shifting right by more than or equal to +-- the bit size of the number and the number is unsigned or signed non-negative. +-- * The result is defined to be -1 when shifting right by more than or equal to +-- the bit size of the number and the number is signed negative. +-- +-- The `safeSymStrictShiftL` and `safeSymStrictShiftR` are defined for all +-- non-negative shift amounts that is less than the bit size. Shifting by more +-- than or equal to the bit size is an error, otherwise they are the same as the +-- non-strict versions. +class (MonadError e m, TryMerge m, Mergeable a) => SafeSymShift e a m where + safeSymShiftL :: a -> a -> m a + safeSymShiftR :: a -> a -> m a + safeSymStrictShiftL :: a -> a -> m a + safeSymStrictShiftR :: a -> a -> m a + +-- | This function handles the case when the shift amount is out the range of +-- `Int` correctly. +safeSymShiftLConcreteNum :: + (MonadError ArithException m, TryMerge m, Integral a, FiniteBits a, Mergeable a) => + Bool -> + a -> + a -> + m a +safeSymShiftLConcreteNum _ _ s | s < 0 = mrgThrowError Overflow +safeSymShiftLConcreteNum allowLargeShiftAmount a s + | (fromIntegral s :: Integer) >= fromIntegral (finiteBitSize a) = + if allowLargeShiftAmount then mrgReturn 0 else mrgThrowError Overflow +safeSymShiftLConcreteNum _ a s = mrgReturn $ shiftL a (fromIntegral s) + +-- | This function handles the case when the shift amount is out the range of +-- `Int` correctly. +safeSymShiftRConcreteNum :: + ( MonadError ArithException m, + TryMerge m, + Integral a, + FiniteBits a, + Mergeable a + ) => + Bool -> + a -> + a -> + m a +safeSymShiftRConcreteNum _ _ s | s < 0 = mrgThrowError Overflow +safeSymShiftRConcreteNum allowLargeShiftAmount a s + | (fromIntegral s :: Integer) >= fromIntegral (finiteBitSize a) = + if allowLargeShiftAmount then mrgReturn 0 else mrgThrowError Overflow +safeSymShiftRConcreteNum _ a s = mrgReturn $ shiftR a (fromIntegral s) + +#define SAFE_SYM_SHIFT_CONCRETE(T) \ + instance (MonadError ArithException m, TryMerge m) => \ + SafeSymShift ArithException T m where \ + safeSymShiftL = safeSymShiftLConcreteNum True; \ + safeSymShiftR = safeSymShiftRConcreteNum True; \ + safeSymStrictShiftL = safeSymShiftLConcreteNum False; \ + safeSymStrictShiftR = safeSymShiftRConcreteNum False + +#if 1 +SAFE_SYM_SHIFT_CONCRETE(Word8) +SAFE_SYM_SHIFT_CONCRETE(Word16) +SAFE_SYM_SHIFT_CONCRETE(Word32) +SAFE_SYM_SHIFT_CONCRETE(Word64) +SAFE_SYM_SHIFT_CONCRETE(Word) +SAFE_SYM_SHIFT_CONCRETE(Int8) +SAFE_SYM_SHIFT_CONCRETE(Int16) +SAFE_SYM_SHIFT_CONCRETE(Int32) +SAFE_SYM_SHIFT_CONCRETE(Int64) +SAFE_SYM_SHIFT_CONCRETE(Int) +#endif + +instance + (MonadError ArithException m, TryMerge m, KnownNat n, 1 <= n) => + SafeSymShift ArithException (WordN n) m + where + safeSymShiftL = safeSymShiftLConcreteNum True + safeSymShiftR = safeSymShiftRConcreteNum True + safeSymStrictShiftL = safeSymShiftLConcreteNum False + safeSymStrictShiftR = safeSymShiftRConcreteNum False + +instance + (MonadError ArithException m, TryMerge m, KnownNat n, 1 <= n) => + SafeSymShift ArithException (IntN n) m + where + safeSymShiftL = safeSymShiftLConcreteNum True + safeSymShiftR = safeSymShiftRConcreteNum True + safeSymStrictShiftL = safeSymShiftLConcreteNum False + safeSymStrictShiftR = safeSymShiftRConcreteNum False + +instance + (MonadError ArithException m, MonadUnion m, KnownNat n, 1 <= n) => + SafeSymShift ArithException (SymWordN n) m + where + safeSymShiftL (SymWordN a) (SymWordN s) = + return $ SymWordN $ pevalShiftLeftTerm a s + safeSymShiftR (SymWordN a) (SymWordN s) = + return $ SymWordN $ pevalShiftRightTerm a s + safeSymStrictShiftL a@(SymWordN ta) s@(SymWordN ts) = + mrgIf + (s .>= fromIntegral (finiteBitSize a)) + (mrgThrowError Overflow) + (return $ SymWordN $ pevalShiftLeftTerm ta ts) + safeSymStrictShiftR a@(SymWordN ta) s@(SymWordN ts) = + mrgIf + (s .>= fromIntegral (finiteBitSize a)) + (mrgThrowError Overflow) + (return $ SymWordN $ pevalShiftRightTerm ta ts) + +instance + (MonadError ArithException m, MonadUnion m, KnownNat n, 1 <= n) => + SafeSymShift ArithException (SymIntN n) m + where + safeSymShiftL (SymIntN a) ss@(SymIntN s) = + mrgIf + (ss .< 0) + (mrgThrowError Overflow) + (return $ SymIntN $ pevalShiftLeftTerm a s) + safeSymShiftR (SymIntN a) ss@(SymIntN s) = + mrgIf + (ss .< 0) + (mrgThrowError Overflow) + (return $ SymIntN $ pevalShiftRightTerm a s) + safeSymStrictShiftL a@(SymIntN ta) s@(SymIntN ts) = + mrgIf + (s .< 0 .|| (bs .>= 0 .&& s .>= bs)) + (mrgThrowError Overflow) + (return $ SymIntN $ pevalShiftLeftTerm ta ts) + where + bs = fromIntegral (finiteBitSize a) + safeSymStrictShiftR a@(SymIntN ta) s@(SymIntN ts) = + mrgIf + (s .< 0 .|| (bs .>= 0 .&& s .>= bs)) + (mrgThrowError Overflow) + (return $ SymIntN $ pevalShiftRightTerm ta ts) + where + bs = fromIntegral (finiteBitSize a) diff --git a/src/Grisette/Internal/Core/Data/Class/SignConversion.hs b/src/Grisette/Internal/Core/Data/Class/SignConversion.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Core/Data/Class/SignConversion.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE FunctionalDependencies #-} + +module Grisette.Internal.Core.Data.Class.SignConversion + ( SignConversion (..), + ) +where + +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Word (Word16, Word32, Word64, Word8) + +-- | Convert values between signed and unsigned. +class SignConversion ubv sbv | ubv -> sbv, sbv -> ubv where + -- | Convert unsigned value to the corresponding signed value. + toSigned :: ubv -> sbv + + -- | Convert signed value to the corresponding unsigned value. + toUnsigned :: sbv -> ubv + +instance SignConversion Word8 Int8 where + toSigned = fromIntegral + toUnsigned = fromIntegral + +instance SignConversion Word16 Int16 where + toSigned = fromIntegral + toUnsigned = fromIntegral + +instance SignConversion Word32 Int32 where + toSigned = fromIntegral + toUnsigned = fromIntegral + +instance SignConversion Word64 Int64 where + toSigned = fromIntegral + toUnsigned = fromIntegral + +instance SignConversion Word Int where + toSigned = fromIntegral + toUnsigned = fromIntegral diff --git a/src/Grisette/Internal/Core/Data/Class/SimpleMergeable.hs b/src/Grisette/Internal/Core/Data/Class/SimpleMergeable.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Core/Data/Class/SimpleMergeable.hs @@ -0,0 +1,631 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Core.Data.Class.SimpleMergeable +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Core.Data.Class.SimpleMergeable + ( -- * Simple mergeable types + SimpleMergeable (..), + SimpleMergeable1 (..), + mrgIte1, + SimpleMergeable2 (..), + mrgIte2, + UnionMergeable1 (..), + mrgIf, + mergeWithStrategy, + merge, + ) +where + +import Control.Monad.Except (ExceptT (ExceptT)) +import Control.Monad.Identity + ( Identity (Identity), + IdentityT (IdentityT), + ) +import qualified Control.Monad.RWS.Lazy as RWSLazy +import qualified Control.Monad.RWS.Strict as RWSStrict +import Control.Monad.Reader (ReaderT (ReaderT)) +import qualified Control.Monad.State.Lazy as StateLazy +import qualified Control.Monad.State.Strict as StateStrict +import Control.Monad.Trans.Cont (ContT (ContT)) +import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import Data.Kind (Type) +import GHC.Generics + ( Generic (Rep, from, to), + K1 (K1), + M1 (M1), + U1, + V1, + type (:*:) ((:*:)), + ) +import GHC.TypeNats (KnownNat, type (<=)) +import Generics.Deriving (Default (Default)) +import Grisette.Internal.Core.Control.Exception (AssertionError) +import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp (symIte)) +import Grisette.Internal.Core.Data.Class.Mergeable + ( Mergeable (rootStrategy), + Mergeable', + Mergeable1 (liftRootStrategy), + Mergeable2 (liftRootStrategy2), + Mergeable3 (liftRootStrategy3), + MergingStrategy (SimpleStrategy), + ) +import Grisette.Internal.Core.Data.Class.TryMerge (TryMerge (tryMergeWithStrategy)) +import Grisette.Internal.SymPrim.GeneralFun (type (-->)) +import Grisette.Internal.SymPrim.Prim.Term + ( LinkedRep, + SupportedPrim, + ) +import Grisette.Internal.SymPrim.SymBV + ( SymIntN, + SymWordN, + ) +import Grisette.Internal.SymPrim.SymBool (SymBool) +import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>)) +import Grisette.Internal.SymPrim.SymInteger (SymInteger) +import Grisette.Internal.SymPrim.SymTabularFun (type (=~>)) +import Grisette.Internal.SymPrim.TabularFun (type (=->)) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim +-- >>> import Control.Monad.Identity + +-- | Auxiliary class for the generic derivation for the 'SimpleMergeable' class. +class SimpleMergeable' f where + mrgIte' :: SymBool -> f a -> f a -> f a + +instance (SimpleMergeable' U1) where + mrgIte' _ t _ = t + {-# INLINE mrgIte' #-} + +instance (SimpleMergeable' V1) where + mrgIte' _ t _ = t + {-# INLINE mrgIte' #-} + +instance (SimpleMergeable c) => (SimpleMergeable' (K1 i c)) where + mrgIte' cond (K1 a) (K1 b) = K1 $ mrgIte cond a b + {-# INLINE mrgIte' #-} + +instance (SimpleMergeable' a) => (SimpleMergeable' (M1 i c a)) where + mrgIte' cond (M1 a) (M1 b) = M1 $ mrgIte' cond a b + {-# INLINE mrgIte' #-} + +instance (SimpleMergeable' a, SimpleMergeable' b) => (SimpleMergeable' (a :*: b)) where + mrgIte' cond (a1 :*: a2) (b1 :*: b2) = mrgIte' cond a1 b1 :*: mrgIte' cond a2 b2 + {-# INLINE mrgIte' #-} + +-- | This class indicates that a type has a simple root merge strategy. +-- +-- __Note:__ This type class can be derived for algebraic data types. +-- You may need the @DerivingVia@ and @DerivingStrategies@ extensions. +-- +-- > data X = ... +-- > deriving Generic +-- > deriving (Mergeable, SimpleMergeable) via (Default X) +class (Mergeable a) => SimpleMergeable a where + -- | Performs if-then-else with the simple root merge strategy. + -- + -- >>> mrgIte "a" "b" "c" :: SymInteger + -- (ite a b c) + mrgIte :: SymBool -> a -> a -> a + +instance (Generic a, Mergeable' (Rep a), SimpleMergeable' (Rep a)) => SimpleMergeable (Default a) where + mrgIte cond (Default a) (Default b) = Default $ to $ mrgIte' cond (from a) (from b) + {-# INLINE mrgIte #-} + +-- | Lifting of the 'SimpleMergeable' class to unary type constructors. +class (Mergeable1 u) => SimpleMergeable1 u where + -- | Lift 'mrgIte' through the type constructor. + -- + -- >>> liftMrgIte mrgIte "a" (Identity "b") (Identity "c") :: Identity SymInteger + -- Identity (ite a b c) + liftMrgIte :: (SymBool -> a -> a -> a) -> SymBool -> u a -> u a -> u a + +-- | Lift the standard 'mrgIte' function through the type constructor. +-- +-- >>> mrgIte1 "a" (Identity "b") (Identity "c") :: Identity SymInteger +-- Identity (ite a b c) +mrgIte1 :: (SimpleMergeable1 u, SimpleMergeable a) => SymBool -> u a -> u a -> u a +mrgIte1 = liftMrgIte mrgIte +{-# INLINE mrgIte1 #-} + +-- | Lifting of the 'SimpleMergeable' class to binary type constructors. +class (Mergeable2 u) => SimpleMergeable2 u where + -- | Lift 'mrgIte' through the type constructor. + -- + -- >>> liftMrgIte2 mrgIte mrgIte "a" ("b", "c") ("d", "e") :: (SymInteger, SymBool) + -- ((ite a b d),(ite a c e)) + liftMrgIte2 :: (SymBool -> a -> a -> a) -> (SymBool -> b -> b -> b) -> SymBool -> u a b -> u a b -> u a b + +-- | Lift the standard 'mrgIte' function through the type constructor. +-- +-- >>> mrgIte2 "a" ("b", "c") ("d", "e") :: (SymInteger, SymBool) +-- ((ite a b d),(ite a c e)) +mrgIte2 :: (SimpleMergeable2 u, SimpleMergeable a, SimpleMergeable b) => SymBool -> u a b -> u a b -> u a b +mrgIte2 = liftMrgIte2 mrgIte mrgIte +{-# INLINE mrgIte2 #-} + +-- | Special case of the 'Mergeable1' and 'SimpleMergeable1' class for type +-- constructors that are 'SimpleMergeable' when applied to any 'Mergeable' +-- types. +-- +-- This type class is used to generalize the 'mrgIf' function to other +-- containers, for example, monad transformer transformed Unions. +class (SimpleMergeable1 u, TryMerge u) => UnionMergeable1 (u :: Type -> Type) where + -- | Symbolic @if@ control flow with the result merged with some merge strategy. + -- + -- >>> mrgIfWithStrategy rootStrategy "a" (mrgSingle "b") (return "c") :: UnionM SymInteger + -- {(ite a b c)} + -- + -- __Note:__ Be careful to call this directly in your code. + -- The supplied merge strategy should be consistent with the type's root merge strategy, + -- or some internal invariants would be broken and the program can crash. + -- + -- This function is to be called when the 'Mergeable' constraint can not be resolved, + -- e.g., the merge strategy for the contained type is given with 'Mergeable1'. + -- In other cases, 'mrgIf' is usually a better alternative. + mrgIfWithStrategy :: MergingStrategy a -> SymBool -> u a -> u a -> u a + + mrgIfPropagatedStrategy :: SymBool -> u a -> u a -> u a + +mergeWithStrategy :: (UnionMergeable1 m) => MergingStrategy a -> m a -> m a +mergeWithStrategy = tryMergeWithStrategy +{-# INLINE mergeWithStrategy #-} + +-- | Try to merge the container with the root strategy. +merge :: (UnionMergeable1 m, Mergeable a) => m a -> m a +merge = mergeWithStrategy rootStrategy +{-# INLINE merge #-} + +-- | Symbolic @if@ control flow with the result merged with the type's root merge strategy. +-- +-- Equivalent to @'mrgIfWithStrategy' 'rootStrategy'@. +-- +-- >>> mrgIf "a" (return "b") (return "c") :: UnionM SymInteger +-- {(ite a b c)} +mrgIf :: (UnionMergeable1 u, Mergeable a) => SymBool -> u a -> u a -> u a +mrgIf = mrgIfWithStrategy rootStrategy +{-# INLINE mrgIf #-} + +instance SimpleMergeable () where + mrgIte _ t _ = t + {-# INLINE mrgIte #-} + +instance (SimpleMergeable a, SimpleMergeable b) => SimpleMergeable (a, b) where + mrgIte cond (a1, b1) (a2, b2) = (mrgIte cond a1 a2, mrgIte cond b1 b2) + {-# INLINE mrgIte #-} + +instance (SimpleMergeable a) => SimpleMergeable1 ((,) a) where + liftMrgIte mb cond (a1, b1) (a2, b2) = (mrgIte cond a1 a2, mb cond b1 b2) + {-# INLINE liftMrgIte #-} + +instance SimpleMergeable2 (,) where + liftMrgIte2 ma mb cond (a1, b1) (a2, b2) = (ma cond a1 a2, mb cond b1 b2) + {-# INLINE liftMrgIte2 #-} + +instance + (SimpleMergeable a, SimpleMergeable b, SimpleMergeable c) => + SimpleMergeable (a, b, c) + where + mrgIte cond (a1, b1, c1) (a2, b2, c2) = (mrgIte cond a1 a2, mrgIte cond b1 b2, mrgIte cond c1 c2) + {-# INLINE mrgIte #-} + +instance + ( SimpleMergeable a, + SimpleMergeable b, + SimpleMergeable c, + SimpleMergeable d + ) => + SimpleMergeable (a, b, c, d) + where + mrgIte cond (a1, b1, c1, d1) (a2, b2, c2, d2) = + (mrgIte cond a1 a2, mrgIte cond b1 b2, mrgIte cond c1 c2, mrgIte cond d1 d2) + {-# INLINE mrgIte #-} + +instance + ( SimpleMergeable a, + SimpleMergeable b, + SimpleMergeable c, + SimpleMergeable d, + SimpleMergeable e + ) => + SimpleMergeable (a, b, c, d, e) + where + mrgIte cond (a1, b1, c1, d1, e1) (a2, b2, c2, d2, e2) = + (mrgIte cond a1 a2, mrgIte cond b1 b2, mrgIte cond c1 c2, mrgIte cond d1 d2, mrgIte cond e1 e2) + {-# INLINE mrgIte #-} + +instance + ( SimpleMergeable a, + SimpleMergeable b, + SimpleMergeable c, + SimpleMergeable d, + SimpleMergeable e, + SimpleMergeable f + ) => + SimpleMergeable (a, b, c, d, e, f) + where + mrgIte cond (a1, b1, c1, d1, e1, f1) (a2, b2, c2, d2, e2, f2) = + (mrgIte cond a1 a2, mrgIte cond b1 b2, mrgIte cond c1 c2, mrgIte cond d1 d2, mrgIte cond e1 e2, mrgIte cond f1 f2) + {-# INLINE mrgIte #-} + +instance + ( SimpleMergeable a, + SimpleMergeable b, + SimpleMergeable c, + SimpleMergeable d, + SimpleMergeable e, + SimpleMergeable f, + SimpleMergeable g + ) => + SimpleMergeable (a, b, c, d, e, f, g) + where + mrgIte cond (a1, b1, c1, d1, e1, f1, g1) (a2, b2, c2, d2, e2, f2, g2) = + ( mrgIte cond a1 a2, + mrgIte cond b1 b2, + mrgIte cond c1 c2, + mrgIte cond d1 d2, + mrgIte cond e1 e2, + mrgIte cond f1 f2, + mrgIte cond g1 g2 + ) + {-# INLINE mrgIte #-} + +instance + ( SimpleMergeable a, + SimpleMergeable b, + SimpleMergeable c, + SimpleMergeable d, + SimpleMergeable e, + SimpleMergeable f, + SimpleMergeable g, + SimpleMergeable h + ) => + SimpleMergeable (a, b, c, d, e, f, g, h) + where + mrgIte cond (a1, b1, c1, d1, e1, f1, g1, h1) (a2, b2, c2, d2, e2, f2, g2, h2) = + ( mrgIte cond a1 a2, + mrgIte cond b1 b2, + mrgIte cond c1 c2, + mrgIte cond d1 d2, + mrgIte cond e1 e2, + mrgIte cond f1 f2, + mrgIte cond g1 g2, + mrgIte cond h1 h2 + ) + {-# INLINE mrgIte #-} + +instance (SimpleMergeable b) => SimpleMergeable (a -> b) where + mrgIte = mrgIte1 + {-# INLINE mrgIte #-} + +instance SimpleMergeable1 ((->) a) where + liftMrgIte ms cond t f v = ms cond (t v) (f v) + {-# INLINE liftMrgIte #-} + +instance (UnionMergeable1 m, Mergeable a) => SimpleMergeable (MaybeT m a) where + mrgIte = mrgIf + {-# INLINE mrgIte #-} + +instance (UnionMergeable1 m) => SimpleMergeable1 (MaybeT m) where + liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) + {-# INLINE liftMrgIte #-} + +instance (UnionMergeable1 m) => UnionMergeable1 (MaybeT m) where + mrgIfWithStrategy strategy cond (MaybeT l) (MaybeT r) = + MaybeT $ mrgIfWithStrategy (liftRootStrategy strategy) cond l r + {-# INLINE mrgIfWithStrategy #-} + mrgIfPropagatedStrategy cond (MaybeT l) (MaybeT r) = + MaybeT $ mrgIfPropagatedStrategy cond l r + {-# INLINE mrgIfPropagatedStrategy #-} + +instance + (UnionMergeable1 m, Mergeable e, Mergeable a) => + SimpleMergeable (ExceptT e m a) + where + mrgIte = mrgIf + {-# INLINE mrgIte #-} + +instance + (UnionMergeable1 m, Mergeable e) => + SimpleMergeable1 (ExceptT e m) + where + liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) + {-# INLINE liftMrgIte #-} + +instance + (UnionMergeable1 m, Mergeable e) => + UnionMergeable1 (ExceptT e m) + where + mrgIfWithStrategy s cond (ExceptT t) (ExceptT f) = + ExceptT $ mrgIfWithStrategy (liftRootStrategy s) cond t f + {-# INLINE mrgIfWithStrategy #-} + mrgIfPropagatedStrategy cond (ExceptT t) (ExceptT f) = + ExceptT $ mrgIfPropagatedStrategy cond t f + {-# INLINE mrgIfPropagatedStrategy #-} + +instance + (Mergeable s, Mergeable a, UnionMergeable1 m) => + SimpleMergeable (StateLazy.StateT s m a) + where + mrgIte = mrgIf + {-# INLINE mrgIte #-} + +instance + (Mergeable s, UnionMergeable1 m) => + SimpleMergeable1 (StateLazy.StateT s m) + where + liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) + {-# INLINE liftMrgIte #-} + +instance + (Mergeable s, UnionMergeable1 m) => + UnionMergeable1 (StateLazy.StateT s m) + where + mrgIfWithStrategy s cond (StateLazy.StateT t) (StateLazy.StateT f) = + StateLazy.StateT $ \v -> + mrgIfWithStrategy + (liftRootStrategy2 s rootStrategy) + cond + (t v) + (f v) + {-# INLINE mrgIfWithStrategy #-} + mrgIfPropagatedStrategy cond (StateLazy.StateT t) (StateLazy.StateT f) = + StateLazy.StateT $ \v -> mrgIfPropagatedStrategy cond (t v) (f v) + {-# INLINE mrgIfPropagatedStrategy #-} + +instance + (Mergeable s, Mergeable a, UnionMergeable1 m) => + SimpleMergeable (StateStrict.StateT s m a) + where + mrgIte = mrgIf + {-# INLINE mrgIte #-} + +instance + (Mergeable s, UnionMergeable1 m) => + SimpleMergeable1 (StateStrict.StateT s m) + where + liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) + {-# INLINE liftMrgIte #-} + +instance + (Mergeable s, UnionMergeable1 m) => + UnionMergeable1 (StateStrict.StateT s m) + where + mrgIfWithStrategy s cond (StateStrict.StateT t) (StateStrict.StateT f) = + StateStrict.StateT $ + \v -> + mrgIfWithStrategy (liftRootStrategy2 s rootStrategy) cond (t v) (f v) + {-# INLINE mrgIfWithStrategy #-} + mrgIfPropagatedStrategy cond (StateStrict.StateT t) (StateStrict.StateT f) = + StateStrict.StateT $ \v -> mrgIfPropagatedStrategy cond (t v) (f v) + {-# INLINE mrgIfPropagatedStrategy #-} + +instance + (Mergeable s, Mergeable a, UnionMergeable1 m, Monoid s) => + SimpleMergeable (WriterLazy.WriterT s m a) + where + mrgIte = mrgIf + {-# INLINE mrgIte #-} + +instance + (Mergeable s, UnionMergeable1 m, Monoid s) => + SimpleMergeable1 (WriterLazy.WriterT s m) + where + liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) + {-# INLINE liftMrgIte #-} + +instance + (Mergeable s, UnionMergeable1 m, Monoid s) => + UnionMergeable1 (WriterLazy.WriterT s m) + where + mrgIfWithStrategy s cond (WriterLazy.WriterT t) (WriterLazy.WriterT f) = + WriterLazy.WriterT $ + mrgIfWithStrategy (liftRootStrategy2 s rootStrategy) cond t f + {-# INLINE mrgIfWithStrategy #-} + mrgIfPropagatedStrategy cond (WriterLazy.WriterT t) (WriterLazy.WriterT f) = + WriterLazy.WriterT $ mrgIfPropagatedStrategy cond t f + {-# INLINE mrgIfPropagatedStrategy #-} + +instance + (Mergeable s, Mergeable a, UnionMergeable1 m, Monoid s) => + SimpleMergeable (WriterStrict.WriterT s m a) + where + mrgIte = mrgIf + {-# INLINE mrgIte #-} + +instance + (Mergeable s, UnionMergeable1 m, Monoid s) => + SimpleMergeable1 (WriterStrict.WriterT s m) + where + liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) + {-# INLINE liftMrgIte #-} + +instance + (Mergeable s, UnionMergeable1 m, Monoid s) => + UnionMergeable1 (WriterStrict.WriterT s m) + where + mrgIfWithStrategy s cond (WriterStrict.WriterT t) (WriterStrict.WriterT f) = + WriterStrict.WriterT $ + mrgIfWithStrategy (liftRootStrategy2 s rootStrategy) cond t f + {-# INLINE mrgIfWithStrategy #-} + mrgIfPropagatedStrategy cond (WriterStrict.WriterT t) (WriterStrict.WriterT f) = + WriterStrict.WriterT $ mrgIfPropagatedStrategy cond t f + {-# INLINE mrgIfPropagatedStrategy #-} + +instance + (Mergeable a, UnionMergeable1 m) => + SimpleMergeable (ReaderT s m a) + where + mrgIte = mrgIf + {-# INLINE mrgIte #-} + +instance + (UnionMergeable1 m) => + SimpleMergeable1 (ReaderT s m) + where + liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) + {-# INLINE liftMrgIte #-} + +instance + (UnionMergeable1 m) => + UnionMergeable1 (ReaderT s m) + where + mrgIfWithStrategy s cond (ReaderT t) (ReaderT f) = + ReaderT $ \v -> mrgIfWithStrategy s cond (t v) (f v) + {-# INLINE mrgIfWithStrategy #-} + mrgIfPropagatedStrategy cond (ReaderT t) (ReaderT f) = + ReaderT $ \v -> mrgIfPropagatedStrategy cond (t v) (f v) + {-# INLINE mrgIfPropagatedStrategy #-} + +instance (SimpleMergeable a) => SimpleMergeable (Identity a) where + mrgIte = mrgIte1 + {-# INLINE mrgIte #-} + +instance SimpleMergeable1 Identity where + liftMrgIte mite cond (Identity l) (Identity r) = Identity $ mite cond l r + {-# INLINE liftMrgIte #-} + +instance + (UnionMergeable1 m, Mergeable a) => + SimpleMergeable (IdentityT m a) + where + mrgIte = mrgIf + {-# INLINE mrgIte #-} + +instance (UnionMergeable1 m) => SimpleMergeable1 (IdentityT m) where + liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) + {-# INLINE liftMrgIte #-} + +instance (UnionMergeable1 m) => UnionMergeable1 (IdentityT m) where + mrgIfWithStrategy s cond (IdentityT l) (IdentityT r) = + IdentityT $ mrgIfWithStrategy s cond l r + {-# INLINE mrgIfWithStrategy #-} + mrgIfPropagatedStrategy cond (IdentityT l) (IdentityT r) = + IdentityT $ mrgIfPropagatedStrategy cond l r + {-# INLINE mrgIfPropagatedStrategy #-} + +instance (UnionMergeable1 m, Mergeable r) => SimpleMergeable (ContT r m a) where + mrgIte cond (ContT l) (ContT r) = ContT $ \c -> mrgIf cond (l c) (r c) + {-# INLINE mrgIte #-} + +instance (UnionMergeable1 m, Mergeable r) => SimpleMergeable1 (ContT r m) where + liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) + {-# INLINE liftMrgIte #-} + +instance (UnionMergeable1 m, Mergeable r) => UnionMergeable1 (ContT r m) where + mrgIfWithStrategy _ cond (ContT l) (ContT r) = + ContT $ \c -> mrgIf cond (l c) (r c) + {-# INLINE mrgIfWithStrategy #-} + mrgIfPropagatedStrategy cond (ContT l) (ContT r) = + ContT $ \c -> mrgIfPropagatedStrategy cond (l c) (r c) + {-# INLINE mrgIfPropagatedStrategy #-} + +instance + (Mergeable s, Mergeable w, Monoid w, Mergeable a, UnionMergeable1 m) => + SimpleMergeable (RWSLazy.RWST r w s m a) + where + mrgIte = mrgIf + {-# INLINE mrgIte #-} + +instance + (Mergeable s, Mergeable w, Monoid w, UnionMergeable1 m) => + SimpleMergeable1 (RWSLazy.RWST r w s m) + where + liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) + {-# INLINE liftMrgIte #-} + +instance + (Mergeable s, Mergeable w, Monoid w, UnionMergeable1 m) => + UnionMergeable1 (RWSLazy.RWST r w s m) + where + mrgIfWithStrategy ms cond (RWSLazy.RWST t) (RWSLazy.RWST f) = + RWSLazy.RWST $ \r s -> + mrgIfWithStrategy + (liftRootStrategy3 ms rootStrategy rootStrategy) + cond + (t r s) + (f r s) + {-# INLINE mrgIfWithStrategy #-} + mrgIfPropagatedStrategy cond (RWSLazy.RWST t) (RWSLazy.RWST f) = + RWSLazy.RWST $ \r s -> mrgIfPropagatedStrategy cond (t r s) (f r s) + {-# INLINE mrgIfPropagatedStrategy #-} + +instance + (Mergeable s, Mergeable w, Monoid w, Mergeable a, UnionMergeable1 m) => + SimpleMergeable (RWSStrict.RWST r w s m a) + where + mrgIte = mrgIf + {-# INLINE mrgIte #-} + +instance + (Mergeable s, Mergeable w, Monoid w, UnionMergeable1 m) => + SimpleMergeable1 (RWSStrict.RWST r w s m) + where + liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) + {-# INLINE liftMrgIte #-} + +instance + (Mergeable s, Mergeable w, Monoid w, UnionMergeable1 m) => + UnionMergeable1 (RWSStrict.RWST r w s m) + where + mrgIfWithStrategy ms cond (RWSStrict.RWST t) (RWSStrict.RWST f) = + RWSStrict.RWST $ \r s -> + mrgIfWithStrategy + (liftRootStrategy3 ms rootStrategy rootStrategy) + cond + (t r s) + (f r s) + {-# INLINE mrgIfWithStrategy #-} + mrgIfPropagatedStrategy cond (RWSStrict.RWST t) (RWSStrict.RWST f) = + RWSStrict.RWST $ \r s -> mrgIfPropagatedStrategy cond (t r s) (f r s) + {-# INLINE mrgIfPropagatedStrategy #-} + +#define SIMPLE_MERGEABLE_SIMPLE(symtype) \ +instance SimpleMergeable symtype where \ + mrgIte = symIte; \ + {-# INLINE mrgIte #-} + +#define SIMPLE_MERGEABLE_BV(symtype) \ +instance (KnownNat n, 1 <= n) => SimpleMergeable (symtype n) where \ + mrgIte = symIte; \ + {-# INLINE mrgIte #-} + +#define SIMPLE_MERGEABLE_FUN(cop, op) \ +instance (SupportedPrim (cop ca cb), LinkedRep ca sa, LinkedRep cb sb) => \ + SimpleMergeable (op sa sb) where \ + mrgIte = symIte; \ + {-# INLINE mrgIte #-} + +#if 1 +SIMPLE_MERGEABLE_SIMPLE(SymBool) +SIMPLE_MERGEABLE_SIMPLE(SymInteger) +SIMPLE_MERGEABLE_BV(SymIntN) +SIMPLE_MERGEABLE_BV(SymWordN) +SIMPLE_MERGEABLE_FUN((=->), (=~>)) +SIMPLE_MERGEABLE_FUN((-->), (-~>)) +#endif + +-- Exception +deriving via (Default AssertionError) instance SimpleMergeable AssertionError diff --git a/src/Grisette/Internal/Core/Data/Class/Solvable.hs b/src/Grisette/Internal/Core/Data/Class/Solvable.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Core/Data/Class/Solvable.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Unused LANGUAGE pragma" #-} + +-- | +-- Module : Grisette.Internal.Core.Data.Class.Solvable +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Core.Data.Class.Solvable + ( -- * Solvable type interface + Solvable (..), + pattern Con, + slocsym, + ilocsym, + ) +where + +import Data.String (IsString) +import Grisette.Internal.Core.Data.Symbol + ( Identifier, + Symbol (IndexedSymbol, SimpleSymbol), + withLoc, + ) +import Language.Haskell.TH.Syntax.Compat (SpliceQ) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim +-- >>> :set -XOverloadedStrings +-- >>> :set -XTemplateHaskell + +-- | The class defines the creation and pattern matching of solvable type +-- values. +class (IsString t) => Solvable c t | t -> c where + -- | Wrap a concrete value in a symbolic value. + -- + -- >>> con True :: SymBool + -- true + con :: c -> t + + -- | Extract the concrete value from a symbolic value. + -- + -- >>> conView (con True :: SymBool) + -- Just True + -- + -- >>> conView (ssym "a" :: SymBool) + -- Nothing + conView :: t -> Maybe c + + -- | Generate symbolic constants. + -- + -- Two symbolic constants with the same symbol are the same symbolic constant, + -- and will always be assigned with the same value by the solver. + -- + -- >>> sym "a" :: SymBool + -- a + -- >>> (sym "a" :: SymBool) == sym "a" + -- True + -- >>> (sym "a" :: SymBool) == sym "b" + -- False + -- >>> (sym "a" :: SymBool) .&& sym "a" + -- a + -- >>> (sym "a" :: SymBool) == isym "a" 1 + -- False + sym :: Symbol -> t + + -- | Generate simply-named symbolic constants. + -- + -- Two symbolic constants with the same identifier are the same symbolic + -- constant, and will always be assigned with the same value by the solver. + -- + -- >>> ssym "a" :: SymBool + -- a + -- >>> (ssym "a" :: SymBool) == ssym "a" + -- True + -- >>> (ssym "a" :: SymBool) == ssym "b" + -- False + -- >>> (ssym "a" :: SymBool) .&& ssym "a" + -- a + ssym :: Identifier -> t + ssym = sym . SimpleSymbol + + -- | Generate indexed symbolic constants. + -- + -- Two symbolic constants with the same identifier but different indices are + -- not the same symbolic constants. + -- + -- >>> isym "a" 1 :: SymBool + -- a@1 + isym :: Identifier -> Int -> t + isym nm idx = sym $ IndexedSymbol nm idx + +-- | Extract the concrete value from a solvable value with 'conView'. +-- +-- >>> case con True :: SymBool of Con v -> v +-- True +pattern Con :: (Solvable c t) => c -> t +pattern Con c <- + (conView -> Just c) + where + Con c = con c + +-- | Generate simply-named symbolic variables. The file location will be +-- attached to the identifier. +-- +-- >>> $$(slocsym "a") :: SymBool +-- a::... +-- +-- Calling 'slocsym' with the same name at different location will always +-- generate different symbolic constants. Calling 'slocsym' at the same +-- location for multiple times will generate the same symbolic constants. +-- +-- >>> ($$(slocsym "a") :: SymBool) == $$(slocsym "a") +-- False +-- >>> let f _ = $$(slocsym "a") :: SymBool +-- >>> f () == f () +-- True +slocsym :: (Solvable c s) => Identifier -> SpliceQ s +slocsym nm = [||ssym $$(withLoc nm)||] + +-- | Generate indexed symbolic variables. The file location will be attached to +-- identifier. +-- +-- >>> $$(ilocsym "a" 1) :: SymBool +-- a::...@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||] diff --git a/src/Grisette/Internal/Core/Data/Class/Solver.hs b/src/Grisette/Internal/Core/Data/Class/Solver.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Core/Data/Class/Solver.hs @@ -0,0 +1,288 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Core.Data.Class.Solver +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Core.Data.Class.Solver + ( -- * Note for the examples + + -- + + -- | The examples assumes that the [z3](https://github.com/Z3Prover/z3) + -- solver is available in @PATH@. + + -- * Solver interfaces + SolvingFailure (..), + MonadicSolver (..), + SolverCommand (..), + ConfigurableSolver (..), + Solver (..), + withSolver, + solve, + solveMulti, + + -- * Union with exceptions + UnionWithExcept (..), + solveExcept, + solveMultiExcept, + ) +where + +import Control.DeepSeq (NFData) +import Control.Exception (SomeException, bracket) +import Control.Monad.Except (ExceptT, runExceptT) +import qualified Data.HashSet as S +import Data.Hashable (Hashable) +import Data.Maybe (fromJust) +import GHC.Generics (Generic) +import Grisette.Internal.Core.Data.Class.ExtractSymbolics + ( ExtractSymbolics (extractSymbolics), + ) +import Grisette.Internal.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.||))) +import Grisette.Internal.Core.Data.Class.PlainUnion + ( PlainUnion, + simpleMerge, + ) +import Grisette.Internal.Core.Data.Class.Solvable (Solvable (con)) +import Grisette.Internal.SymPrim.Prim.Model + ( Model, + SymbolSet (unSymbolSet), + equation, + ) +import Grisette.Internal.SymPrim.Prim.Term + ( SomeTypedSymbol (SomeTypedSymbol), + ) +import Grisette.Internal.SymPrim.SymBool (SymBool (SymBool)) +import Language.Haskell.TH.Syntax (Lift) + +data SolveInternal = SolveInternal + deriving (Eq, Show, Ord, Generic, Hashable, Lift, NFData) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim +-- >>> import Grisette.Backend +-- >>> :set -XOverloadedStrings + +-- | The current failures that can be returned by the solver. +data SolvingFailure + = -- | Unsatisfiable: No model is available. + Unsat + | -- | Unknown: The solver cannot determine whether the formula is + -- satisfiable. + Unk + | -- | The solver has reached the maximum number of models to return. + ResultNumLimitReached + | -- | The solver has encountered an error. + SolvingError SomeException + | -- | The solver has been terminated. + Terminated + deriving (Show) + +-- | A monadic solver interface. +-- +-- This interface abstract the monadic interface of a solver. All the operations +-- performed in the monad are using a single solver instance. The solver +-- instance is management by the monad's @run@ function. +class MonadicSolver m where + monadicSolverPush :: Int -> m () + monadicSolverPop :: Int -> m () + monadicSolverSolve :: SymBool -> m (Either SolvingFailure Model) + +-- | The commands that can be sent to a solver. +data SolverCommand + = SolverSolve SymBool + | SolverPush Int + | SolverPop Int + | SolverTerminate + +-- | A class that abstracts the solver interface. +class Solver handle where + -- | Run a solver command. + solverRunCommand :: + (handle -> IO (Either SolvingFailure a)) -> + handle -> + SolverCommand -> + IO (Either SolvingFailure a) + + -- | Solve a formula. + solverSolve :: handle -> SymBool -> IO (Either SolvingFailure Model) + + -- | Push @n@ levels. + solverPush :: handle -> Int -> IO (Either SolvingFailure ()) + solverPush handle n = + solverRunCommand (const $ return $ Right ()) handle $ SolverPush n + + -- | Pop @n@ levels. + solverPop :: handle -> Int -> IO (Either SolvingFailure ()) + solverPop handle n = + solverRunCommand (const $ return $ Right ()) handle $ SolverPop n + + -- | Terminate the solver, wait until the last command is finished. + solverTerminate :: handle -> IO () + + -- | Force terminate the solver, do not wait for the last command to finish. + solverForceTerminate :: handle -> IO () + +-- | A class that abstracts the creation of a solver instance based on a +-- configuration. +-- +-- The solver instance will need to be terminated by the user, with the solver +-- interface. +class + (Solver handle) => + ConfigurableSolver config handle + | config -> handle + where + newSolver :: config -> IO handle + +-- | Start a solver, run a computation with the solver, and terminate the +-- solver after the computation finishes. +withSolver :: + (ConfigurableSolver config handle) => + config -> + (handle -> IO a) -> + IO a +withSolver config = bracket (newSolver config) solverTerminate + +-- | Solve a single formula. Find an assignment to it to make it true. +-- +-- >>> solve (precise z3) ("a" .&& ("b" :: SymInteger) .== 1) +-- Right (Model {a -> True :: Bool, b -> 1 :: Integer}) +-- >>> solve (precise z3) ("a" .&& symNot "a") +-- Left Unsat +solve :: + (ConfigurableSolver config handle) => + -- | solver configuration + config -> + -- | formula to solve, the solver will try to make it true + SymBool -> + IO (Either SolvingFailure Model) +solve config formula = withSolver config (`solverSolve` formula) + +-- | Solve a single formula while returning multiple models to make it true. +-- The maximum number of desired models are given. +-- +-- > >>> solveMulti (precise z3) 4 ("a" .|| "b") +-- > [Model {a -> True :: Bool, b -> False :: Bool},Model {a -> False :: Bool, b -> True :: Bool},Model {a -> True :: Bool, b -> True :: Bool}] +solveMulti :: + (ConfigurableSolver config handle) => + -- | solver configuration + config -> + -- | maximum number of models to return + Int -> + -- | formula to solve, the solver will try to make it true + SymBool -> + IO ([Model], SolvingFailure) +solveMulti config numOfModelRequested formula = + withSolver config $ \solver -> do + firstModel <- solverSolve solver formula + case firstModel of + Left err -> return ([], err) + Right model -> do + (models, err) <- go solver model numOfModelRequested + return (model : models, err) + where + allSymbols = extractSymbolics formula :: SymbolSet + go solver prevModel n + | n <= 1 = return ([], ResultNumLimitReached) + | otherwise = do + let newFormula = + S.foldl' + ( \acc (SomeTypedSymbol _ v) -> + acc + .|| (symNot (SymBool $ fromJust $ equation v prevModel)) + ) + (con False) + (unSymbolSet allSymbols) + res <- solverSolve solver newFormula + case res of + Left err -> return ([], err) + Right model -> do + (models, err) <- go solver model (n - 1) + return (model : models, err) + +-- | A class that abstracts the union-like structures that contains exceptions. +class UnionWithExcept t u e v | t -> u e v where + -- | Extract a union of exceptions and values from the structure. + extractUnionExcept :: t -> u (Either e v) + +instance UnionWithExcept (ExceptT e u v) u e v where + extractUnionExcept = runExceptT + +-- | +-- Solver procedure for programs with error handling. +-- +-- >>> :set -XLambdaCase +-- >>> import Control.Monad.Except +-- >>> let x = "x" :: SymInteger +-- >>> :{ +-- res :: ExceptT AssertionError UnionM () +-- res = do +-- symAssert $ x .> 0 -- constrain that x is positive +-- symAssert $ x .< 2 -- constrain that x is less than 2 +-- :} +-- +-- >>> :{ +-- translate (Left _) = con False -- errors are not desirable +-- translate _ = con True -- non-errors are desirable +-- :} +-- +-- >>> solveExcept (precise z3) translate res +-- Right (Model {x -> 1 :: Integer}) +solveExcept :: + ( UnionWithExcept t u e v, + PlainUnion u, + Functor u, + ConfigurableSolver config handle + ) => + -- | solver configuration + config -> + -- | mapping the results to symbolic boolean formulas, the solver would try to + -- find a model to make the formula true + (Either e v -> SymBool) -> + -- | the program to be solved, should be a union of exception and values + t -> + IO (Either SolvingFailure Model) +solveExcept config f v = solve config (simpleMerge $ f <$> extractUnionExcept v) + +-- | +-- Solver procedure for programs with error handling. Would return multiple +-- models if possible. +solveMultiExcept :: + ( UnionWithExcept t u e v, + PlainUnion u, + Functor u, + ConfigurableSolver config handle + ) => + -- | solver configuration + config -> + -- | maximum number of models to return + Int -> + -- | mapping the results to symbolic boolean formulas, the solver would try to + -- find a model to make the formula true + (Either e v -> SymBool) -> + -- | the program to be solved, should be a union of exception and values + t -> + IO ([Model], SolvingFailure) +solveMultiExcept config n f v = + solveMulti config n (simpleMerge $ f <$> extractUnionExcept v) diff --git a/src/Grisette/Internal/Core/Data/Class/SubstituteSym.hs b/src/Grisette/Internal/Core/Data/Class/SubstituteSym.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Core/Data/Class/SubstituteSym.hs @@ -0,0 +1,314 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Core.Data.Class.SubstituteSym +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Core.Data.Class.SubstituteSym + ( -- * Substituting symbolic constants + SubstituteSym (..), + SubstituteSym' (..), + ) +where + +import Control.Monad.Except (ExceptT (ExceptT)) +import Control.Monad.Identity + ( Identity (Identity), + IdentityT (IdentityT), + ) +import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import qualified Data.ByteString as B +import Data.Functor.Sum (Sum) +import Data.Int (Int16, Int32, Int64, Int8) +import qualified Data.Text as T +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.TypeNats (KnownNat, type (<=)) +import Generics.Deriving + ( Default (Default, unDefault), + Generic (Rep, from, to), + K1 (K1), + M1 (M1), + U1, + V1, + type (:*:) ((:*:)), + type (:+:) (L1, R1), + ) +import Generics.Deriving.Instances () +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.GeneralFun (substTerm, type (-->)) +import Grisette.Internal.SymPrim.Prim.Term + ( LinkedRep (underlyingTerm), + SupportedPrim, + TypedSymbol, + ) +import Grisette.Internal.SymPrim.SymBV + ( SymIntN (SymIntN), + SymWordN (SymWordN), + ) +import Grisette.Internal.SymPrim.SymBool (SymBool (SymBool)) +import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>) (SymGeneralFun)) +import Grisette.Internal.SymPrim.SymInteger (SymInteger (SymInteger)) +import Grisette.Internal.SymPrim.SymTabularFun (type (=~>) (SymTabularFun)) +import Grisette.Internal.SymPrim.TabularFun (type (=->)) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim + +-- | Substitution of symbolic constants. +-- +-- >>> a = "a" :: TypedSymbol Bool +-- >>> v = "x" .&& "y" :: SymBool +-- >>> substituteSym a v (["a" .&& "b", "a"] :: [SymBool]) +-- [(&& (&& x y) b),(&& x y)] +-- +-- __Note 1:__ This type class can be derived for algebraic data types. +-- You may need the @DerivingVia@ and @DerivingStrategies@ extensions. +-- +-- > data X = ... deriving Generic deriving SubstituteSym via (Default X) +class SubstituteSym a where + -- Substitute a symbolic constant to some symbolic value + -- + -- >>> substituteSym "a" ("c" .&& "d" :: Sym Bool) ["a" .&& "b" :: Sym Bool, "a"] + -- [(&& (&& c d) b),(&& c d)] + substituteSym :: (LinkedRep cb sb) => TypedSymbol cb -> sb -> a -> a + +#define CONCRETE_SUBSTITUTESYM(type) \ +instance SubstituteSym type where \ + substituteSym _ _ = id + +#define CONCRETE_SUBSTITUTESYM_BV(type) \ +instance (KnownNat n, 1 <= n) => SubstituteSym (type n) where \ + substituteSym _ _ = id + +#if 1 +CONCRETE_SUBSTITUTESYM(Bool) +CONCRETE_SUBSTITUTESYM(Integer) +CONCRETE_SUBSTITUTESYM(Char) +CONCRETE_SUBSTITUTESYM(Int) +CONCRETE_SUBSTITUTESYM(Int8) +CONCRETE_SUBSTITUTESYM(Int16) +CONCRETE_SUBSTITUTESYM(Int32) +CONCRETE_SUBSTITUTESYM(Int64) +CONCRETE_SUBSTITUTESYM(Word) +CONCRETE_SUBSTITUTESYM(Word8) +CONCRETE_SUBSTITUTESYM(Word16) +CONCRETE_SUBSTITUTESYM(Word32) +CONCRETE_SUBSTITUTESYM(Word64) +CONCRETE_SUBSTITUTESYM(B.ByteString) +CONCRETE_SUBSTITUTESYM(T.Text) +CONCRETE_SUBSTITUTESYM_BV(WordN) +CONCRETE_SUBSTITUTESYM_BV(IntN) +#endif + +instance SubstituteSym () where + substituteSym _ _ = id + +-- Either +deriving via + (Default (Either a b)) + instance + ( SubstituteSym a, + SubstituteSym b + ) => + SubstituteSym (Either a b) + +-- Maybe +deriving via (Default (Maybe a)) instance (SubstituteSym a) => SubstituteSym (Maybe a) + +-- List +deriving via (Default [a]) instance (SubstituteSym a) => SubstituteSym [a] + +-- (,) +deriving via + (Default (a, b)) + instance + (SubstituteSym a, SubstituteSym b) => + SubstituteSym (a, b) + +-- (,,) +deriving via + (Default (a, b, c)) + instance + ( SubstituteSym a, + SubstituteSym b, + SubstituteSym c + ) => + SubstituteSym (a, b, c) + +-- (,,,) +deriving via + (Default (a, b, c, d)) + instance + ( SubstituteSym a, + SubstituteSym b, + SubstituteSym c, + SubstituteSym d + ) => + SubstituteSym (a, b, c, d) + +-- (,,,,) +deriving via + (Default (a, b, c, d, e)) + instance + ( SubstituteSym a, + SubstituteSym b, + SubstituteSym c, + SubstituteSym d, + SubstituteSym e + ) => + SubstituteSym (a, b, c, d, e) + +-- (,,,,,) +deriving via + (Default (a, b, c, d, e, f)) + instance + ( SubstituteSym a, + SubstituteSym b, + SubstituteSym c, + SubstituteSym d, + SubstituteSym e, + SubstituteSym f + ) => + SubstituteSym (a, b, c, d, e, f) + +-- (,,,,,,) +deriving via + (Default (a, b, c, d, e, f, g)) + instance + ( SubstituteSym a, + SubstituteSym b, + SubstituteSym c, + SubstituteSym d, + SubstituteSym e, + SubstituteSym f, + SubstituteSym g + ) => + SubstituteSym (a, b, c, d, e, f, g) + +-- (,,,,,,,) +deriving via + (Default (a, b, c, d, e, f, g, h)) + instance + ( SubstituteSym a, + SubstituteSym b, + SubstituteSym c, + SubstituteSym d, + SubstituteSym e, + SubstituteSym f, + SubstituteSym g, + SubstituteSym h + ) => + SubstituteSym ((,,,,,,,) a b c d e f g h) + +-- MaybeT +instance + (SubstituteSym (m (Maybe a))) => + SubstituteSym (MaybeT m a) + where + substituteSym sym val (MaybeT v) = MaybeT $ substituteSym sym val v + +-- ExceptT +instance + (SubstituteSym (m (Either e a))) => + SubstituteSym (ExceptT e m a) + where + substituteSym sym val (ExceptT v) = ExceptT $ substituteSym sym val v + +-- Sum +deriving via + (Default (Sum f g a)) + instance + (SubstituteSym (f a), SubstituteSym (g a)) => + SubstituteSym (Sum f g a) + +-- WriterT +instance + (SubstituteSym (m (a, s))) => + SubstituteSym (WriterLazy.WriterT s m a) + where + substituteSym sym val (WriterLazy.WriterT v) = WriterLazy.WriterT $ substituteSym sym val v + +instance + (SubstituteSym (m (a, s))) => + SubstituteSym (WriterStrict.WriterT s m a) + where + substituteSym sym val (WriterStrict.WriterT v) = WriterStrict.WriterT $ substituteSym sym val v + +-- Identity +instance (SubstituteSym a) => SubstituteSym (Identity a) where + substituteSym sym val (Identity a) = Identity $ substituteSym sym val a + +-- IdentityT +instance (SubstituteSym (m a)) => SubstituteSym (IdentityT m a) where + substituteSym sym val (IdentityT a) = IdentityT $ substituteSym sym val a + +#define SUBSTITUTE_SYM_SIMPLE(symtype) \ +instance SubstituteSym symtype where \ + substituteSym sym v (symtype t) = symtype $ substTerm sym (underlyingTerm v) t + +#define SUBSTITUTE_SYM_BV(symtype) \ +instance (KnownNat n, 1 <= n) => SubstituteSym (symtype n) where \ + substituteSym sym v (symtype t) = symtype $ substTerm sym (underlyingTerm v) t + +#define SUBSTITUTE_SYM_FUN(cop, op, cons) \ +instance (SupportedPrim (cop ca cb), LinkedRep ca sa, LinkedRep cb sb) => \ + SubstituteSym (op sa sb) where \ + substituteSym sym v (cons t) = cons $ substTerm sym (underlyingTerm v) t + +#if 1 +SUBSTITUTE_SYM_SIMPLE(SymBool) +SUBSTITUTE_SYM_SIMPLE(SymInteger) +SUBSTITUTE_SYM_BV(SymIntN) +SUBSTITUTE_SYM_BV(SymWordN) +SUBSTITUTE_SYM_FUN((=->), (=~>), SymTabularFun) +SUBSTITUTE_SYM_FUN((-->), (-~>), SymGeneralFun) +#endif + +-- | Auxiliary class for 'SubstituteSym' instance derivation +class SubstituteSym' a where + -- | Auxiliary function for 'substituteSym' derivation + substituteSym' :: (LinkedRep cb sb) => TypedSymbol cb -> sb -> a c -> a c + +instance + ( Generic a, + SubstituteSym' (Rep a) + ) => + SubstituteSym (Default a) + where + substituteSym sym val = Default . to . substituteSym' sym val . from . unDefault + +instance SubstituteSym' U1 where + substituteSym' _ _ = id + +instance SubstituteSym' V1 where + substituteSym' _ _ = id + +instance (SubstituteSym c) => SubstituteSym' (K1 i c) where + substituteSym' sym val (K1 v) = K1 $ substituteSym sym val v + +instance (SubstituteSym' a) => SubstituteSym' (M1 i c a) where + substituteSym' sym val (M1 v) = M1 $ substituteSym' sym val v + +instance (SubstituteSym' a, SubstituteSym' b) => SubstituteSym' (a :+: b) where + substituteSym' sym val (L1 l) = L1 $ substituteSym' sym val l + substituteSym' sym val (R1 r) = R1 $ substituteSym' sym val r + +instance (SubstituteSym' a, SubstituteSym' b) => SubstituteSym' (a :*: b) where + substituteSym' sym val (a :*: b) = substituteSym' sym val a :*: substituteSym' sym val b diff --git a/src/Grisette/Internal/Core/Data/Class/SymRotate.hs b/src/Grisette/Internal/Core/Data/Class/SymRotate.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Core/Data/Class/SymRotate.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} + +module Grisette.Internal.Core.Data.Class.SymRotate + ( SymRotate (..), + DefaultFiniteBitsSymRotate (..), + ) +where + +import Data.Bits (Bits (isSigned, rotate), FiniteBits (finiteBitSize)) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Word (Word16, Word32, Word64, Word8) + +-- | The `symRotate` is similar to `rotate`, but accepts the type itself instead +-- of `Int` for the rotate amount. The function works on all inputs, including +-- the rotate amounts that are beyond the bit width of the value. +-- +-- The `symRotateNegated` function rotates to the opposite direction of +-- `symRotate`. This function is introduced to handle the asymmetry of the range +-- of values. +class (Bits a) => SymRotate a where + symRotate :: a -> a -> a + symRotateNegated :: a -> a -> a + +instance SymRotate Int where + symRotate = rotate + symRotateNegated a s + | s /= minBound = rotate a (-s) + | otherwise = rotate a (-(s + finiteBitSize s)) + +newtype DefaultFiniteBitsSymRotate a = DefaultFiniteBitsSymRotate + { unDefaultFiniteBitsSymRotate :: a + } + deriving newtype (Eq, Bits) + +instance + (Integral a, FiniteBits a) => + SymRotate (DefaultFiniteBitsSymRotate a) + where + symRotate (DefaultFiniteBitsSymRotate a) (DefaultFiniteBitsSymRotate s) + | isSigned a = DefaultFiniteBitsSymRotate $ symRotateSigned a s + | otherwise = DefaultFiniteBitsSymRotate $ symRotateUnsigned a s + where + symRotateUnsigned :: a -> a -> a + symRotateUnsigned a s = + rotate a (fromIntegral (s `mod` fromIntegral (finiteBitSize a))) + symRotateSigned :: a -> a -> a + symRotateSigned a s + | finiteBitSize s == 1 = a + | finiteBitSize s == 2 = rotate a (fromIntegral s) + | otherwise = + rotate a (fromIntegral (s `mod` fromIntegral (finiteBitSize a))) + symRotateNegated (DefaultFiniteBitsSymRotate a) (DefaultFiniteBitsSymRotate s) + | isSigned a = DefaultFiniteBitsSymRotate $ symRotateSigned a s + | otherwise = DefaultFiniteBitsSymRotate $ symRotateUnsigned a s + where + bs = fromIntegral (finiteBitSize a) + smodbs = s `mod` bs + symRotateUnsigned :: a -> a -> a + symRotateUnsigned a _ = + rotate a (fromIntegral (bs - smodbs)) + symRotateSigned :: a -> a -> a + symRotateSigned a s + | finiteBitSize a == 1 = a + | finiteBitSize a == 2 = rotate a (-fromIntegral s) + | otherwise = + if smodbs > 0 + then rotate a (fromIntegral (bs - smodbs)) + else rotate a (fromIntegral (-smodbs)) + +deriving via (DefaultFiniteBitsSymRotate Int8) instance SymRotate Int8 + +deriving via (DefaultFiniteBitsSymRotate Int16) instance SymRotate Int16 + +deriving via (DefaultFiniteBitsSymRotate Int32) instance SymRotate Int32 + +deriving via (DefaultFiniteBitsSymRotate Int64) instance SymRotate Int64 + +deriving via (DefaultFiniteBitsSymRotate Word8) instance SymRotate Word8 + +deriving via (DefaultFiniteBitsSymRotate Word16) instance SymRotate Word16 + +deriving via (DefaultFiniteBitsSymRotate Word32) instance SymRotate Word32 + +deriving via (DefaultFiniteBitsSymRotate Word64) instance SymRotate Word64 + +deriving via (DefaultFiniteBitsSymRotate Word) instance SymRotate Word diff --git a/src/Grisette/Internal/Core/Data/Class/SymShift.hs b/src/Grisette/Internal/Core/Data/Class/SymShift.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Core/Data/Class/SymShift.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} + +module Grisette.Internal.Core.Data.Class.SymShift + ( SymShift (..), + DefaultFiniteBitsSymShift (..), + ) +where + +import Data.Bits (Bits (isSigned, shift, shiftR), FiniteBits (finiteBitSize)) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Word (Word16, Word32, Word64, Word8) + +-- | A class for shifting operations. +-- +-- The `symShift` function shifts the value to the left if the shift amount is +-- positive, and to the right if the shift amount is negative. If shifting +-- beyond the bit width of the value, the result is the same as shifting with +-- the bit width. +-- +-- The `symShiftNegated` function shifts the value to the right if the shift +-- amount is positive, and to the left if the shift amount is negative. This +-- function is introduced to handle the asymmetry of the range of values. +class (Bits a) => SymShift a where + symShift :: a -> a -> a + symShiftNegated :: a -> a -> a + +instance SymShift Int where + symShift a s + | s >= finiteBitSize s = 0 + | s <= -finiteBitSize s = if a >= 0 then 0 else -1 + | otherwise = shift a s + symShiftNegated :: Int -> Int -> Int + symShiftNegated a s + | s <= -finiteBitSize a = 0 + | otherwise = symShift a (-s) + +newtype DefaultFiniteBitsSymShift a = DefaultFiniteBitsSymShift + { unDefaultFiniteBitsSymShift :: a + } + deriving newtype (Eq, Bits) + +instance + (Integral a, FiniteBits a) => + SymShift (DefaultFiniteBitsSymShift a) + where + symShift (DefaultFiniteBitsSymShift a) (DefaultFiniteBitsSymShift s) + | isSigned a = DefaultFiniteBitsSymShift $ symShiftSigned a s + | otherwise = DefaultFiniteBitsSymShift $ symShiftUnsigned a s + where + symShiftUnsigned :: (Integral a, FiniteBits a) => a -> a -> a + symShiftUnsigned a s + | s >= fromIntegral (finiteBitSize a) = 0 + | otherwise = shift a (fromIntegral s) + {-# INLINE symShiftUnsigned #-} + + symShiftSigned :: (Integral a, FiniteBits a) => a -> a -> a + symShiftSigned a s + | finiteBitSize s == 1 = shift a (fromIntegral s) + | finiteBitSize s == 2 = shift a (fromIntegral s) + | s >= fromIntegral (finiteBitSize a) = 0 + | s <= fromIntegral (-finiteBitSize a) = if a < 0 then -1 else 0 + | otherwise = shift a (fromIntegral s) + {-# INLINE symShiftSigned #-} + {-# INLINE symShift #-} + symShiftNegated (DefaultFiniteBitsSymShift a) (DefaultFiniteBitsSymShift s) + | isSigned a = DefaultFiniteBitsSymShift $ symShiftSigned a s + | otherwise = DefaultFiniteBitsSymShift $ symShiftUnsigned a s + where + symShiftUnsigned :: (Integral a, FiniteBits a) => a -> a -> a + symShiftUnsigned a s + | s >= fromIntegral (finiteBitSize a) = 0 + | otherwise = shiftR a (fromIntegral s) + {-# INLINE symShiftUnsigned #-} + + symShiftSigned :: (Integral a, FiniteBits a) => a -> a -> a + symShiftSigned a s + | finiteBitSize s == 1 = shift a (-fromIntegral s) + | finiteBitSize s == 2 = shift a (-fromIntegral s) + | s <= fromIntegral (-finiteBitSize a) = 0 + | s >= fromIntegral (finiteBitSize a) = if a < 0 then -1 else 0 + | otherwise = shift a (-fromIntegral s) + {-# INLINE symShiftSigned #-} + {-# INLINE symShiftNegated #-} + +deriving via (DefaultFiniteBitsSymShift Int8) instance SymShift Int8 + +deriving via (DefaultFiniteBitsSymShift Int16) instance SymShift Int16 + +deriving via (DefaultFiniteBitsSymShift Int32) instance SymShift Int32 + +deriving via (DefaultFiniteBitsSymShift Int64) instance SymShift Int64 + +deriving via (DefaultFiniteBitsSymShift Word8) instance SymShift Word8 + +deriving via (DefaultFiniteBitsSymShift Word16) instance SymShift Word16 + +deriving via (DefaultFiniteBitsSymShift Word32) instance SymShift Word32 + +deriving via (DefaultFiniteBitsSymShift Word64) instance SymShift Word64 + +deriving via (DefaultFiniteBitsSymShift Word) instance SymShift Word diff --git a/src/Grisette/Internal/Core/Data/Class/ToCon.hs b/src/Grisette/Internal/Core/Data/Class/ToCon.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Core/Data/Class/ToCon.hs @@ -0,0 +1,326 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Core.Data.Class.ToCon +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Core.Data.Class.ToCon + ( -- * Converting to concrete values + ToCon (..), + ) +where + +import Control.Monad.Except (ExceptT (ExceptT)) +import Control.Monad.Identity + ( Identity (Identity, runIdentity), + IdentityT (IdentityT), + ) +import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import qualified Data.ByteString as B +import Data.Functor.Sum (Sum) +import Data.Int (Int16, Int32, Int64, Int8) +import qualified Data.Text as T +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.Generics (Generic (Rep, from, to), K1 (K1), M1 (M1), U1, V1, type (:*:) ((:*:)), type (:+:) (L1, R1)) +import GHC.TypeNats (KnownNat, type (<=)) +import Generics.Deriving (Default (Default)) +import Generics.Deriving.Instances () +import Grisette.Internal.Core.Control.Exception (AssertionError, VerificationConditions) +import Grisette.Internal.Core.Data.Class.Solvable (Solvable (conView), pattern Con) +import Grisette.Internal.SymPrim.BV + ( IntN (IntN), + WordN (WordN), + ) +import Grisette.Internal.SymPrim.GeneralFun (type (-->)) +import Grisette.Internal.SymPrim.IntBitwidth (intBitwidthQ) +import Grisette.Internal.SymPrim.Prim.Term + ( LinkedRep, + SupportedPrim, + ) +import Grisette.Internal.SymPrim.SymBV + ( SymIntN, + SymWordN, + ) +import Grisette.Internal.SymPrim.SymBool (SymBool) +import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>)) +import Grisette.Internal.SymPrim.SymInteger (SymInteger) +import Grisette.Internal.SymPrim.SymTabularFun (type (=~>)) +import Grisette.Internal.SymPrim.TabularFun (type (=->)) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim + +-- | Convert a symbolic value to concrete value if possible. +class ToCon a b where + -- | Convert a symbolic value to concrete value if possible. + -- If the symbolic value cannot be converted to concrete, the result will be 'Nothing'. + -- + -- >>> toCon (ssym "a" :: SymInteger) :: Maybe Integer + -- Nothing + -- + -- >>> toCon (con 1 :: SymInteger) :: Maybe Integer + -- Just 1 + -- + -- 'toCon' works on complex types too. + -- + -- >>> toCon ([con 1, con 2] :: [SymInteger]) :: Maybe [Integer] + -- Just [1,2] + -- + -- >>> toCon ([con 1, ssym "a"] :: [SymInteger]) :: Maybe [Integer] + -- Nothing + toCon :: a -> Maybe b + +#define CONCRETE_TOCON(type) \ +instance ToCon type type where \ + toCon = Just + +#define CONCRETE_TOCON_BV(type) \ +instance (KnownNat n, 1 <= n) => ToCon (type n) (type n) where \ + toCon = Just + +#if 1 +CONCRETE_TOCON(Bool) +CONCRETE_TOCON(Integer) +CONCRETE_TOCON(Char) +CONCRETE_TOCON(Int) +CONCRETE_TOCON(Int8) +CONCRETE_TOCON(Int16) +CONCRETE_TOCON(Int32) +CONCRETE_TOCON(Int64) +CONCRETE_TOCON(Word) +CONCRETE_TOCON(Word8) +CONCRETE_TOCON(Word16) +CONCRETE_TOCON(Word32) +CONCRETE_TOCON(Word64) +CONCRETE_TOCON(B.ByteString) +CONCRETE_TOCON(T.Text) +CONCRETE_TOCON_BV(WordN) +CONCRETE_TOCON_BV(IntN) +#endif + +-- Unit +instance ToCon () () where + toCon = Just + +-- Either +deriving via (Default (Either e2 a2)) instance (ToCon e1 e2, ToCon a1 a2) => ToCon (Either e1 a1) (Either e2 a2) + +-- Maybe +deriving via (Default (Maybe a2)) instance (ToCon a1 a2) => ToCon (Maybe a1) (Maybe a2) + +-- List +deriving via (Default [b]) instance (ToCon a b) => ToCon [a] [b] + +-- (,) +deriving via (Default (a2, b2)) instance (ToCon a1 a2, ToCon b1 b2) => ToCon (a1, b1) (a2, b2) + +-- (,,) +deriving via (Default (a2, b2, c2)) instance (ToCon a1 a2, ToCon b1 b2, ToCon c1 c2) => ToCon (a1, b1, c1) (a2, b2, c2) + +-- (,,,) +deriving via + (Default (a2, b2, c2, d2)) + instance + (ToCon a1 a2, ToCon b1 b2, ToCon c1 c2, ToCon d1 d2) => ToCon (a1, b1, c1, d1) (a2, b2, c2, d2) + +-- (,,,,) +deriving via + (Default (a2, b2, c2, d2, e2)) + instance + (ToCon a1 a2, ToCon b1 b2, ToCon c1 c2, ToCon d1 d2, ToCon e1 e2) => + ToCon (a1, b1, c1, d1, e1) (a2, b2, c2, d2, e2) + +-- (,,,,,) +deriving via + (Default (a2, b2, c2, d2, e2, f2)) + instance + (ToCon a1 a2, ToCon b1 b2, ToCon c1 c2, ToCon d1 d2, ToCon e1 e2, ToCon f1 f2) => + ToCon (a1, b1, c1, d1, e1, f1) (a2, b2, c2, d2, e2, f2) + +-- (,,,,,,) +deriving via + (Default (a2, b2, c2, d2, e2, f2, g2)) + instance + (ToCon a1 a2, ToCon b1 b2, ToCon c1 c2, ToCon d1 d2, ToCon e1 e2, ToCon f1 f2, ToCon g1 g2) => + ToCon (a1, b1, c1, d1, e1, f1, g1) (a2, b2, c2, d2, e2, f2, g2) + +-- (,,,,,,,) +deriving via + (Default (a2, b2, c2, d2, e2, f2, g2, h2)) + instance + (ToCon a1 a2, ToCon b1 b2, ToCon c1 c2, ToCon d1 d2, ToCon e1 e2, ToCon f1 f2, ToCon g1 g2, ToCon h1 h2) => + ToCon (a1, b1, c1, d1, e1, f1, g1, h1) (a2, b2, c2, d2, e2, f2, g2, h2) + +-- MaybeT +instance + (ToCon (m1 (Maybe a)) (m2 (Maybe b))) => + ToCon (MaybeT m1 a) (MaybeT m2 b) + where + toCon (MaybeT v) = MaybeT <$> toCon v + +-- ExceptT +instance + (ToCon (m1 (Either e1 a)) (m2 (Either e2 b))) => + ToCon (ExceptT e1 m1 a) (ExceptT e2 m2 b) + where + toCon (ExceptT v) = ExceptT <$> toCon v + +instance + (ToCon (m1 (Either e1 a)) (Either e2 b)) => + ToCon (ExceptT e1 m1 a) (Either e2 b) + where + toCon (ExceptT v) = toCon v + +-- Sum +deriving via + (Default (Sum f1 g1 a1)) + instance + (ToCon (f a) (f1 a1), ToCon (g a) (g1 a1)) => ToCon (Sum f g a) (Sum f1 g1 a1) + +-- WriterT +instance + (ToCon (m1 (a, s1)) (m2 (b, s2))) => + ToCon (WriterLazy.WriterT s1 m1 a) (WriterLazy.WriterT s2 m2 b) + where + toCon (WriterLazy.WriterT v) = WriterLazy.WriterT <$> toCon v + +instance + (ToCon (m1 (a, s1)) (m2 (b, s2))) => + ToCon (WriterStrict.WriterT s1 m1 a) (WriterStrict.WriterT s2 m2 b) + where + toCon (WriterStrict.WriterT v) = WriterStrict.WriterT <$> toCon v + +-- Identity +instance (ToCon a b) => ToCon (Identity a) (Identity b) where + toCon (Identity a) = Identity <$> toCon a + +instance ToCon (Identity v) v where + toCon = Just . runIdentity + +instance ToCon v (Identity v) where + toCon = Just . Identity + +-- IdentityT +instance (ToCon (m a) (m1 b)) => ToCon (IdentityT m a) (IdentityT m1 b) where + toCon (IdentityT a) = IdentityT <$> toCon a + +#define TO_CON_SYMID_SIMPLE(symtype) \ +instance ToCon symtype symtype where \ + toCon = Just + +#define TO_CON_SYMID_BV(symtype) \ +instance (KnownNat n, 1 <= n) => ToCon (symtype n) (symtype n) where \ + toCon = Just + +#define TO_CON_SYMID_FUN(op) \ +instance (SupportedPrim a, SupportedPrim b) => ToCon (a op b) (a op b) where \ + toCon = Just + +#if 1 +TO_CON_SYMID_SIMPLE(SymBool) +TO_CON_SYMID_SIMPLE(SymInteger) +TO_CON_SYMID_BV(SymIntN) +TO_CON_SYMID_BV(SymWordN) +TO_CON_SYMID_FUN(=~>) +TO_CON_SYMID_FUN(-~>) + +#endif + +#define TO_CON_FROMSYM_SIMPLE(contype, symtype) \ +instance ToCon symtype contype where \ + toCon = conView + +#define TO_CON_FROMSYM_BV(contype, symtype) \ +instance (KnownNat n, 1 <= n) => ToCon (symtype n) (contype n) where \ + toCon = conView + +#define TO_CON_FROMSYM_FUN(conop, symop) \ +instance (SupportedPrim (conop ca cb), LinkedRep ca sa, LinkedRep cb sb) => \ + ToCon (symop sa sb) (conop ca cb) where \ + toCon = conView + +#if 1 +TO_CON_FROMSYM_SIMPLE(Bool, SymBool) +TO_CON_FROMSYM_SIMPLE(Integer, SymInteger) +TO_CON_FROMSYM_BV(IntN, SymIntN) +TO_CON_FROMSYM_BV(WordN, SymWordN) +TO_CON_FROMSYM_FUN((=->), (=~>)) +TO_CON_FROMSYM_FUN((-->), (-~>)) +#endif + +#define TOCON_MACHINE_INTEGER(sbvw, bvw, n, int) \ +instance ToCon (sbvw n) int where \ + toCon (Con (bvw v :: bvw n)) = Just $ fromIntegral v; \ + toCon _ = Nothing + +#if 1 +TOCON_MACHINE_INTEGER(SymIntN, IntN, 8, Int8) +TOCON_MACHINE_INTEGER(SymIntN, IntN, 16, Int16) +TOCON_MACHINE_INTEGER(SymIntN, IntN, 32, Int32) +TOCON_MACHINE_INTEGER(SymIntN, IntN, 64, Int64) +TOCON_MACHINE_INTEGER(SymWordN, WordN, 8, Word8) +TOCON_MACHINE_INTEGER(SymWordN, WordN, 16, Word16) +TOCON_MACHINE_INTEGER(SymWordN, WordN, 32, Word32) +TOCON_MACHINE_INTEGER(SymWordN, WordN, 64, Word64) +TOCON_MACHINE_INTEGER(SymIntN, IntN, $intBitwidthQ, Int) +TOCON_MACHINE_INTEGER(SymWordN, WordN, $intBitwidthQ, Word) +#endif + +deriving via + (Default AssertionError) + instance + ToCon AssertionError AssertionError + +deriving via + (Default VerificationConditions) + instance + ToCon VerificationConditions VerificationConditions + +-- Derivation of ToCon for generic types +instance (Generic a, Generic b, ToCon' (Rep a) (Rep b)) => ToCon a (Default b) where + toCon v = fmap (Default . to) $ toCon' $ from v + +class ToCon' a b where + toCon' :: a c -> Maybe (b c) + +instance ToCon' U1 U1 where + toCon' = Just + +instance ToCon' V1 V1 where + toCon' = Just + +instance (ToCon a b) => ToCon' (K1 i a) (K1 i b) where + toCon' (K1 a) = K1 <$> toCon a + +instance (ToCon' a b) => ToCon' (M1 i c1 a) (M1 i c2 b) where + toCon' (M1 a) = M1 <$> toCon' a + +instance (ToCon' a1 a2, ToCon' b1 b2) => ToCon' (a1 :+: b1) (a2 :+: b2) where + toCon' (L1 a) = L1 <$> toCon' a + toCon' (R1 a) = R1 <$> toCon' a + +instance (ToCon' a1 a2, ToCon' b1 b2) => ToCon' (a1 :*: b1) (a2 :*: b2) where + toCon' (a :*: b) = do + ac <- toCon' a + bc <- toCon' b + return $ ac :*: bc diff --git a/src/Grisette/Internal/Core/Data/Class/ToSym.hs b/src/Grisette/Internal/Core/Data/Class/ToSym.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Core/Data/Class/ToSym.hs @@ -0,0 +1,316 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Core.Data.Class.ToSym +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Core.Data.Class.ToSym + ( -- * Converting to symbolic values + ToSym (..), + ) +where + +import Control.Monad.Identity + ( Identity (Identity), + IdentityT (IdentityT), + ) +import Control.Monad.Reader (ReaderT (ReaderT)) +import qualified Control.Monad.State.Lazy as StateLazy +import qualified Control.Monad.State.Strict as StateStrict +import Control.Monad.Trans.Except (ExceptT (ExceptT)) +import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import qualified Data.ByteString as B +import Data.Functor.Sum (Sum) +import Data.Int (Int16, Int32, Int64, Int8) +import qualified Data.Text as T +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.TypeNats (KnownNat, type (<=)) +import Generics.Deriving + ( Default (Default), + Generic (Rep, from, to), + K1 (K1), + M1 (M1), + U1, + V1, + type (:*:) ((:*:)), + type (:+:) (L1, R1), + ) +import Grisette.Internal.Core.Control.Exception (AssertionError, VerificationConditions) +import Grisette.Internal.Core.Data.Class.Solvable (Solvable (con)) +import Grisette.Internal.SymPrim.BV + ( IntN, + WordN, + ) +import Grisette.Internal.SymPrim.GeneralFun (type (-->)) +import Grisette.Internal.SymPrim.IntBitwidth (intBitwidthQ) +import Grisette.Internal.SymPrim.Prim.Term + ( LinkedRep, + SupportedPrim, + ) +import Grisette.Internal.SymPrim.SymBV + ( SymIntN, + SymWordN, + ) +import Grisette.Internal.SymPrim.SymBool (SymBool) +import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>)) +import Grisette.Internal.SymPrim.SymInteger (SymInteger) +import Grisette.Internal.SymPrim.SymTabularFun (type (=~>)) +import Grisette.Internal.SymPrim.TabularFun (type (=->)) + +-- $setup +-- >>> import Grisette.SymPrim + +-- | Convert a concrete value to symbolic value. +class ToSym a b where + -- | Convert a concrete value to symbolic value. + -- + -- >>> toSym False :: SymBool + -- false + -- + -- >>> toSym [False, True] :: [SymBool] + -- [false,true] + toSym :: a -> b + +#define CONCRETE_TOSYM(type) \ +instance ToSym type type where \ + toSym = id + +#define CONCRETE_TOSYM_BV(type) \ +instance (KnownNat n, 1 <= n) => ToSym (type n) (type n) where \ + toSym = id + +#if 1 +CONCRETE_TOSYM(Bool) +CONCRETE_TOSYM(Integer) +CONCRETE_TOSYM(Char) +CONCRETE_TOSYM(Int) +CONCRETE_TOSYM(Int8) +CONCRETE_TOSYM(Int16) +CONCRETE_TOSYM(Int32) +CONCRETE_TOSYM(Int64) +CONCRETE_TOSYM(Word) +CONCRETE_TOSYM(Word8) +CONCRETE_TOSYM(Word16) +CONCRETE_TOSYM(Word32) +CONCRETE_TOSYM(Word64) +CONCRETE_TOSYM(B.ByteString) +CONCRETE_TOSYM(T.Text) +CONCRETE_TOSYM_BV(IntN) +CONCRETE_TOSYM_BV(WordN) +#endif + +-- Unit +instance ToSym () () where + toSym = id + +-- Either +deriving via (Default (Either e2 a2)) instance (ToSym e1 e2, ToSym a1 a2) => ToSym (Either e1 a1) (Either e2 a2) + +-- Maybe +deriving via (Default (Maybe b)) instance (ToSym a b) => ToSym (Maybe a) (Maybe b) + +-- List +deriving via (Default [b]) instance (ToSym a b) => ToSym [a] [b] + +-- (,) +deriving via (Default (b1, b2)) instance (ToSym a1 b1, ToSym a2 b2) => ToSym (a1, a2) (b1, b2) + +-- (,,) +deriving via (Default (b1, b2, b3)) instance (ToSym a1 b1, ToSym a2 b2, ToSym a3 b3) => ToSym (a1, a2, a3) (b1, b2, b3) + +-- (,,,) +deriving via + (Default (a2, b2, c2, d2)) + instance + (ToSym a1 a2, ToSym b1 b2, ToSym c1 c2, ToSym d1 d2) => ToSym (a1, b1, c1, d1) (a2, b2, c2, d2) + +-- (,,,,) +deriving via + (Default (a2, b2, c2, d2, e2)) + instance + (ToSym a1 a2, ToSym b1 b2, ToSym c1 c2, ToSym d1 d2, ToSym e1 e2) => + ToSym (a1, b1, c1, d1, e1) (a2, b2, c2, d2, e2) + +-- (,,,,,) +deriving via + (Default (a2, b2, c2, d2, e2, f2)) + instance + (ToSym a1 a2, ToSym b1 b2, ToSym c1 c2, ToSym d1 d2, ToSym e1 e2, ToSym f1 f2) => + ToSym (a1, b1, c1, d1, e1, f1) (a2, b2, c2, d2, e2, f2) + +-- (,,,,,,) +deriving via + (Default (a2, b2, c2, d2, e2, f2, g2)) + instance + (ToSym a1 a2, ToSym b1 b2, ToSym c1 c2, ToSym d1 d2, ToSym e1 e2, ToSym f1 f2, ToSym g1 g2) => + ToSym (a1, b1, c1, d1, e1, f1, g1) (a2, b2, c2, d2, e2, f2, g2) + +-- (,,,,,,,) +deriving via + (Default (a2, b2, c2, d2, e2, f2, g2, h2)) + instance + (ToSym a1 a2, ToSym b1 b2, ToSym c1 c2, ToSym d1 d2, ToSym e1 e2, ToSym f1 f2, ToSym g1 g2, ToSym h1 h2) => + ToSym (a1, b1, c1, d1, e1, f1, g1, h1) (a2, b2, c2, d2, e2, f2, g2, h2) + +-- function +instance (ToSym a b) => ToSym (v -> a) (v -> b) where + toSym f = toSym . f + +-- MaybeT +instance + (ToSym (m1 (Maybe a)) (m2 (Maybe b))) => + ToSym (MaybeT m1 a) (MaybeT m2 b) + where + toSym (MaybeT v) = MaybeT $ toSym v + +-- ExceptT +instance + (ToSym (m1 (Either e1 a)) (m2 (Either e2 b))) => + ToSym (ExceptT e1 m1 a) (ExceptT e2 m2 b) + where + toSym (ExceptT v) = ExceptT $ toSym v + +-- StateT +instance (ToSym (s1 -> m1 (a1, s1)) (s2 -> m2 (a2, s2))) => ToSym (StateLazy.StateT s1 m1 a1) (StateLazy.StateT s2 m2 a2) where + toSym (StateLazy.StateT f1) = StateLazy.StateT $ toSym f1 + +instance (ToSym (s1 -> m1 (a1, s1)) (s2 -> m2 (a2, s2))) => ToSym (StateStrict.StateT s1 m1 a1) (StateStrict.StateT s2 m2 a2) where + toSym (StateStrict.StateT f1) = StateStrict.StateT $ toSym f1 + +-- WriterT +instance (ToSym (m1 (a1, s1)) (m2 (a2, s2))) => ToSym (WriterLazy.WriterT s1 m1 a1) (WriterLazy.WriterT s2 m2 a2) where + toSym (WriterLazy.WriterT f1) = WriterLazy.WriterT $ toSym f1 + +instance (ToSym (m1 (a1, s1)) (m2 (a2, s2))) => ToSym (WriterStrict.WriterT s1 m1 a1) (WriterStrict.WriterT s2 m2 a2) where + toSym (WriterStrict.WriterT f1) = WriterStrict.WriterT $ toSym f1 + +-- ReaderT +instance (ToSym (s1 -> m1 a1) (s2 -> m2 a2)) => ToSym (ReaderT s1 m1 a1) (ReaderT s2 m2 a2) where + toSym (ReaderT f1) = ReaderT $ toSym f1 + +-- Sum +deriving via + (Default (Sum f1 g1 a1)) + instance + (ToSym (f a) (f1 a1), ToSym (g a) (g1 a1)) => ToSym (Sum f g a) (Sum f1 g1 a1) + +-- Identity +instance (ToSym a b) => ToSym (Identity a) (Identity b) where + toSym (Identity a) = Identity $ toSym a + +-- IdentityT +instance (ToSym (m a) (m1 b)) => ToSym (IdentityT m a) (IdentityT m1 b) where + toSym (IdentityT v) = IdentityT $ toSym v + +#define TO_SYM_SYMID_SIMPLE(symtype) \ +instance ToSym symtype symtype where \ + toSym = id + +#define TO_SYM_SYMID_BV(symtype) \ +instance (KnownNat n, 1 <= n) => ToSym (symtype n) (symtype n) where \ + toSym = id + +#define TO_SYM_SYMID_FUN(op) \ +instance (SupportedPrim a, SupportedPrim b) => ToSym (a op b) (a op b) where \ + toSym = id + +#if 1 +TO_SYM_SYMID_SIMPLE(SymBool) +TO_SYM_SYMID_SIMPLE(SymInteger) +TO_SYM_SYMID_BV(SymIntN) +TO_SYM_SYMID_BV(SymWordN) +TO_SYM_SYMID_FUN(=~>) +TO_SYM_SYMID_FUN(-~>) +#endif + +#define TO_SYM_FROMCON_SIMPLE(contype, symtype) \ +instance ToSym contype symtype where \ + toSym = con + +#define TO_SYM_FROMCON_BV(contype, symtype) \ +instance (KnownNat n, 1 <= n) => ToSym (contype n) (symtype n) where \ + toSym = con + +#define TO_SYM_FROMCON_FUN(conop, symop) \ +instance (SupportedPrim (conop ca cb), LinkedRep ca sa, LinkedRep cb sb) => \ + ToSym (conop ca cb) (symop sa sb) where \ + toSym = con + +#if 1 +TO_SYM_FROMCON_SIMPLE(Bool, SymBool) +TO_SYM_FROMCON_SIMPLE(Integer, SymInteger) +TO_SYM_FROMCON_BV(IntN, SymIntN) +TO_SYM_FROMCON_BV(WordN, SymWordN) +TO_SYM_FROMCON_FUN((=->), (=~>)) +TO_SYM_FROMCON_FUN((-->), (-~>)) +#endif + +#define TOSYM_MACHINE_INTEGER(int, bv) \ +instance ToSym int (bv) where \ + toSym = fromIntegral + +#if 1 +TOSYM_MACHINE_INTEGER(Int8, SymIntN 8) +TOSYM_MACHINE_INTEGER(Int16, SymIntN 16) +TOSYM_MACHINE_INTEGER(Int32, SymIntN 32) +TOSYM_MACHINE_INTEGER(Int64, SymIntN 64) +TOSYM_MACHINE_INTEGER(Word8, SymWordN 8) +TOSYM_MACHINE_INTEGER(Word16, SymWordN 16) +TOSYM_MACHINE_INTEGER(Word32, SymWordN 32) +TOSYM_MACHINE_INTEGER(Word64, SymWordN 64) +TOSYM_MACHINE_INTEGER(Int, SymIntN $intBitwidthQ) +TOSYM_MACHINE_INTEGER(Word, SymWordN $intBitwidthQ) +#endif + +-- Exception +deriving via + (Default AssertionError) + instance + ToSym AssertionError AssertionError + +deriving via + (Default VerificationConditions) + instance + ToSym VerificationConditions VerificationConditions + +instance (Generic a, Generic b, ToSym' (Rep a) (Rep b)) => ToSym a (Default b) where + toSym = Default . to . toSym' . from + +class ToSym' a b where + toSym' :: a c -> b c + +instance ToSym' U1 U1 where + toSym' = id + +instance ToSym' V1 V1 where + toSym' = id + +instance (ToSym a b) => ToSym' (K1 i a) (K1 i b) where + toSym' (K1 a) = K1 $ toSym a + +instance (ToSym' a b) => ToSym' (M1 i c1 a) (M1 i c2 b) where + toSym' (M1 a) = M1 $ toSym' a + +instance (ToSym' a1 a2, ToSym' b1 b2) => ToSym' (a1 :+: b1) (a2 :+: b2) where + toSym' (L1 a) = L1 $ toSym' a + toSym' (R1 b) = R1 $ toSym' b + +instance (ToSym' a1 a2, ToSym' b1 b2) => ToSym' (a1 :*: b1) (a2 :*: b2) where + toSym' (a :*: b) = toSym' a :*: toSym' b diff --git a/src/Grisette/Internal/Core/Data/Class/TryMerge.hs b/src/Grisette/Internal/Core/Data/Class/TryMerge.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Core/Data/Class/TryMerge.hs @@ -0,0 +1,210 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} + +-- | +-- Module : Grisette.Internal.Core.Data.Class.TryMerge +-- Copyright : (c) Sirui Lu 2023-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Core.Data.Class.TryMerge + ( TryMerge (..), + tryMerge, + MonadTryMerge, + mrgSingle, + mrgSingleWithStrategy, + ) +where + +import Control.Monad.Cont (ContT (ContT)) +import Control.Monad.Except (ExceptT (ExceptT)) +import Control.Monad.Identity + ( Identity, + IdentityT (IdentityT), + ) +import qualified Control.Monad.RWS.Lazy as RWSLazy +import qualified Control.Monad.RWS.Strict as RWSStrict +import Control.Monad.Reader (ReaderT (ReaderT)) +import qualified Control.Monad.State.Lazy as StateLazy +import qualified Control.Monad.State.Strict as StateStrict +import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import Data.Functor.Sum (Sum (InL, InR)) +import qualified Data.Monoid as Monoid +import Grisette.Internal.Core.Data.Class.Mergeable + ( Mergeable (rootStrategy), + Mergeable1 (liftRootStrategy), + Mergeable2 (liftRootStrategy2), + Mergeable3 (liftRootStrategy3), + MergingStrategy, + ) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim + +-- | A class for containers that may or may not be merged. +-- +-- If the container is capable of multi-path execution, then the +-- `tryMergeWithStrategy` function should merge the paths according to the +-- supplied strategy. +-- +-- If the container is not capable of multi-path execution, then the +-- `tryMergeWithStrategy` function should be equivalent to `id`. +-- +-- Note that this will not necessarily do a recursive merge for the elements. +class TryMerge m where + tryMergeWithStrategy :: MergingStrategy a -> m a -> m a + +-- | Try to merge the container with the root strategy. +tryMerge :: (TryMerge m, Mergeable a) => m a -> m a +tryMerge = tryMergeWithStrategy rootStrategy +{-# INLINE tryMerge #-} + +-- | Wrap a value in the applicative functor and capture the 'Mergeable' +-- knowledge. +-- +-- >>> mrgSingleWithStrategy rootStrategy "a" :: UnionM SymInteger +-- {a} +-- +-- __Note:__ Be careful to call this directly from your code. +-- The supplied merge strategy should be consistent with the type's root merge +-- strategy, or some internal invariants would be broken and the program can +-- crash. +-- +-- This function is to be called when the 'Mergeable' constraint can not be +-- resolved, e.g., the merge strategy for the contained type is given with +-- 'Mergeable1'. In other cases, 'mrgPure' is usually a better alternative. +mrgSingleWithStrategy :: + (TryMerge m, Applicative m) => + MergingStrategy a -> + a -> + m a +mrgSingleWithStrategy strategy = tryMergeWithStrategy strategy . pure +{-# INLINE mrgSingleWithStrategy #-} + +-- | Wrap a value in the applicative functor and propagate the type's root merge +-- strategy. +-- +-- Equivalent to @'mrgSingleWithStrategy' 'rootStrategy'@. +-- +-- >>> mrgSingle "a" :: UnionM SymInteger +-- {a} +mrgSingle :: (TryMerge m, Applicative m, Mergeable a) => a -> m a +mrgSingle = mrgSingleWithStrategy rootStrategy +{-# INLINE mrgSingle #-} + +instance (TryMerge m) => TryMerge (MaybeT m) where + tryMergeWithStrategy strategy (MaybeT ma) = + MaybeT $ tryMergeWithStrategy (liftRootStrategy strategy) ma + {-# INLINE tryMergeWithStrategy #-} + +instance (Mergeable e, TryMerge m) => TryMerge (ExceptT e m) where + tryMergeWithStrategy strategy (ExceptT ma) = + ExceptT $ tryMergeWithStrategy (liftRootStrategy strategy) ma + {-# INLINE tryMergeWithStrategy #-} + +instance (TryMerge m) => TryMerge (ReaderT r m) where + tryMergeWithStrategy strategy (ReaderT f) = + ReaderT $ \v -> tryMergeWithStrategy strategy $ f v + {-# INLINE tryMergeWithStrategy #-} + +instance (Mergeable s, TryMerge m) => TryMerge (StateLazy.StateT s m) where + tryMergeWithStrategy strategy (StateLazy.StateT f) = + StateLazy.StateT $ + \s -> tryMergeWithStrategy (liftRootStrategy2 strategy rootStrategy) (f s) + {-# INLINE tryMergeWithStrategy #-} + +instance (Mergeable s, TryMerge m) => TryMerge (StateStrict.StateT s m) where + tryMergeWithStrategy strategy (StateStrict.StateT f) = + StateStrict.StateT $ + \s -> tryMergeWithStrategy (liftRootStrategy2 strategy rootStrategy) (f s) + {-# INLINE tryMergeWithStrategy #-} + +instance + (Monoid w, Mergeable w, TryMerge m) => + TryMerge (WriterLazy.WriterT w m) + where + tryMergeWithStrategy strategy (WriterLazy.WriterT f) = + WriterLazy.WriterT $ + tryMergeWithStrategy (liftRootStrategy2 strategy rootStrategy) f + {-# INLINE tryMergeWithStrategy #-} + +instance + (Monoid w, Mergeable w, TryMerge m) => + TryMerge (WriterStrict.WriterT w m) + where + tryMergeWithStrategy strategy (WriterStrict.WriterT f) = + WriterStrict.WriterT $ + tryMergeWithStrategy (liftRootStrategy2 strategy rootStrategy) f + {-# INLINE tryMergeWithStrategy #-} + +instance + (Monoid w, Mergeable w, Mergeable s, TryMerge m) => + TryMerge (RWSStrict.RWST r w s m) + where + tryMergeWithStrategy strategy (RWSStrict.RWST f) = + RWSStrict.RWST $ + \r s -> + tryMergeWithStrategy + (liftRootStrategy3 strategy rootStrategy rootStrategy) + (f r s) + {-# INLINE tryMergeWithStrategy #-} + +instance + (Monoid w, Mergeable w, Mergeable s, TryMerge m) => + TryMerge (RWSLazy.RWST r w s m) + where + tryMergeWithStrategy strategy (RWSLazy.RWST f) = + RWSLazy.RWST $ + \r s -> + tryMergeWithStrategy + (liftRootStrategy3 strategy rootStrategy rootStrategy) + (f r s) + {-# INLINE tryMergeWithStrategy #-} + +instance (TryMerge m) => TryMerge (IdentityT m) where + tryMergeWithStrategy strategy (IdentityT ma) = + IdentityT $ tryMergeWithStrategy strategy ma + {-# INLINE tryMergeWithStrategy #-} + +instance (TryMerge m, Mergeable r) => TryMerge (ContT r m) where + tryMergeWithStrategy _ (ContT ma) = + ContT $ \c -> tryMergeWithStrategy rootStrategy (ma c) + {-# INLINE tryMergeWithStrategy #-} + +-- | Alias for a monad type that has 'TryMerge'. +type MonadTryMerge f = (TryMerge f, Monad f) + +#define TRYMERGE_ID(T) \ + instance TryMerge (T) where { \ + tryMergeWithStrategy _ = id; {-# INLINE tryMergeWithStrategy #-} \ + } + +#if 1 +TRYMERGE_ID(Either a) +TRYMERGE_ID(Maybe) +TRYMERGE_ID(Identity) +TRYMERGE_ID([]) +TRYMERGE_ID((,) a) +TRYMERGE_ID((,,) a b) +TRYMERGE_ID((,,,) a b c) +TRYMERGE_ID((,,,,) a b c d) +TRYMERGE_ID((,,,,,) a b c d e) +TRYMERGE_ID((,,,,,,) a b c d e f) +TRYMERGE_ID((,,,,,,,) a b c d e f g) +TRYMERGE_ID((,,,,,,,,) a b c d e f g h) +#endif + +instance (TryMerge f, TryMerge g) => TryMerge (Sum f g) where + tryMergeWithStrategy strategy (InL fa) = + InL $ tryMergeWithStrategy strategy fa + tryMergeWithStrategy strategy (InR fa) = + InR $ tryMergeWithStrategy strategy fa + +instance TryMerge Monoid.Sum where + tryMergeWithStrategy _ = id + {-# INLINE tryMergeWithStrategy #-} diff --git a/src/Grisette/Internal/Core/Data/MemoUtils.hs b/src/Grisette/Internal/Core/Data/MemoUtils.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Core/Data/MemoUtils.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Grisette.Internal.Core.Data.MemoUtils +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Core.Data.MemoUtils + ( -- * Hashtable-based memoization + htmemo, + htmemo2, + htmemo3, + htmup, + htmemoFix, + ) +where + +import Data.Function (fix) +import qualified Data.HashTable.IO as H +import Data.Hashable (Hashable) +import System.IO.Unsafe (unsafePerformIO) + +type HashTable k v = H.BasicHashTable k v + +-- | Function memoizer with mutable hash table. +htmemo :: (Eq k, Hashable k) => (k -> a) -> k -> a +htmemo f = unsafePerformIO $ do + cache <- H.new :: IO (HashTable k v) + return $ \x -> unsafePerformIO $ do + tryV <- H.lookup cache x + case tryV of + Nothing -> do + -- traceM "New value" + let v = f x + H.insert cache x v + return v + Just v -> return v + +-- | Lift a memoizer to work with one more argument. +htmup :: (Eq k, Hashable k) => (b -> c) -> (k -> b) -> (k -> c) +htmup mem f = htmemo (mem . f) + +-- | Function memoizer with mutable hash table. Works on binary functions. +htmemo2 :: (Eq k1, Hashable k1, Eq k2, Hashable k2) => (k1 -> k2 -> a) -> (k1 -> k2 -> a) +htmemo2 = htmup htmemo + +-- | Function memoizer with mutable hash table. Works on ternary functions. +htmemo3 :: + (Eq k1, Hashable k1, Eq k2, Hashable k2, Eq k3, Hashable k3) => + (k1 -> k2 -> k3 -> a) -> + (k1 -> k2 -> k3 -> a) +htmemo3 = htmup htmemo2 + +-- | Memoizing recursion. Use like 'fix'. +htmemoFix :: (Eq k, Hashable k) => ((k -> a) -> (k -> a)) -> k -> a +htmemoFix h = fix (htmemo . h) diff --git a/src/Grisette/Internal/Core/Data/Symbol.hs b/src/Grisette/Internal/Core/Data/Symbol.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Core/Data/Symbol.hs @@ -0,0 +1,217 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Unused LANGUAGE pragma" #-} + +-- | +-- Module : Grisette.Internal.Core.Data.Symbol +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Core.Data.Symbol + ( Identifier (..), + identifier, + withInfo, + withLoc, + Symbol (..), + simple, + indexed, + ) +where + +import Control.DeepSeq (NFData (rnf)) +import Data.Hashable (Hashable (hashWithSalt)) +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 Language.Haskell.TH.Syntax (Lift (liftTyped), unsafeTExpCoerce) +import Language.Haskell.TH.Syntax.Compat (SpliceQ, liftSplice) + +-- | Identifier type used for 'GenSym' +-- +-- The constructor is hidden intentionally. +-- You can construct an identifier by: +-- +-- * a raw identifier +-- +-- The following two expressions will refer to the same identifier (the +-- solver won't distinguish them and would assign the same value to them). +-- The user may need to use unique names to avoid unintentional identifier +-- collision. +-- +-- >>> identifier "a" +-- a +-- +-- >>> "a" :: Identifier -- available when OverloadedStrings is enabled +-- a +-- +-- * bundle the identifier with some user provided information +-- +-- Identifiers created with different name or different additional +-- information will not be the same. +-- +-- >>> withInfo "a" (1 :: Int) +-- a:1 +-- +-- * bundle the calling file location with the identifier to ensure global +-- uniqueness +-- +-- Identifiers created at different locations will not be the +-- same. The identifiers created at the same location will be the same. +-- +-- >>> $$(withLoc "a") -- a sample result could be "a::18:4-18" +-- a::... +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 + +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 Hashable Identifier where + hashWithSalt s (Identifier n) = s `hashWithSalt` n + hashWithSalt s (IdentifierWithInfo n i) = s `hashWithSalt` n `hashWithSalt` i + +instance Lift Identifier where + liftTyped (Identifier n) = [||Identifier n||] + liftTyped (IdentifierWithInfo n i) = [||IdentifierWithInfo n i||] + +instance NFData Identifier where + rnf (Identifier n) = rnf n + rnf (IdentifierWithInfo n i) = rnf n `seq` rnf i + +-- | Simple identifier. +-- The same identifier refers to the same symbolic variable in the whole +-- program. +-- +-- The user may need to use unique identifiers to avoid unintentional identifier +-- collision. +identifier :: T.Text -> Identifier +identifier = Identifier + +-- | Identifier with extra information. +-- +-- The same identifier with the same information refers to the same symbolic +-- variable in the whole program. +-- +-- The user may need to use unique identifiers or additional information 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 +-- >>> :set -XTemplateHaskell + +-- File location type. +data FileLocation = FileLocation + { locPath :: String, + locLineno :: Int, + locSpan :: (Int, Int) + } + deriving (Eq, Ord, Generic, Lift, NFData, Hashable) + +instance Show FileLocation where + show (FileLocation p l (s1, s2)) = + p ++ ":" ++ show l ++ ":" ++ show s1 ++ "-" ++ show s2 + +parseFileLocation :: String -> FileLocation +parseFileLocation str = + let r = reverse str + (s2, r1) = break (== '-') r + (s1, r2) = break (== ':') $ tail r1 + (l, p) = break (== ':') $ tail r2 + in FileLocation + (reverse $ tail p) + (read $ reverse l) + (read $ reverse s1, read $ reverse s2) + +-- | Identifier with the current location as extra information. +-- +-- >>> $$(withLoc "a") -- a sample result could be "a::18:4-18" +-- a::... +-- +-- The uniqueness is ensured for the call to 'identifier' at different location. +withLoc :: Identifier -> SpliceQ Identifier +withLoc s = + [|| + withInfo + s + (parseFileLocation $$(liftSplice $ unsafeTExpCoerce __LOCATION__)) + ||] + +-- | Symbol types for a symbolic variable. +-- +-- The symbols can be indexed with an integer. +data Symbol where + SimpleSymbol :: Identifier -> Symbol + IndexedSymbol :: Identifier -> Int -> Symbol + deriving (Eq, Ord, Generic, Lift, NFData, Hashable) + +instance Show Symbol where + show (SimpleSymbol i) = show i + show (IndexedSymbol i idx) = show i ++ "@" ++ show idx + +instance IsString Symbol where + fromString = SimpleSymbol . fromString + +-- | Create a simple symbol. +simple :: Identifier -> Symbol +simple = SimpleSymbol + +-- | Create an indexed symbol. +indexed :: Identifier -> Int -> Symbol +indexed = IndexedSymbol diff --git a/src/Grisette/Internal/Core/Data/Union.hs b/src/Grisette/Internal/Core/Data/Union.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Core/Data/Union.hs @@ -0,0 +1,322 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Grisette.Internal.Core.Data.Union +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Core.Data.Union + ( -- * The union data structure. + + -- | Please consider using 'Grisette.Internal.Core.Control.Monad.UnionM' instead. + Union (..), + ifWithLeftMost, + ifWithStrategy, + fullReconstruct, + ) +where + +import Control.DeepSeq (NFData (rnf), NFData1 (liftRnf), rnf1) +import Control.Monad (ap) +import Data.Functor.Classes + ( Eq1 (liftEq), + Show1 (liftShowsPrec), + showsPrec1, + showsUnaryWith, + ) +import Data.Hashable (Hashable (hashWithSalt)) +import GHC.Generics (Generic, Generic1) +import Grisette.Internal.Core.Data.Class.GPretty + ( GPretty (gprettyPrec), + condEnclose, + ) +import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp (symIte)) +import Grisette.Internal.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.&&), (.||))) +import Grisette.Internal.Core.Data.Class.Mergeable + ( Mergeable (rootStrategy), + Mergeable1 (liftRootStrategy), + MergingStrategy (NoStrategy, SimpleStrategy, SortedStrategy), + ) +import Grisette.Internal.Core.Data.Class.PlainUnion + ( PlainUnion (ifView, singleView), + ) +import Grisette.Internal.Core.Data.Class.SimpleMergeable + ( SimpleMergeable (mrgIte), + SimpleMergeable1 (liftMrgIte), + UnionMergeable1 (mrgIfPropagatedStrategy, mrgIfWithStrategy), + mrgIf, + ) +import Grisette.Internal.Core.Data.Class.Solvable (pattern Con) +import Grisette.Internal.Core.Data.Class.TryMerge (TryMerge (tryMergeWithStrategy)) +import Grisette.Internal.SymPrim.AllSyms + ( AllSyms (allSymsS), + SomeSym (SomeSym), + ) +import Grisette.Internal.SymPrim.SymBool (SymBool) +import Language.Haskell.TH.Syntax (Lift) + +#if MIN_VERSION_prettyprinter(1,7,0) +import Prettyprinter (align, group, nest, vsep) +#else +import Data.Text.Prettyprint.Doc (align, group, nest, vsep) +#endif + +-- | The default union implementation. +data Union a where + -- | A single value + UnionSingle :: a -> Union a + -- | A if value + UnionIf :: + -- | Cached leftmost value + a -> + -- | Is merged invariant already maintained? + !Bool -> + -- | If condition + !SymBool -> + -- | True branch + Union a -> + -- | False branch + Union a -> + Union a + deriving (Generic, Eq, Lift, Generic1) + deriving (Functor) + +instance Applicative Union where + pure = UnionSingle + {-# INLINE pure #-} + (<*>) = ap + {-# INLINE (<*>) #-} + +instance Monad Union where + return = pure + {-# INLINE return #-} + UnionSingle a >>= f = f a + UnionIf _ _ c t f >>= f' = ifWithLeftMost False c (t >>= f') (f >>= f') + {-# INLINE (>>=) #-} + +instance Eq1 Union where + liftEq e (UnionSingle a) (UnionSingle b) = e a b + liftEq e (UnionIf l1 i1 c1 t1 f1) (UnionIf l2 i2 c2 t2 f2) = + e l1 l2 && i1 == i2 && c1 == c2 && liftEq e t1 t2 && liftEq e f1 f2 + liftEq _ _ _ = False + +instance (NFData a) => NFData (Union a) where + rnf = rnf1 + +instance NFData1 Union where + liftRnf _a (UnionSingle a) = _a a + liftRnf _a (UnionIf a bo b l r) = + _a a `seq` + rnf bo `seq` + rnf b `seq` + liftRnf _a l `seq` + liftRnf _a r + +-- | Build 'UnionIf' with leftmost cache correctly maintained. +-- +-- Usually you should never directly try to build a 'UnionIf' with its +-- constructor. +ifWithLeftMost :: Bool -> SymBool -> Union a -> Union a -> Union a +ifWithLeftMost _ (Con c) t f + | c = t + | otherwise = f +ifWithLeftMost inv cond t f = UnionIf (leftMost t) inv cond t f +{-# INLINE ifWithLeftMost #-} + +instance PlainUnion Union where + singleView (UnionSingle a) = Just a + singleView _ = Nothing + {-# INLINE singleView #-} + ifView (UnionIf _ _ cond ifTrue ifFalse) = Just (cond, ifTrue, ifFalse) + ifView _ = Nothing + {-# INLINE ifView #-} + +leftMost :: Union a -> a +leftMost (UnionSingle a) = a +leftMost (UnionIf a _ _ _ _) = a +{-# INLINE leftMost #-} + +instance (Mergeable a) => Mergeable (Union a) where + rootStrategy = SimpleStrategy $ ifWithStrategy rootStrategy + {-# INLINE rootStrategy #-} + +instance Mergeable1 Union where + liftRootStrategy ms = SimpleStrategy $ ifWithStrategy ms + {-# INLINE liftRootStrategy #-} + +instance (Mergeable a) => SimpleMergeable (Union a) where + mrgIte = mrgIf + +instance SimpleMergeable1 Union where + liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) + +instance TryMerge Union where + tryMergeWithStrategy = fullReconstruct + {-# INLINE tryMergeWithStrategy #-} + +instance UnionMergeable1 Union where + mrgIfWithStrategy = ifWithStrategy + {-# INLINE mrgIfWithStrategy #-} + + mrgIfPropagatedStrategy = ifWithLeftMost False + {-# INLINE mrgIfPropagatedStrategy #-} + +instance Show1 Union where + liftShowsPrec sp _ i (UnionSingle a) = showsUnaryWith sp "Single" i a + liftShowsPrec sp sl i (UnionIf _ _ cond t f) = + showParen (i > 10) $ + showString "If" + . showChar ' ' + . showsPrec 11 cond + . showChar ' ' + . sp1 11 t + . showChar ' ' + . sp1 11 f + where + sp1 = liftShowsPrec sp sl + +instance (Show a) => Show (Union a) where + showsPrec = showsPrec1 + +instance (GPretty a) => GPretty (Union a) where + gprettyPrec n (UnionSingle a) = gprettyPrec n a + gprettyPrec n (UnionIf _ _ cond t f) = + group $ + condEnclose (n > 10) "(" ")" $ + align $ + nest 2 $ + vsep + [ "If", + gprettyPrec 11 cond, + gprettyPrec 11 t, + gprettyPrec 11 f + ] + +instance (Hashable a) => Hashable (Union a) where + s `hashWithSalt` (UnionSingle a) = + s `hashWithSalt` (0 :: Int) `hashWithSalt` a + s `hashWithSalt` (UnionIf _ _ c l r) = + s + `hashWithSalt` (1 :: Int) + `hashWithSalt` c + `hashWithSalt` l + `hashWithSalt` r + +instance (AllSyms a) => AllSyms (Union a) where + allSymsS (UnionSingle v) = allSymsS v + allSymsS (UnionIf _ _ c t f) = \l -> SomeSym c : (allSymsS t . allSymsS f $ l) + +-- | Fully reconstruct a 'Union' to maintain the merged invariant. +fullReconstruct :: MergingStrategy a -> Union a -> Union a +fullReconstruct strategy (UnionIf _ False cond t f) = + ifWithStrategyInv + strategy + cond + (fullReconstruct strategy t) + (fullReconstruct strategy f) +fullReconstruct _ u = u +{-# INLINE fullReconstruct #-} + +-- | Use a specific strategy to build a 'UnionIf' value. +-- +-- The merged invariant will be maintained in the result. +ifWithStrategy :: + MergingStrategy a -> + SymBool -> + Union a -> + Union a -> + Union a +ifWithStrategy strategy cond t@(UnionIf _ False _ _ _) f = + ifWithStrategy strategy cond (fullReconstruct strategy t) f +ifWithStrategy strategy cond t f@(UnionIf _ False _ _ _) = + ifWithStrategy strategy cond t (fullReconstruct strategy f) +ifWithStrategy strategy cond t f = ifWithStrategyInv strategy cond t f +{-# INLINE ifWithStrategy #-} + +ifWithStrategyInv :: + MergingStrategy a -> + SymBool -> + Union a -> + Union a -> + Union a +ifWithStrategyInv _ (Con v) t f + | v = t + | otherwise = f +ifWithStrategyInv strategy cond (UnionIf _ True condTrue tt _) f + | cond == condTrue = ifWithStrategyInv strategy cond tt f +-- {| symNot cond == condTrue || cond == symNot condTrue = ifWithStrategyInv strategy cond ft f +ifWithStrategyInv strategy cond t (UnionIf _ True condFalse _ ff) + | cond == condFalse = ifWithStrategyInv strategy cond t ff +-- {| symNot cond == condTrue || cond == symNot condTrue = ifWithStrategyInv strategy cond t tf -- buggy here condTrue +ifWithStrategyInv (SimpleStrategy m) cond (UnionSingle l) (UnionSingle r) = UnionSingle $ m cond l r +ifWithStrategyInv strategy@(SortedStrategy idxFun substrategy) cond ifTrue ifFalse = case (ifTrue, ifFalse) of + (UnionSingle _, UnionSingle _) -> ssUnionIf cond ifTrue ifFalse + (UnionSingle _, UnionIf {}) -> sgUnionIf cond ifTrue ifFalse + (UnionIf {}, UnionSingle _) -> gsUnionIf cond ifTrue ifFalse + _ -> ggUnionIf cond ifTrue ifFalse + where + ssUnionIf cond' ifTrue' ifFalse' + | idxt < idxf = ifWithLeftMost True cond' ifTrue' ifFalse' + | idxt == idxf = ifWithStrategyInv (substrategy idxt) cond' ifTrue' ifFalse' + | otherwise = ifWithLeftMost True (symNot cond') ifFalse' ifTrue' + where + idxt = idxFun $ leftMost ifTrue' + idxf = idxFun $ leftMost ifFalse' + {-# INLINE ssUnionIf #-} + sgUnionIf cond' ifTrue' ifFalse'@(UnionIf _ True condf ft ff) + | idxft == idxff = ssUnionIf cond' ifTrue' ifFalse' + | idxt < idxft = ifWithLeftMost True cond' ifTrue' ifFalse' + | idxt == idxft = ifWithLeftMost True (cond' .|| condf) (ifWithStrategyInv (substrategy idxt) cond' ifTrue' ft) ff + | otherwise = ifWithLeftMost True (symNot cond' .&& condf) ft (ifWithStrategyInv strategy cond' ifTrue' ff) + where + idxft = idxFun $ leftMost ft + idxff = idxFun $ leftMost ff + idxt = idxFun $ leftMost ifTrue' + sgUnionIf _ _ _ = undefined + {-# INLINE sgUnionIf #-} + gsUnionIf cond' ifTrue'@(UnionIf _ True condt tt tf) ifFalse' + | idxtt == idxtf = ssUnionIf cond' ifTrue' ifFalse' + | idxtt < idxf = ifWithLeftMost True (cond' .&& condt) tt $ ifWithStrategyInv strategy cond' tf ifFalse' + | idxtt == idxf = ifWithLeftMost True (symNot cond' .|| condt) (ifWithStrategyInv (substrategy idxf) cond' tt ifFalse') tf + | otherwise = ifWithLeftMost True (symNot cond') ifFalse' ifTrue' + where + idxtt = idxFun $ leftMost tt + idxtf = idxFun $ leftMost tf + idxf = idxFun $ leftMost ifFalse' + gsUnionIf _ _ _ = undefined + {-# INLINE gsUnionIf #-} + ggUnionIf cond' ifTrue'@(UnionIf _ True condt tt tf) ifFalse'@(UnionIf _ True condf ft ff) + | idxtt == idxtf = sgUnionIf cond' ifTrue' ifFalse' + | idxft == idxff = gsUnionIf cond' ifTrue' ifFalse' + | idxtt < idxft = ifWithLeftMost True (cond' .&& condt) tt $ ifWithStrategyInv strategy cond' tf ifFalse' + | idxtt == idxft = + let newCond = symIte cond' condt condf + newUnionIfTrue = ifWithStrategyInv (substrategy idxtt) cond' tt ft + newUnionIfFalse = ifWithStrategyInv strategy cond' tf ff + in ifWithLeftMost True newCond newUnionIfTrue newUnionIfFalse + | otherwise = ifWithLeftMost True (symNot cond' .&& condf) ft $ ifWithStrategyInv strategy cond' ifTrue' ff + where + idxtt = idxFun $ leftMost tt + idxtf = idxFun $ leftMost tf + idxft = idxFun $ leftMost ft + idxff = idxFun $ leftMost ff + ggUnionIf _ _ _ = undefined + {-# INLINE ggUnionIf #-} +ifWithStrategyInv NoStrategy cond ifTrue ifFalse = ifWithLeftMost True cond ifTrue ifFalse +ifWithStrategyInv _ _ _ _ = error "Invariant violated" +{-# INLINE ifWithStrategyInv #-} diff --git a/src/Grisette/Internal/Core/TH/MergeConstructor.hs b/src/Grisette/Internal/Core/TH/MergeConstructor.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Core/TH/MergeConstructor.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE Trustworthy #-} + +-- | +-- Module : Grisette.Internal.Core.TH.MergedConstructor +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Core.TH.MergeConstructor + ( mkMergeConstructor, + mkMergeConstructor', + ) +where + +import Control.Monad (join, replicateM, when, zipWithM) +import Data.Bifunctor (Bifunctor (second)) +import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) +import Grisette.Internal.Core.Data.Class.TryMerge (TryMerge) +import Language.Haskell.TH + ( Body (NormalB), + Clause (Clause), + Con (ForallC, GadtC, InfixC, NormalC, RecC, RecGadtC), + Dec (DataD, FunD, NewtypeD, SigD), + Exp (AppE, ConE, LamE, VarE), + Info (DataConI, TyConI), + Name, + Pat (VarP), + Pred, + Q, + TyVarBndr (PlainTV), + Type (AppT, ArrowT, ForallT, VarT), + mkName, + newName, + pprint, + reify, + ) +#if MIN_VERSION_template_haskell(2,17,0) +import Language.Haskell.TH.Syntax + ( Name (Name), + OccName (OccName), + Specificity (SpecifiedSpec), + Type (MulArrowT), + ) +#else +import Language.Haskell.TH.Syntax (Name (Name), OccName (OccName)) +#endif + +-- | Generate constructor wrappers that wraps the result in a container with `TryMerge` with provided names. +-- +-- > mkMergeConstructor' ["mrgTuple2"] ''(,) +-- +-- generates +-- +-- > mrgTuple2 :: (Mergeable (a, b), Applicative m, TryMerge m) => a -> b -> u (a, b) +-- > mrgTuple2 = \v1 v2 -> mrgSingle (v1, v2) +mkMergeConstructor' :: + -- | Names for generated wrappers + [String] -> + -- | The type to generate the wrappers for + Name -> + Q [Dec] +mkMergeConstructor' names typName = do + constructors <- getConstructors typName + when (length names /= length constructors) $ + fail "Number of names does not match the number of constructors" + ds <- zipWithM mkSingleWrapper names constructors + return $ join ds + +occName :: Name -> String +occName (Name (OccName name) _) = name + +getConstructorName :: Con -> Q String +getConstructorName (NormalC name _) = return $ occName name +getConstructorName (RecC name _) = return $ occName name +getConstructorName InfixC {} = + fail "You should use mkMergeConstructor' to manually provide the name for infix constructors" +getConstructorName (ForallC _ _ c) = getConstructorName c +getConstructorName (GadtC [name] _ _) = return $ occName name +getConstructorName (RecGadtC [name] _ _) = return $ occName name +getConstructorName c = fail $ "Unsupported constructor at this time: " ++ pprint c + +getConstructors :: Name -> Q [Con] +getConstructors typName = do + d <- reify typName + case d of + TyConI (DataD _ _ _ _ constructors _) -> return constructors + TyConI (NewtypeD _ _ _ _ constructor _) -> return [constructor] + _ -> fail $ "Unsupported declaration: " ++ pprint d + +-- | Generate constructor wrappers that wraps the result in a container with `TryMerge`. +-- +-- > mkMergeConstructor "mrg" ''Maybe +-- +-- generates +-- +-- > mrgJust :: (Mergeable (Maybe a), Applicative m, TryMerge m) => m (Maybe a) +-- > mrgNothing = mrgSingle Nothing +-- > mrgJust :: (Mergeable (Maybe a), Applicative m, TryMerge m) => a -> m (Maybe a) +-- > mrgJust = \x -> mrgSingle (Just x) +mkMergeConstructor :: + -- | Prefix for generated wrappers + String -> + -- | The type to generate the wrappers for + Name -> + Q [Dec] +mkMergeConstructor prefix typName = do + constructors <- getConstructors typName + constructorNames <- mapM getConstructorName constructors + mkMergeConstructor' ((prefix ++) <$> constructorNames) typName + +augmentNormalCExpr :: Int -> Exp -> Q Exp +augmentNormalCExpr n f = do + xs <- replicateM n (newName "x") + let args = map VarP xs + mrgSingleFun <- [|mrgSingle|] + return $ + LamE + args + ( AppE mrgSingleFun $ + foldl AppE f (map VarE xs) + ) + +#if MIN_VERSION_template_haskell(2,17,0) +augmentFinalType :: Type -> Q (([TyVarBndr Specificity], [Pred]), Type) +#else +augmentFinalType :: Type -> Q (([TyVarBndr], [Pred]), Type) +#endif +augmentFinalType (AppT a@(AppT ArrowT _) t) = do + tl <- augmentFinalType t + return $ second (AppT a) tl +#if MIN_VERSION_template_haskell(2,17,0) +augmentFinalType (AppT (AppT (AppT MulArrowT _) var) t) = do + tl <- augmentFinalType t + return $ second (AppT (AppT ArrowT var)) tl +#endif +augmentFinalType t = do + mName <- newName "m" + let mTy = VarT mName + mergeable <- [t|Mergeable|] + applicative <- [t|Applicative|] + tryMerge <- [t|TryMerge|] +#if MIN_VERSION_template_haskell(2,17,0) + return + ( ( [ PlainTV mName SpecifiedSpec ], + [ AppT mergeable t, AppT applicative mTy, AppT tryMerge mTy] + ), + AppT mTy t + ) +#else + return + ( ( [ PlainTV mName ], + [ AppT mergeable t, AppT applicative mTy, AppT tryMerge mTy] + ), + AppT mTy t + ) +#endif + +augmentNormalCType :: Type -> Q Type +augmentNormalCType (ForallT tybinders ctx ty1) = do + ((bndrs, preds), augmentedTyp) <- augmentFinalType ty1 + return $ ForallT (tybinders ++ bndrs) (preds ++ ctx) augmentedTyp +augmentNormalCType t = do + ((bndrs, preds), augmentedTyp) <- augmentFinalType t + return $ ForallT bndrs preds augmentedTyp + +mkSingleWrapper :: String -> Con -> Q [Dec] +mkSingleWrapper name (NormalC oriName b) = do + DataConI _ constructorTyp _ <- reify oriName + augmentedTyp <- augmentNormalCType constructorTyp + let retName = mkName name + expr <- augmentNormalCExpr (length b) (ConE oriName) + return + [ SigD retName augmentedTyp, + FunD retName [Clause [] (NormalB expr) []] + ] +mkSingleWrapper name (RecC oriName b) = do + DataConI _ constructorTyp _ <- reify oriName + augmentedTyp <- augmentNormalCType constructorTyp + let retName = mkName name + expr <- augmentNormalCExpr (length b) (ConE oriName) + return + [ SigD retName augmentedTyp, + FunD retName [Clause [] (NormalB expr) []] + ] +mkSingleWrapper _ v = fail $ "Unsupported constructor" ++ pprint v diff --git a/src/Grisette/Internal/IR/SymPrim.hs b/src/Grisette/Internal/IR/SymPrim.hs deleted file mode 100644 --- a/src/Grisette/Internal/IR/SymPrim.hs +++ /dev/null @@ -1,195 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} --- Disable this warning because we are re-exporting things. -{-# OPTIONS_GHC -Wno-missing-import-lists #-} - --- | --- Module : Grisette.Internal.IR.SymPrim --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Internal.IR.SymPrim - ( -- Sym (..), - UnaryOp (..), - BinaryOp (..), - TernaryOp (..), - Term (..), - showUntyped, - withSymbolSupported, - SomeTypedSymbol (..), - someTypedSymbol, - evaluateTerm, - introSupportedPrimConstraint, - SomeTerm (..), - SupportedPrim (..), - castTerm, - identity, - identityWithTypeRep, - pformat, - constructUnary, - constructBinary, - constructTernary, - conTerm, - symTerm, - ssymTerm, - isymTerm, - sinfosymTerm, - iinfosymTerm, - termSize, - termsSize, - extractSymbolicsTerm, - trueTerm, - falseTerm, - pattern BoolConTerm, - pattern TrueTerm, - pattern FalseTerm, - pattern BoolTerm, - pevalNotTerm, - pevalEqvTerm, - pevalNotEqvTerm, - pevalOrTerm, - pevalAndTerm, - pevalITETerm, - pevalImplyTerm, - pevalXorTerm, - unaryUnfoldOnce, - binaryUnfoldOnce, - pattern UnaryTermPatt, - pattern BinaryTermPatt, - pattern TernaryTermPatt, - PartialFun, - PartialRuleUnary, - TotalRuleUnary, - PartialRuleBinary, - TotalRuleBinary, - totalize, - totalize2, - UnaryPartialStrategy (..), - unaryPartial, - BinaryCommPartialStrategy (..), - BinaryPartialStrategy (..), - binaryPartial, - pattern NumConTerm, - pattern NumOrdConTerm, - pevalAddNumTerm, - pevalMinusNumTerm, - pevalUMinusNumTerm, - pevalAbsNumTerm, - pevalSignumNumTerm, - pevalTimesNumTerm, - pevalLtNumTerm, - pevalLeNumTerm, - pevalGtNumTerm, - pevalGeNumTerm, - pevalTabularFunApplyTerm, - pevalGeneralFunApplyTerm, - pevalDivIntegralTerm, - pevalModIntegralTerm, - pevalQuotIntegralTerm, - pevalRemIntegralTerm, - ) -where - -import Grisette.IR.SymPrim.Data.Prim.Helpers - ( pattern BinaryTermPatt, - pattern TernaryTermPatt, - pattern UnaryTermPatt, - ) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors - ( conTerm, - constructBinary, - constructTernary, - constructUnary, - iinfosymTerm, - isymTerm, - sinfosymTerm, - ssymTerm, - symTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.SomeTerm - ( SomeTerm (..), - ) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term - ( BinaryOp (..), - SomeTypedSymbol (..), - SupportedPrim (..), - Term (..), - TernaryOp (..), - UnaryOp (..), - showUntyped, - someTypedSymbol, - withSymbolSupported, - ) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermUtils - ( castTerm, - extractSymbolicsTerm, - identity, - identityWithTypeRep, - introSupportedPrimConstraint, - pformat, - termSize, - termsSize, - ) -import Grisette.IR.SymPrim.Data.Prim.Model (evaluateTerm) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool - ( falseTerm, - pevalAndTerm, - pevalEqvTerm, - pevalITETerm, - pevalImplyTerm, - pevalNotEqvTerm, - pevalNotTerm, - pevalOrTerm, - pevalXorTerm, - trueTerm, - pattern BoolConTerm, - pattern BoolTerm, - pattern FalseTerm, - pattern TrueTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.GeneralFun - ( pevalGeneralFunApplyTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.Integral - ( pevalDivIntegralTerm, - pevalModIntegralTerm, - pevalQuotIntegralTerm, - pevalRemIntegralTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.Num - ( pevalAbsNumTerm, - pevalAddNumTerm, - pevalGeNumTerm, - pevalGtNumTerm, - pevalLeNumTerm, - pevalLtNumTerm, - pevalMinusNumTerm, - pevalSignumNumTerm, - pevalTimesNumTerm, - pevalUMinusNumTerm, - pattern NumConTerm, - pattern NumOrdConTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.PartialEval - ( BinaryCommPartialStrategy (..), - BinaryPartialStrategy (..), - PartialFun, - PartialRuleBinary, - PartialRuleUnary, - TotalRuleBinary, - TotalRuleUnary, - UnaryPartialStrategy (..), - binaryPartial, - totalize, - totalize2, - unaryPartial, - ) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.TabularFun - ( pevalTabularFunApplyTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.Unfold - ( binaryUnfoldOnce, - unaryUnfoldOnce, - ) diff --git a/src/Grisette/Internal/SymPrim/AllSyms.hs b/src/Grisette/Internal/SymPrim/AllSyms.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/SymPrim/AllSyms.hs @@ -0,0 +1,329 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.SymPrim.AllSyms +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.SymPrim.AllSyms + ( symSize, + symsSize, + SomeSym (..), + AllSyms (..), + allSymsSize, + ) +where + +import Control.Monad.Except (ExceptT (ExceptT)) +import Control.Monad.Identity + ( Identity (Identity), + IdentityT (IdentityT), + ) +import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import qualified Data.ByteString as B +import Data.Functor.Sum (Sum) +import Data.Int (Int16, Int32, Int64, Int8) +import qualified Data.Text as T +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.Generics + ( Generic (Rep, from), + K1 (K1), + M1 (M1), + U1, + type (:*:) ((:*:)), + type (:+:) (L1, R1), + ) +import Generics.Deriving (Default (Default, unDefault)) +import Grisette.Internal.Core.Control.Exception + ( AssertionError, + VerificationConditions, + ) +import Grisette.Internal.SymPrim.Prim.SomeTerm + ( SomeTerm (SomeTerm), + ) +import Grisette.Internal.SymPrim.Prim.Term + ( LinkedRep (underlyingTerm), + ) +import Grisette.Internal.SymPrim.Prim.TermUtils + ( someTermsSize, + termSize, + termsSize, + ) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim +-- >>> import Grisette.Backend +-- >>> import Data.Proxy + +-- | Get the sum of the sizes of a list of symbolic terms. +-- Duplicate sub-terms are counted for only once. +-- +-- >>> symsSize [1, "a" :: SymInteger, "a" + 1 :: SymInteger] +-- 3 +symsSize :: forall con sym. (LinkedRep con sym) => [sym] -> Int +symsSize = termsSize . fmap (underlyingTerm @con) +{-# INLINE symsSize #-} + +-- | Get the size of a symbolic term. +-- Duplicate sub-terms are counted for only once. +-- +-- >>> symSize (1 :: SymInteger) +-- 1 +-- >>> symSize ("a" :: SymInteger) +-- 1 +-- >>> symSize ("a" + 1 :: SymInteger) +-- 3 +-- >>> symSize (("a" + 1) * ("a" + 1) :: SymInteger) +-- 4 +symSize :: forall con sym. (LinkedRep con sym) => sym -> Int +symSize = termSize . underlyingTerm @con +{-# INLINE symSize #-} + +-- | Some symbolic value with 'LinkedRep' constraint. +data SomeSym where + SomeSym :: (LinkedRep con sym) => sym -> SomeSym + +someUnderlyingTerm :: SomeSym -> SomeTerm +someUnderlyingTerm (SomeSym s) = SomeTerm $ underlyingTerm s + +someSymsSize :: [SomeSym] -> Int +someSymsSize = someTermsSize . fmap someUnderlyingTerm +{-# INLINE someSymsSize #-} + +-- | Extract all symbolic primitive values that are represented as SMT terms. +-- +-- __Note:__ This type class can be derived for algebraic data types. You may +-- need the @DerivingVia@ and @DerivingStrategies@ extenstions. +-- +-- > data X = ... deriving Generic deriving AllSyms via (Default X) +class AllSyms a where + -- | Convert a value to a list of symbolic primitive values. It should + -- prepend to an existing list of symbolic primitive values. + allSymsS :: a -> [SomeSym] -> [SomeSym] + allSymsS a l = allSyms a ++ l + + -- | Specialized 'allSymsS' that prepends to an empty list. + allSyms :: a -> [SomeSym] + allSyms a = allSymsS a [] + + {-# MINIMAL allSymsS | allSyms #-} + +-- | Get the total size of symbolic terms in a value. +-- Duplicate sub-terms are counted for only once. +-- +-- >>> allSymsSize ("a" :: SymInteger, "a" + "b" :: SymInteger, ("a" + "b") * "c" :: SymInteger) +-- 5 +allSymsSize :: (AllSyms a) => a -> Int +allSymsSize = someSymsSize . allSyms + +class AllSyms' a where + allSymsS' :: a c -> [SomeSym] -> [SomeSym] + +instance (Generic a, AllSyms' (Rep a)) => AllSyms (Default a) where + allSymsS = allSymsS' . from . unDefault + +instance AllSyms' U1 where + allSymsS' _ = id + +instance (AllSyms c) => AllSyms' (K1 i c) where + allSymsS' (K1 v) = allSymsS v + +instance (AllSyms' a) => AllSyms' (M1 i c a) where + allSymsS' (M1 v) = allSymsS' v + +instance (AllSyms' a, AllSyms' b) => AllSyms' (a :+: b) where + allSymsS' (L1 l) = allSymsS' l + allSymsS' (R1 r) = allSymsS' r + +instance (AllSyms' a, AllSyms' b) => AllSyms' (a :*: b) where + allSymsS' (a :*: b) = allSymsS' a . allSymsS' b + +#define CONCRETE_ALLSYMS(type) \ +instance AllSyms type where \ + allSymsS _ = id + +#if 1 +CONCRETE_ALLSYMS(Bool) +CONCRETE_ALLSYMS(Integer) +CONCRETE_ALLSYMS(Char) +CONCRETE_ALLSYMS(Int) +CONCRETE_ALLSYMS(Int8) +CONCRETE_ALLSYMS(Int16) +CONCRETE_ALLSYMS(Int32) +CONCRETE_ALLSYMS(Int64) +CONCRETE_ALLSYMS(Word) +CONCRETE_ALLSYMS(Word8) +CONCRETE_ALLSYMS(Word16) +CONCRETE_ALLSYMS(Word32) +CONCRETE_ALLSYMS(Word64) +CONCRETE_ALLSYMS(B.ByteString) +CONCRETE_ALLSYMS(T.Text) +#endif + +instance AllSyms () where + allSymsS _ = id + +-- Either +deriving via + (Default (Either a b)) + instance + ( AllSyms a, + AllSyms b + ) => + AllSyms (Either a b) + +-- Maybe +deriving via (Default (Maybe a)) instance (AllSyms a) => AllSyms (Maybe a) + +-- List +deriving via (Default [a]) instance (AllSyms a) => AllSyms [a] + +-- (,) +deriving via + (Default (a, b)) + instance + (AllSyms a, AllSyms b) => + AllSyms (a, b) + +-- (,,) +deriving via + (Default (a, b, c)) + instance + ( AllSyms a, + AllSyms b, + AllSyms c + ) => + AllSyms (a, b, c) + +-- (,,,) +deriving via + (Default (a, b, c, d)) + instance + ( AllSyms a, + AllSyms b, + AllSyms c, + AllSyms d + ) => + AllSyms (a, b, c, d) + +-- (,,,,) +deriving via + (Default (a, b, c, d, e)) + instance + ( AllSyms a, + AllSyms b, + AllSyms c, + AllSyms d, + AllSyms e + ) => + AllSyms (a, b, c, d, e) + +-- (,,,,,) +deriving via + (Default (a, b, c, d, e, f)) + instance + ( AllSyms a, + AllSyms b, + AllSyms c, + AllSyms d, + AllSyms e, + AllSyms f + ) => + AllSyms (a, b, c, d, e, f) + +-- (,,,,,,) +deriving via + (Default (a, b, c, d, e, f, g)) + instance + ( AllSyms a, + AllSyms b, + AllSyms c, + AllSyms d, + AllSyms e, + AllSyms f, + AllSyms g + ) => + AllSyms (a, b, c, d, e, f, g) + +-- (,,,,,,,) +deriving via + (Default (a, b, c, d, e, f, g, h)) + instance + ( AllSyms a, + AllSyms b, + AllSyms c, + AllSyms d, + AllSyms e, + AllSyms f, + AllSyms g, + AllSyms h + ) => + AllSyms ((,,,,,,,) a b c d e f g h) + +-- MaybeT +instance + (AllSyms (m (Maybe a))) => + AllSyms (MaybeT m a) + where + allSymsS (MaybeT v) = allSymsS v + +-- ExceptT +instance + (AllSyms (m (Either e a))) => + AllSyms (ExceptT e m a) + where + allSymsS (ExceptT v) = allSymsS v + +-- Sum +deriving via + (Default (Sum f g a)) + instance + (AllSyms (f a), AllSyms (g a)) => + AllSyms (Sum f g a) + +-- WriterT +instance + (AllSyms (m (a, s))) => + AllSyms (WriterLazy.WriterT s m a) + where + allSymsS (WriterLazy.WriterT v) = allSymsS v + +instance + (AllSyms (m (a, s))) => + AllSyms (WriterStrict.WriterT s m a) + where + allSymsS (WriterStrict.WriterT v) = allSymsS v + +-- Identity +instance (AllSyms a) => AllSyms (Identity a) where + allSymsS (Identity a) = allSymsS a + +-- IdentityT +instance (AllSyms (m a)) => AllSyms (IdentityT m a) where + allSymsS (IdentityT a) = allSymsS a + +-- VerificationConditions +deriving via (Default VerificationConditions) instance AllSyms VerificationConditions + +-- AssertionError +deriving via (Default AssertionError) instance AllSyms AssertionError diff --git a/src/Grisette/Internal/SymPrim/BV.hs b/src/Grisette/Internal/SymPrim/BV.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/SymPrim/BV.hs @@ -0,0 +1,496 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} + +-- | +-- Module : Grisette.Internal.SymPrim.BV +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.SymPrim.BV + ( BitwidthMismatch (..), + IntN (..), + WordN (..), + ) +where + +import Control.Applicative (Alternative ((<|>))) +import Control.DeepSeq (NFData) +import Control.Exception + ( ArithException (Overflow), + Exception (displayException), + throw, + ) +import Data.Bits + ( Bits + ( bit, + bitSize, + bitSizeMaybe, + clearBit, + complement, + isSigned, + popCount, + rotateL, + rotateR, + shiftL, + shiftR, + testBit, + xor, + zeroBits, + (.&.), + (.|.) + ), + FiniteBits (finiteBitSize), + ) +import Data.Hashable (Hashable) +import Data.Maybe (fromMaybe, isJust) +import Data.Proxy (Proxy (Proxy)) +import GHC.Enum + ( boundedEnumFrom, + boundedEnumFromThen, + predError, + succError, + toEnumError, + ) +import GHC.Generics (Generic) +import GHC.Read + ( Read (readListPrec, readPrec), + parens, + readListDefault, + readListPrecDefault, + readNumber, + ) +import GHC.Real ((%)) +import GHC.TypeNats + ( KnownNat, + Nat, + natVal, + type (+), + type (<=), + ) +import Grisette.Internal.Core.Data.Class.BitVector + ( SizedBV + ( sizedBVConcat, + sizedBVExt, + sizedBVSelect, + sizedBVSext, + sizedBVZext + ), + ) +import Grisette.Internal.Core.Data.Class.SignConversion + ( SignConversion (toSigned, toUnsigned), + ) +import Grisette.Internal.Core.Data.Class.SymRotate + ( DefaultFiniteBitsSymRotate (DefaultFiniteBitsSymRotate), + SymRotate, + ) +import Grisette.Internal.Core.Data.Class.SymShift + ( DefaultFiniteBitsSymShift (DefaultFiniteBitsSymShift), + SymShift, + ) +import Language.Haskell.TH.Syntax (Lift) +import Numeric (showHex, showIntAtBase) +import qualified Test.QuickCheck as QC +import Text.ParserCombinators.ReadP (string) +import Text.ParserCombinators.ReadPrec + ( ReadPrec, + get, + look, + pfail, + ) +import Text.Read (lift) +import qualified Text.Read.Lex as L + +data BitwidthMismatch = BitwidthMismatch + deriving (Show, Eq, Ord, Generic) + +instance Exception BitwidthMismatch where + displayException BitwidthMismatch = "Bit width does not match" + +-- | +-- Symbolic unsigned bit vectors. +newtype WordN (n :: Nat) = WordN {unWordN :: Integer} + deriving (Eq, Ord, Generic, Lift, Hashable, NFData) + +instance (KnownNat n, 1 <= n) => Show (WordN n) where + show (WordN w) = if (bitwidth `mod` 4) == 0 then hexRepPre ++ hexRep else binRepPre ++ binRep + where + bitwidth = natVal (Proxy :: Proxy n) + hexRepPre = "0x" ++ replicate (fromIntegral (bitwidth `div` 4) - length hexRep) '0' + hexRep = showHex w "" + binRepPre = "0b" ++ replicate (fromIntegral bitwidth - length binRep) '0' + binRep = showIntAtBase 2 (\x -> if x == 0 then '0' else '1') w "" + +convertInt :: (Num a) => L.Lexeme -> ReadPrec a +convertInt (L.Number n) + | Just i <- L.numberToInteger n = return (fromInteger i) +convertInt _ = pfail + +readBinary :: (Num a) => ReadPrec a +readBinary = parens $ do + r0 <- look + case r0 of + ('-' : _) -> do + _ <- get + negate <$> parens parse0b + _ -> parse0b + where + isDigit c = isJust (valDig c) + valDigit c = fromMaybe 0 (valDig c) + valDig '0' = Just 0 + valDig '1' = Just 1 + valDig _ = Nothing + parse0b = do + _ <- Text.Read.lift $ string "0b" + fromInteger <$> Text.Read.lift (L.readIntP 2 isDigit valDigit) + +instance (KnownNat n, 1 <= n) => Read (WordN n) where + readPrec = readNumber convertInt <|> readBinary + readListPrec = readListPrecDefault + readList = readListDefault + +-- | +-- Symbolic signed bit vectors. +newtype IntN (n :: Nat) = IntN {unIntN :: Integer} + deriving (Eq, Generic, Lift, Hashable, NFData) + +instance (KnownNat n, 1 <= n) => Show (IntN n) where + show (IntN w) = if (bitwidth `mod` 4) == 0 then hexRepPre ++ hexRep else binRepPre ++ binRep + where + bitwidth = natVal (Proxy :: Proxy n) + hexRepPre = "0x" ++ replicate (fromIntegral (bitwidth `div` 4) - length hexRep) '0' + hexRep = showHex w "" + binRepPre = "0b" ++ replicate (fromIntegral bitwidth - length binRep) '0' + binRep = showIntAtBase 2 (\x -> if x == 0 then '0' else '1') w "" + +instance (KnownNat n, 1 <= n) => Read (IntN n) where + readPrec = readNumber convertInt <|> readBinary + readListPrec = readListPrecDefault + readList = readListDefault + +instance (KnownNat n, 1 <= n) => Bits (WordN n) where + WordN a .&. WordN b = WordN (a .&. b) + WordN a .|. WordN b = WordN (a .|. b) + WordN a `xor` WordN b = WordN (a `xor` b) + complement a = maxBound `xor` a + + -- shift use default implementation + -- rotate use default implementation + zeroBits = WordN 0 + bit i + | i < 0 || i >= fromIntegral (natVal (Proxy :: Proxy n)) = zeroBits + | otherwise = WordN (bit i) + + -- setBit use default implementation + clearBit (WordN a) i = WordN (clearBit a i) + + -- complementBit use default implementation + testBit (WordN a) = testBit a + bitSizeMaybe = Just . finiteBitSize + bitSize = finiteBitSize + isSigned _ = False + shiftL w i | i >= finiteBitSize w = 0 + shiftL (WordN a) i = WordN (a `shiftL` i) .&. maxBound + + -- unsafeShiftL use default implementation + shiftR w i | i >= finiteBitSize w = 0 + shiftR (WordN a) i = WordN (a `shiftR` i) + + -- unsafeShiftR use default implementation + rotateL a 0 = a + rotateL (WordN a) k + | k >= n = rotateL (WordN a) (k `mod` n) + | otherwise = WordN $ l + h + where + n = fromIntegral $ natVal (Proxy :: Proxy n) + s = n - k + l = a `shiftR` s + h = (a - (l `shiftL` s)) `shiftL` k + rotateR a 0 = a + rotateR (WordN a) k + | k >= n = rotateR (WordN a) (k `mod` n) + | otherwise = WordN $ l + h + where + n = fromIntegral $ natVal (Proxy :: Proxy n) + s = n - k + l = a `shiftR` k + h = (a - (l `shiftL` k)) `shiftL` s + popCount (WordN n) = popCount n + +instance (KnownNat n, 1 <= n) => FiniteBits (WordN n) where + finiteBitSize _ = fromIntegral (natVal (Proxy :: Proxy n)) + +instance (KnownNat n, 1 <= n) => Bounded (WordN n) where + maxBound = WordN ((1 `shiftL` fromIntegral (natVal (Proxy :: Proxy n))) - 1) + minBound = WordN 0 + +instance (KnownNat n, 1 <= n) => Enum (WordN n) where + succ x + | x /= maxBound = x + 1 + | otherwise = succError $ "WordN " ++ show (natVal (Proxy :: Proxy n)) + pred x + | x /= minBound = x - 1 + | otherwise = predError $ "WordN " ++ show (natVal (Proxy :: Proxy n)) + toEnum i + | i >= 0 && toInteger i <= toInteger (maxBound :: WordN n) = WordN (toInteger i) + | otherwise = toEnumError ("WordN " ++ show (natVal (Proxy :: Proxy n))) i (minBound :: WordN n, maxBound :: WordN n) + fromEnum (WordN n) = fromEnum n + enumFrom = boundedEnumFrom + {-# INLINE enumFrom #-} + enumFromThen = boundedEnumFromThen + {-# INLINE enumFromThen #-} + +instance (KnownNat n, 1 <= n) => Real (WordN n) where + toRational (WordN n) = n % 1 + +instance (KnownNat n, 1 <= n) => Integral (WordN n) where + quot (WordN x) (WordN y) = WordN (x `quot` y) + rem (WordN x) (WordN y) = WordN (x `rem` y) + quotRem (WordN x) (WordN y) = case quotRem x y of + (q, r) -> (WordN q, WordN r) + div = quot + mod = rem + divMod = quotRem + toInteger (WordN n) = n + +instance (KnownNat n, 1 <= n) => Num (WordN n) where + WordN x + WordN y = WordN (x + y) .&. maxBound + WordN x * WordN y = WordN (x * y) .&. maxBound + WordN x - WordN y + | x >= y = WordN (x - y) + | otherwise = WordN ((1 `shiftL` fromIntegral (natVal (Proxy :: Proxy n))) + x - y) + negate (WordN 0) = WordN 0 + negate a = complement a + WordN 1 + abs x = x + signum (WordN 0) = 0 + signum _ = 1 + fromInteger !x + | x == 0 = WordN 0 + | x > 0 = WordN (x .&. unWordN (maxBound :: WordN n)) + | otherwise = -fromInteger (-x) + +instance (KnownNat n, 1 <= n) => QC.Arbitrary (WordN n) where + arbitrary = QC.arbitrarySizedBoundedIntegral + + -- QC.shrinkIntegral assumes that 2 is representable by the number, which is + -- not the case for 1-bit bit vector. + shrink i + | i == 0 = [] + | i == 1 = [0] + | otherwise = QC.shrinkIntegral i + +minusOneIntN :: forall proxy n. (KnownNat n) => proxy n -> IntN n +minusOneIntN _ = IntN (1 `shiftL` fromIntegral (natVal (Proxy :: Proxy n)) - 1) + +instance (KnownNat n, 1 <= n) => Bits (IntN n) where + IntN a .&. IntN b = IntN (a .&. b) + IntN a .|. IntN b = IntN (a .|. b) + IntN a `xor` IntN b = IntN (a `xor` b) + complement a = minusOneIntN (Proxy :: Proxy n) `xor` a + + -- shift use default implementation + -- rotate use default implementation + zeroBits = IntN 0 + bit i = IntN (unWordN (bit i :: WordN n)) + + -- setBit use default implementation + clearBit (IntN a) i = IntN (clearBit a i) + + -- complementBit use default implementation + testBit (IntN a) = testBit a + bitSizeMaybe = Just . finiteBitSize + bitSize = finiteBitSize + isSigned _ = True + + shiftL (IntN a) i = IntN (unWordN $ (WordN a :: WordN n) `shiftL` i) + + -- unsafeShiftL use default implementation + shiftR i 0 = i + shiftR (IntN i) k + | k >= n = if b then IntN (maxi - 1) else IntN 0 + | otherwise = if b then IntN (maxi - noi + (i `shiftR` k)) else IntN (i `shiftR` k) + where + b = testBit i (n - 1) + n = fromIntegral $ natVal (Proxy :: Proxy n) + maxi = (1 :: Integer) `shiftL` n + noi = (1 :: Integer) `shiftL` (n - k) + + -- unsafeShiftR use default implementation + rotateL (IntN i) k = IntN $ unWordN $ rotateL (WordN i :: WordN n) k + rotateR (IntN i) k = IntN $ unWordN $ rotateR (WordN i :: WordN n) k + popCount (IntN i) = popCount i + +instance (KnownNat n, 1 <= n) => FiniteBits (IntN n) where + finiteBitSize _ = fromIntegral (natVal (Proxy :: Proxy n)) + +instance (KnownNat n, 1 <= n) => Bounded (IntN n) where + maxBound = IntN (1 `shiftL` (fromIntegral (natVal (Proxy :: Proxy n)) - 1) - 1) + minBound = maxBound + 1 + +instance (KnownNat n, 1 <= n) => Enum (IntN n) where + succ x + | x /= maxBound = x + 1 + | otherwise = succError $ "IntN " ++ show (natVal (Proxy :: Proxy n)) + pred x + | x /= minBound = x - 1 + | otherwise = predError $ "IntN " ++ show (natVal (Proxy :: Proxy n)) + toEnum i + | i >= fromIntegral (minBound :: IntN n) && i <= fromIntegral (maxBound :: IntN n) = fromIntegral i + | otherwise = toEnumError ("IntN " ++ show (natVal (Proxy :: Proxy n))) i (minBound :: WordN n, maxBound :: WordN n) + fromEnum = fromEnum . toInteger + enumFrom = boundedEnumFrom + {-# INLINE enumFrom #-} + enumFromThen = boundedEnumFromThen + {-# INLINE enumFromThen #-} + +instance (KnownNat n, 1 <= n) => Real (IntN n) where + toRational i = toInteger i % 1 + +instance (KnownNat n, 1 <= n) => Integral (IntN n) where + quot x y = + if x == minBound && y == -1 + then throw Overflow + else fromInteger (toInteger x `quot` toInteger y) + rem x y = fromInteger (toInteger x `rem` toInteger y) + quotRem x y = + if x == minBound && y == -1 + then throw Overflow + else case quotRem (toInteger x) (toInteger y) of + (q, r) -> (fromInteger q, fromInteger r) + div x y = + if x == minBound && y == -1 + then throw Overflow + else fromInteger (toInteger x `div` toInteger y) + mod x y = fromInteger (toInteger x `mod` toInteger y) + divMod x y = + if x == minBound && y == -1 + then throw Overflow + else case divMod (toInteger x) (toInteger y) of + (q, r) -> (fromInteger q, fromInteger r) + toInteger i@(IntN n) = case signum i of + 0 -> 0 + -1 -> + let x = negate i + in if signum x == -1 then -n else negate (toInteger x) + 1 -> n + _ -> undefined + +instance (KnownNat n, 1 <= n) => Num (IntN n) where + IntN x + IntN y = IntN (x + y) .&. minusOneIntN (Proxy :: Proxy n) + IntN x * IntN y = IntN (x * y) .&. minusOneIntN (Proxy :: Proxy n) + IntN x - IntN y + | x >= y = IntN (x - y) + | otherwise = IntN ((1 `shiftL` fromIntegral (natVal (Proxy :: Proxy n))) + x - y) + negate (IntN 0) = IntN 0 + negate a = complement a + IntN 1 + abs x = if testBit x (fromIntegral $ natVal (Proxy :: Proxy n) - 1) then negate x else x + signum (IntN 0) = IntN 0 + signum i = if testBit i (fromIntegral $ natVal (Proxy :: Proxy n) - 1) then -1 else 1 + fromInteger !x = IntN $ if v >= 0 then v else (1 `shiftL` n) + v + where + v = unWordN (fromInteger (x + maxn) :: WordN n) - maxn + n = fromIntegral (natVal (Proxy :: Proxy n)) + maxn = 1 `shiftL` (n - 1) - 1 + +instance (KnownNat n, 1 <= n) => Ord (IntN n) where + IntN a <= IntN b + | as && not bs = True + | not as && bs = False + | otherwise = a <= b + where + n = fromIntegral (natVal (Proxy :: Proxy n)) + as = testBit a (n - 1) + bs = testBit b (n - 1) + +instance (KnownNat n, 1 <= n) => QC.Arbitrary (IntN n) where + arbitrary = QC.arbitrarySizedBoundedIntegral + + -- QC.shrinkIntegral assumes that 2 is representable by the number, which is + -- not the case for 1-bit bit vector. + shrink i + | i == 0 = [] + | i == 1 = [0] + | otherwise = QC.shrinkIntegral i + +instance SizedBV WordN where + sizedBVConcat :: forall l r. (KnownNat l, KnownNat r, 1 <= l, 1 <= r) => WordN l -> WordN r -> WordN (l + r) + sizedBVConcat (WordN a) (WordN b) = WordN ((a `shiftL` fromIntegral (natVal (Proxy :: Proxy r))) .|. b) + sizedBVZext _ (WordN v) = WordN v + sizedBVSext :: forall l r proxy. (KnownNat l, KnownNat r, 1 <= l, KnownNat r, l <= r) => proxy r -> WordN l -> WordN r + sizedBVSext pr (WordN v) = if s then WordN (maxi - noi + v) else WordN v + where + r = fromIntegral $ natVal pr + l = fromIntegral $ natVal (Proxy :: Proxy l) + s = testBit v (l - 1) + maxi = (1 :: Integer) `shiftL` r + noi = (1 :: Integer) `shiftL` l + sizedBVExt = sizedBVZext + sizedBVSelect :: + forall n ix w p q. + (KnownNat n, KnownNat ix, KnownNat w, 1 <= n, 1 <= w, ix + w <= n) => + p ix -> + q w -> + WordN n -> + WordN w + sizedBVSelect pix pw (WordN v) = WordN ((v `shiftR` ix) .&. mask) + where + ix = fromIntegral $ natVal pix + w = fromIntegral $ natVal pw + mask = (1 `shiftL` w) - 1 + +instance SizedBV IntN where + sizedBVConcat :: forall l r. (KnownNat l, KnownNat r, 1 <= l, 1 <= r) => IntN l -> IntN r -> IntN (l + r) + sizedBVConcat (IntN a) (IntN b) = IntN $ unWordN $ sizedBVConcat (WordN a :: WordN l) (WordN b :: WordN r) + sizedBVZext _ (IntN v) = IntN v + sizedBVSext :: forall l r proxy. (KnownNat l, KnownNat r, 1 <= l, KnownNat r, l <= r) => proxy r -> IntN l -> IntN r + sizedBVSext pr (IntN v) = IntN $ unWordN $ sizedBVSext pr (WordN v :: WordN l) + sizedBVExt = sizedBVSext + sizedBVSelect :: + forall n ix w p q. + (KnownNat n, KnownNat ix, KnownNat w, 1 <= n, 1 <= w, ix + w <= n) => + p ix -> + q w -> + IntN n -> + IntN w + sizedBVSelect pix pw (IntN v) = IntN $ unWordN $ sizedBVSelect pix pw (WordN v :: WordN n) + +instance (KnownNat n, 1 <= n) => SignConversion (WordN n) (IntN n) where + toSigned (WordN i) = IntN i + toUnsigned (IntN i) = WordN i + +deriving via + (DefaultFiniteBitsSymShift (IntN n)) + instance + (KnownNat n, 1 <= n) => SymShift (IntN n) + +deriving via + (DefaultFiniteBitsSymShift (WordN n)) + instance + (KnownNat n, 1 <= n) => SymShift (WordN n) + +deriving via + (DefaultFiniteBitsSymRotate (IntN n)) + instance + (KnownNat n, 1 <= n) => SymRotate (IntN n) + +deriving via + (DefaultFiniteBitsSymRotate (WordN n)) + instance + (KnownNat n, 1 <= n) => SymRotate (WordN n) diff --git a/src/Grisette/Internal/SymPrim/GeneralFun.hs b/src/Grisette/Internal/SymPrim/GeneralFun.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/SymPrim/GeneralFun.hs @@ -0,0 +1,686 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Eta reduce" #-} + +-- | +-- Module : Grisette.Internal.SymPrim.GeneralFun +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.SymPrim.GeneralFun + ( type (-->) (..), + buildGeneralFun, + substTerm, + ) +where + +import Control.DeepSeq (NFData (rnf)) +import Data.Bifunctor (Bifunctor (second)) +import Data.Foldable (Foldable (foldl')) +import Data.Hashable (Hashable (hashWithSalt)) +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.MemoUtils (htmemo) +import Grisette.Internal.Core.Data.Symbol + ( Symbol (IndexedSymbol, SimpleSymbol), + withInfo, + ) +import Grisette.Internal.SymPrim.Prim.Internal.PartialEval (totalize2) +import Grisette.Internal.SymPrim.Prim.Internal.Term + ( SBVRep, + SupportedPrim (parseSMTModelResult, sbvEq), + partitionCVArg, + ) +import Grisette.Internal.SymPrim.Prim.SomeTerm (SomeTerm (SomeTerm)) +import Grisette.Internal.SymPrim.Prim.Term + ( BinaryOp (pevalBinary), + LinkedRep (underlyingTerm, wrapTerm), + NonFuncSBVBaseType, + PEvalApplyTerm (pevalApplyTerm, sbvApplyTerm), + PEvalBVSignConversionTerm (pevalBVToSignedTerm, pevalBVToUnsignedTerm), + PEvalBVTerm (pevalBVConcatTerm, pevalBVExtendTerm, pevalBVSelectTerm), + PEvalBitwiseTerm + ( pevalAndBitsTerm, + pevalComplementBitsTerm, + pevalOrBitsTerm, + pevalXorBitsTerm + ), + PEvalDivModIntegralTerm + ( pevalDivIntegralTerm, + pevalModIntegralTerm + ), + PEvalNumTerm + ( pevalAbsNumTerm, + pevalAddNumTerm, + pevalMulNumTerm, + pevalNegNumTerm, + pevalSignumNumTerm + ), + PEvalOrdTerm (pevalLeOrdTerm, pevalLtOrdTerm), + PEvalRotateTerm (pevalRotateRightTerm), + PEvalShiftTerm (pevalShiftLeftTerm, pevalShiftRightTerm), + SBVType, + SupportedNonFuncPrim (withNonFuncPrim), + SupportedPrim + ( conSBVTerm, + defaultValue, + pevalITETerm, + symSBVName, + symSBVTerm, + withPrim + ), + SupportedPrimConstraint (PrimConstraint), + Term + ( AbsNumTerm, + AddNumTerm, + AndBitsTerm, + AndTerm, + ApplyTerm, + BVConcatTerm, + BVExtendTerm, + BVSelectTerm, + BinaryTerm, + ComplementBitsTerm, + ConTerm, + DivIntegralTerm, + EqTerm, + ITETerm, + LeOrdTerm, + LtOrdTerm, + ModIntegralTerm, + MulNumTerm, + NegNumTerm, + NotTerm, + OrBitsTerm, + OrTerm, + QuotIntegralTerm, + RemIntegralTerm, + RotateLeftTerm, + RotateRightTerm, + ShiftLeftTerm, + ShiftRightTerm, + SignumNumTerm, + SymTerm, + TernaryTerm, + ToSignedTerm, + ToUnsignedTerm, + UnaryTerm, + XorBitsTerm + ), + TernaryOp (pevalTernary), + TypedSymbol (TypedSymbol, unTypedSymbol), + UnaryOp (pevalUnary), + applyTerm, + conTerm, + pevalAndTerm, + pevalDefaultEqTerm, + pevalEqTerm, + pevalITEBasicTerm, + pevalNotTerm, + pevalOrTerm, + pevalQuotIntegralTerm, + pevalRemIntegralTerm, + pevalRotateLeftTerm, + pformat, + someTypedSymbol, + symTerm, + translateTypeError, + ) +import Language.Haskell.TH.Syntax (Lift (liftTyped)) +import Type.Reflection + ( TypeRep, + eqTypeRep, + typeRep, + pattern App, + type (:~~:) (HRefl), + ) +import Unsafe.Coerce (unsafeCoerce) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim + +-- | General symbolic function type. Use the '#' operator to apply the function. +-- Note that this function should be applied to symbolic values only. It is by +-- itself already a symbolic value, but can be considered partially concrete +-- as the function body is specified. Use 'Grisette.SymPrim.SymPrim.-~>' +-- for uninterpreted general symbolic functions. +-- +-- The result would be partially evaluated. +-- +-- >>> :set -XOverloadedStrings +-- >>> :set -XTypeOperators +-- >>> let f = ("x" :: TypedSymbol Integer) --> ("x" + 1 + "y" :: SymInteger) :: Integer --> Integer +-- >>> f # 1 -- 1 has the type SymInteger +-- (+ 2 y) +-- >>> f # "a" -- "a" has the type SymInteger +-- (+ 1 (+ a y)) +data (-->) a b where + GeneralFun :: + (SupportedPrim a, SupportedPrim b) => + TypedSymbol a -> + Term b -> + a --> b + +instance (LinkedRep a sa, LinkedRep b sb) => Function (a --> b) sa sb where + (GeneralFun s t) # x = wrapTerm $ substTerm s (underlyingTerm x) t + +infixr 0 --> + +buildGeneralFun :: + (SupportedPrim a, SupportedPrim b) => TypedSymbol a -> Term b -> a --> b +buildGeneralFun arg v = + GeneralFun + (TypedSymbol newarg) + (substTerm arg (symTerm newarg) 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) + +instance Eq (a --> b) where + GeneralFun sym1 tm1 == GeneralFun sym2 tm2 = sym1 == sym2 && tm1 == tm2 + +instance Show (a --> b) where + show (GeneralFun sym tm) = "\\(" ++ show sym ++ ") -> " ++ pformat tm + +instance Lift (a --> b) where + liftTyped (GeneralFun sym tm) = [||GeneralFun sym tm||] + +instance Hashable (a --> b) where + s `hashWithSalt` (GeneralFun sym tm) = s `hashWithSalt` sym `hashWithSalt` tm + +instance NFData (a --> b) where + rnf (GeneralFun sym tm) = rnf sym `seq` rnf tm + +instance + (SupportedNonFuncPrim a, SupportedPrim b) => + SupportedPrimConstraint (a --> b) + where + type + PrimConstraint n (a --> b) = + ( SupportedNonFuncPrim a, + SupportedPrim b, + PrimConstraint n b, + SBVType n (a --> b) ~ (SBV.SBV (NonFuncSBVBaseType n a) -> SBVType n b) + ) + +instance + (SupportedNonFuncPrim a, SupportedPrim b) => + SBVRep (a --> b) + where + type + SBVType n (a --> b) = + SBV.SBV (NonFuncSBVBaseType n a) -> + SBVType n b + +parseGeneralFunSMTModelResult :: + forall a b. + (SupportedNonFuncPrim a, SupportedPrim b) => + Int -> + ([([SBVD.CV], SBVD.CV)], SBVD.CV) -> + a --> b +parseGeneralFunSMTModelResult level (l, s) = + let sym = IndexedSymbol "arg" level + funs = + second + (\r -> parseSMTModelResult (level + 1) (r, s)) + <$> partitionCVArg @a l + def = parseSMTModelResult (level + 1) ([], s) + body = + foldl' + ( \acc (v, f) -> + pevalITETerm + (pevalEqTerm (symTerm sym) (conTerm v)) + (conTerm f) + acc + ) + (conTerm def) + funs + in buildGeneralFun (TypedSymbol sym) body + +instance + (SupportedNonFuncPrim a, SupportedNonFuncPrim b) => + SupportedPrim (a --> b) + where + defaultValue = buildGeneralFun (TypedSymbol "a") (conTerm defaultValue) + pevalITETerm = pevalITEBasicTerm + pevalEqTerm = pevalDefaultEqTerm + conSBVTerm _ _ = + translateTypeError + ( Just $ + "BUG. Please send a bug report. GeneralFun must have already been " + <> "partial evaluated away before reaching this point." + ) + (typeRep @(a --> b)) + symSBVName _ num = "gfunc2_" <> show num + symSBVTerm (p :: proxy n) name = + withNonFuncPrim @a p $ + withNonFuncPrim @b p $ + return $ + SBV.uninterpret name + withPrim p r = withNonFuncPrim @a p $ withNonFuncPrim @b p r + sbvEq _ _ = + translateTypeError + ( Just $ + "BUG. Please send a bug report. GeneralFun is not supported for " + <> "equality comparison." + ) + (typeRep @(a --> b)) + parseSMTModelResult = parseGeneralFunSMTModelResult + +instance + {-# OVERLAPPING #-} + ( SupportedNonFuncPrim a, + SupportedNonFuncPrim b, + SupportedNonFuncPrim c, + SupportedPrim a, + SupportedPrim b, + SupportedPrim c + ) => + SupportedPrim (a --> b --> c) + where + defaultValue = buildGeneralFun (TypedSymbol "a") (conTerm defaultValue) + pevalITETerm = pevalITEBasicTerm + pevalEqTerm = pevalDefaultEqTerm + conSBVTerm _ _ = + translateTypeError + ( Just $ + "BUG. Please send a bug report. GeneralFun must have already been " + <> "partial evaluated away before reaching this point." + ) + (typeRep @(a --> b --> c)) + symSBVName _ num = "gfunc3_" <> show num + symSBVTerm (p :: proxy n) name = + withNonFuncPrim @a p $ + withNonFuncPrim @b p $ + withNonFuncPrim @c p $ + return $ + SBV.uninterpret name + withPrim p r = + withNonFuncPrim @a p $ + withNonFuncPrim @b p $ + withNonFuncPrim @c p r + sbvEq _ _ = + translateTypeError + ( Just $ + "BUG. Please send a bug report. GeneralFun is not supported for " + <> "equality comparison." + ) + (typeRep @(a --> b --> c)) + parseSMTModelResult = parseGeneralFunSMTModelResult + +instance + {-# OVERLAPPING #-} + ( SupportedNonFuncPrim a, + SupportedNonFuncPrim b, + SupportedNonFuncPrim c, + SupportedNonFuncPrim d, + SupportedPrim a, + SupportedPrim b, + SupportedPrim c, + SupportedPrim d + ) => + SupportedPrim (a --> b --> c --> d) + where + defaultValue = buildGeneralFun (TypedSymbol "a") (conTerm defaultValue) + pevalITETerm = pevalITEBasicTerm + pevalEqTerm = pevalDefaultEqTerm + conSBVTerm _ _ = + translateTypeError + ( Just $ + "BUG. Please send a bug report. GeneralFun must have already been " + <> "partial evaluated away before reaching this point." + ) + (typeRep @(a --> b --> c --> d)) + symSBVName _ num = "gfunc4_" <> show num + symSBVTerm (p :: proxy n) name = + withNonFuncPrim @a p $ + withNonFuncPrim @b p $ + withNonFuncPrim @c p $ + withNonFuncPrim @d p $ + return $ + SBV.uninterpret name + withPrim p r = + withNonFuncPrim @a p $ + withNonFuncPrim @b p $ + withNonFuncPrim @c p $ + withNonFuncPrim @d p r + sbvEq _ _ = + translateTypeError + ( Just $ + "BUG. Please send a bug report. GeneralFun is not supported for " + <> "equality comparison." + ) + (typeRep @(a --> b --> c --> d)) + parseSMTModelResult = parseGeneralFunSMTModelResult + +instance + {-# OVERLAPPING #-} + ( SupportedNonFuncPrim a, + SupportedNonFuncPrim b, + SupportedNonFuncPrim c, + SupportedNonFuncPrim d, + SupportedNonFuncPrim e, + SupportedPrim a, + SupportedPrim b, + SupportedPrim c, + SupportedPrim d, + SupportedPrim e + ) => + SupportedPrim (a --> b --> c --> d --> e) + where + defaultValue = buildGeneralFun (TypedSymbol "a") (conTerm defaultValue) + pevalITETerm = pevalITEBasicTerm + pevalEqTerm = pevalDefaultEqTerm + conSBVTerm _ _ = + translateTypeError + ( Just $ + "BUG. Please send a bug report. GeneralFun must have already been " + <> "partial evaluated away before reaching this point." + ) + (typeRep @(a --> b --> c --> d --> e)) + symSBVName _ num = "gfunc5_" <> show num + symSBVTerm (p :: proxy n) name = + withNonFuncPrim @a p $ + withNonFuncPrim @b p $ + withNonFuncPrim @c p $ + withNonFuncPrim @d p $ + withNonFuncPrim @e p $ + return $ + SBV.uninterpret name + withPrim p r = + withNonFuncPrim @a p $ + withNonFuncPrim @b p $ + withNonFuncPrim @c p $ + withNonFuncPrim @d p $ + withNonFuncPrim @e p r + sbvEq _ _ = + translateTypeError + ( Just $ + "BUG. Please send a bug report. GeneralFun is not supported for " + <> "equality comparison." + ) + (typeRep @(a --> b --> c --> d --> e)) + parseSMTModelResult = parseGeneralFunSMTModelResult + +instance + {-# OVERLAPPING #-} + ( SupportedNonFuncPrim a, + SupportedNonFuncPrim b, + SupportedNonFuncPrim c, + SupportedNonFuncPrim d, + SupportedNonFuncPrim e, + SupportedNonFuncPrim f, + SupportedPrim a, + SupportedPrim b, + SupportedPrim c, + SupportedPrim d, + SupportedPrim e, + SupportedPrim f + ) => + SupportedPrim (a --> b --> c --> d --> e --> f) + where + defaultValue = buildGeneralFun (TypedSymbol "a") (conTerm defaultValue) + pevalITETerm = pevalITEBasicTerm + pevalEqTerm = pevalDefaultEqTerm + conSBVTerm _ _ = + translateTypeError + ( Just $ + "BUG. Please send a bug report. GeneralFun must have already been " + <> "partial evaluated away before reaching this point." + ) + (typeRep @(a --> b --> c --> d --> e --> f)) + symSBVName _ num = "gfunc6_" <> show num + symSBVTerm (p :: proxy n) name = + withNonFuncPrim @a p $ + withNonFuncPrim @b p $ + withNonFuncPrim @c p $ + withNonFuncPrim @d p $ + withNonFuncPrim @e p $ + withNonFuncPrim @f p $ + return $ + SBV.uninterpret name + withPrim p r = + withNonFuncPrim @a p $ + withNonFuncPrim @b p $ + withNonFuncPrim @c p $ + withNonFuncPrim @d p $ + withNonFuncPrim @e p $ + withNonFuncPrim @f p r + sbvEq _ _ = + translateTypeError + ( Just $ + "BUG. Please send a bug report. GeneralFun is not supported for " + <> "equality comparison." + ) + (typeRep @(a --> b --> c --> d --> e --> f)) + parseSMTModelResult = parseGeneralFunSMTModelResult + +instance + {-# OVERLAPPING #-} + ( SupportedNonFuncPrim a, + SupportedNonFuncPrim b, + SupportedNonFuncPrim c, + SupportedNonFuncPrim d, + SupportedNonFuncPrim e, + SupportedNonFuncPrim f, + SupportedNonFuncPrim g, + SupportedPrim a, + SupportedPrim b, + SupportedPrim c, + SupportedPrim d, + SupportedPrim e, + SupportedPrim f, + SupportedPrim g + ) => + SupportedPrim (a --> b --> c --> d --> e --> f --> g) + where + defaultValue = buildGeneralFun (TypedSymbol "a") (conTerm defaultValue) + pevalITETerm = pevalITEBasicTerm + pevalEqTerm = pevalDefaultEqTerm + conSBVTerm _ _ = + translateTypeError + ( Just $ + "BUG. Please send a bug report. GeneralFun must have already been " + <> "partial evaluated away before reaching this point." + ) + (typeRep @(a --> b --> c --> d --> e --> f --> g)) + symSBVName _ num = "gfunc7_" <> show num + symSBVTerm (p :: proxy n) name = + withNonFuncPrim @a p $ + withNonFuncPrim @b p $ + withNonFuncPrim @c p $ + withNonFuncPrim @d p $ + withNonFuncPrim @e p $ + withNonFuncPrim @f p $ + withNonFuncPrim @g p $ + return $ + SBV.uninterpret name + withPrim p r = + withNonFuncPrim @a p $ + withNonFuncPrim @b p $ + withNonFuncPrim @c p $ + withNonFuncPrim @d p $ + withNonFuncPrim @e p $ + withNonFuncPrim @f p $ + withNonFuncPrim @g p r + sbvEq _ _ = + translateTypeError + ( Just $ + "BUG. Please send a bug report. GeneralFun is not supported for " + <> "equality comparison." + ) + (typeRep @(a --> b --> c --> d --> e --> f --> g)) + parseSMTModelResult = parseGeneralFunSMTModelResult + +instance + {-# OVERLAPPING #-} + ( SupportedNonFuncPrim a, + SupportedNonFuncPrim b, + SupportedNonFuncPrim c, + SupportedNonFuncPrim d, + SupportedNonFuncPrim e, + SupportedNonFuncPrim f, + SupportedNonFuncPrim g, + SupportedNonFuncPrim h, + SupportedPrim a, + SupportedPrim b, + SupportedPrim c, + SupportedPrim d, + SupportedPrim e, + SupportedPrim f, + SupportedPrim g, + SupportedPrim h + ) => + SupportedPrim (a --> b --> c --> d --> e --> f --> g --> h) + where + defaultValue = buildGeneralFun (TypedSymbol "a") (conTerm defaultValue) + pevalITETerm = pevalITEBasicTerm + pevalEqTerm = pevalDefaultEqTerm + conSBVTerm _ _ = + translateTypeError + ( Just $ + "BUG. Please send a bug report. GeneralFun must have already been " + <> "partial evaluated away before reaching this point." + ) + (typeRep @(a --> b --> c --> d --> e --> f --> g --> h)) + symSBVName _ num = "gfunc8_" <> show num + symSBVTerm (p :: proxy n) name = + withNonFuncPrim @a p $ + withNonFuncPrim @b p $ + withNonFuncPrim @c p $ + withNonFuncPrim @d p $ + withNonFuncPrim @e p $ + withNonFuncPrim @f p $ + withNonFuncPrim @g p $ + withNonFuncPrim @h p $ + return $ + SBV.uninterpret name + withPrim p r = + withNonFuncPrim @a p $ + withNonFuncPrim @b p $ + withNonFuncPrim @c p $ + withNonFuncPrim @d p $ + withNonFuncPrim @e p $ + withNonFuncPrim @f p $ + withNonFuncPrim @g p $ + withNonFuncPrim @h p r + sbvEq _ _ = + translateTypeError + ( Just $ + "BUG. Please send a bug report. GeneralFun is not supported for " + <> "equality comparison." + ) + (typeRep @(a --> b --> c --> d --> e --> f --> g --> h)) + parseSMTModelResult = parseGeneralFunSMTModelResult + +pevalGeneralFunApplyTerm :: + ( SupportedNonFuncPrim a, + SupportedPrim b, + SupportedPrim (a --> b) + ) => + Term (a --> b) -> + Term a -> + Term b +pevalGeneralFunApplyTerm = totalize2 doPevalApplyTerm applyTerm + where + doPevalApplyTerm (ConTerm _ (GeneralFun arg tm)) v = + Just $ substTerm arg v tm + doPevalApplyTerm (ITETerm _ c l r) v = + return $ pevalITETerm c (pevalApplyTerm l v) (pevalApplyTerm r v) + doPevalApplyTerm _ _ = Nothing + +instance + ( SupportedPrim (a --> b), + SupportedNonFuncPrim a, + SupportedPrim b + ) => + PEvalApplyTerm (a --> b) a b + where + pevalApplyTerm = pevalGeneralFunApplyTerm + sbvApplyTerm p f a = + withPrim @(a --> b) p $ withNonFuncPrim @a p $ f a + +substTerm :: forall a b. (SupportedPrim a, SupportedPrim b) => TypedSymbol a -> Term a -> Term b -> Term b +substTerm sym term = gov + where + gov :: (SupportedPrim x) => Term x -> Term x + gov b = case go (SomeTerm b) of + SomeTerm v -> unsafeCoerce v + go :: SomeTerm -> SomeTerm + go = htmemo $ \stm@(SomeTerm (tm :: Term v)) -> + case tm of + ConTerm _ cv -> case (typeRep :: TypeRep v) of + App (App gf _) _ -> + case eqTypeRep gf (typeRep @(-->)) of + Just HRefl -> case cv of + GeneralFun sym1 tm1 -> + if someTypedSymbol sym1 == someTypedSymbol sym + then stm + else SomeTerm $ conTerm $ GeneralFun sym1 (gov tm1) + Nothing -> stm + _ -> stm + SymTerm _ ts -> SomeTerm $ if someTypedSymbol ts == someTypedSymbol sym then unsafeCoerce term else tm + UnaryTerm _ tag te -> SomeTerm $ pevalUnary tag (gov te) + BinaryTerm _ tag te te' -> SomeTerm $ pevalBinary tag (gov te) (gov te') + TernaryTerm _ tag op1 op2 op3 -> SomeTerm $ pevalTernary tag (gov op1) (gov op2) (gov op3) + NotTerm _ op -> SomeTerm $ pevalNotTerm (gov op) + OrTerm _ op1 op2 -> SomeTerm $ pevalOrTerm (gov op1) (gov op2) + AndTerm _ op1 op2 -> SomeTerm $ pevalAndTerm (gov op1) (gov op2) + EqTerm _ op1 op2 -> SomeTerm $ pevalEqTerm (gov op1) (gov op2) + ITETerm _ c op1 op2 -> SomeTerm $ pevalITETerm (gov c) (gov op1) (gov op2) + AddNumTerm _ op1 op2 -> SomeTerm $ pevalAddNumTerm (gov op1) (gov op2) + NegNumTerm _ op -> SomeTerm $ pevalNegNumTerm (gov op) + MulNumTerm _ op1 op2 -> SomeTerm $ pevalMulNumTerm (gov op1) (gov op2) + AbsNumTerm _ op -> SomeTerm $ pevalAbsNumTerm (gov op) + SignumNumTerm _ op -> SomeTerm $ pevalSignumNumTerm (gov op) + LtOrdTerm _ op1 op2 -> SomeTerm $ pevalLtOrdTerm (gov op1) (gov op2) + LeOrdTerm _ op1 op2 -> SomeTerm $ pevalLeOrdTerm (gov op1) (gov op2) + AndBitsTerm _ op1 op2 -> SomeTerm $ pevalAndBitsTerm (gov op1) (gov op2) + OrBitsTerm _ op1 op2 -> SomeTerm $ pevalOrBitsTerm (gov op1) (gov op2) + XorBitsTerm _ op1 op2 -> SomeTerm $ pevalXorBitsTerm (gov op1) (gov op2) + ComplementBitsTerm _ op -> SomeTerm $ pevalComplementBitsTerm (gov op) + ShiftLeftTerm _ op n -> SomeTerm $ pevalShiftLeftTerm (gov op) (gov n) + RotateLeftTerm _ op n -> SomeTerm $ pevalRotateLeftTerm (gov op) (gov n) + ShiftRightTerm _ op n -> SomeTerm $ pevalShiftRightTerm (gov op) (gov n) + RotateRightTerm _ op n -> SomeTerm $ pevalRotateRightTerm (gov op) (gov n) + ToSignedTerm _ op -> SomeTerm $ pevalBVToSignedTerm op + ToUnsignedTerm _ op -> SomeTerm $ pevalBVToUnsignedTerm op + BVConcatTerm _ op1 op2 -> SomeTerm $ pevalBVConcatTerm (gov op1) (gov op2) + BVSelectTerm _ ix w op -> SomeTerm $ pevalBVSelectTerm ix w (gov op) + BVExtendTerm _ n signed op -> SomeTerm $ pevalBVExtendTerm n signed (gov op) + ApplyTerm _ f op -> SomeTerm $ pevalApplyTerm (gov f) (gov op) + DivIntegralTerm _ op1 op2 -> SomeTerm $ pevalDivIntegralTerm (gov op1) (gov op2) + ModIntegralTerm _ op1 op2 -> SomeTerm $ pevalModIntegralTerm (gov op1) (gov op2) + QuotIntegralTerm _ op1 op2 -> SomeTerm $ pevalQuotIntegralTerm (gov op1) (gov op2) + RemIntegralTerm _ op1 op2 -> SomeTerm $ pevalRemIntegralTerm (gov op1) (gov op2) diff --git a/src/Grisette/Internal/SymPrim/IntBitwidth.hs b/src/Grisette/Internal/SymPrim/IntBitwidth.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/SymPrim/IntBitwidth.hs @@ -0,0 +1,15 @@ +-- | +-- Module : Grisette.Internal.SymPrim.IntBitwidth +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.SymPrim.IntBitwidth (intBitwidthQ) where + +import Data.Bits (FiniteBits (finiteBitSize)) +import Language.Haskell.TH (TyLit (NumTyLit), Type (LitT), TypeQ) + +intBitwidthQ :: TypeQ +intBitwidthQ = return $ LitT (NumTyLit $ toInteger $ finiteBitSize (undefined :: Int)) diff --git a/src/Grisette/Internal/SymPrim/ModelRep.hs b/src/Grisette/Internal/SymPrim/ModelRep.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/SymPrim/ModelRep.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : Grisette.Internal.SymPrim.ModelRep +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.SymPrim.ModelRep (ModelSymPair (..)) where + +import Grisette.Internal.Core.Data.Class.ModelOps + ( ModelOps (emptyModel, insertValue), + ModelRep (buildModel), + ) +import Grisette.Internal.SymPrim.Prim.Model (Model) +import Grisette.Internal.SymPrim.Prim.Term + ( LinkedRep (underlyingTerm), + Term (SymTerm), + ) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim +-- >>> import Grisette.Backend +-- >>> import Data.Proxy + +-- ModelRep + +-- | A pair of a symbolic constant and its value. +-- This is used to build a model from a list of symbolic constants and their values. +-- +-- >>> buildModel ("a" := (1 :: Integer), "b" := True) :: Model +-- Model {a -> 1 :: Integer, b -> True :: Bool} +data ModelSymPair ct st where + (:=) :: (LinkedRep ct st) => st -> ct -> ModelSymPair ct st + +instance ModelRep (ModelSymPair ct st) Model where + buildModel (sym := val) = + case underlyingTerm sym of + SymTerm _ symbol -> insertValue symbol val emptyModel + _ -> error "buildModel: should only use symbolic constants" diff --git a/src/Grisette/Internal/SymPrim/Prim/Internal/Caches.hs b/src/Grisette/Internal/SymPrim/Prim/Internal/Caches.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/SymPrim/Prim/Internal/Caches.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-cse #-} + +-- | +-- Module : Grisette.Internal.SymPrim.Prim.Internal.Caches +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.SymPrim.Prim.Internal.Caches (typeMemoizedCache) where + +import Control.Concurrent + ( forkIO, + newEmptyMVar, + putMVar, + readMVar, + takeMVar, + tryPutMVar, + ) +import Data.Data (Proxy (Proxy), TypeRep, Typeable, typeRep) +import qualified Data.HashMap.Strict as M +import Data.IORef (IORef, atomicModifyIORef', newIORef) +import Data.Interned (Cache, Interned, mkCache) +import GHC.Base (Any) +import GHC.IO (unsafeDupablePerformIO, unsafePerformIO) +import Unsafe.Coerce (unsafeCoerce) + +mkOnceIO :: IO a -> IO (IO a) +mkOnceIO io = do + mv <- newEmptyMVar + demand <- newEmptyMVar + forkIO (takeMVar demand >> io >>= putMVar mv) + return (tryPutMVar demand () >> readMVar mv) + +termCacheCell :: IO (IORef (M.HashMap TypeRep Any)) +termCacheCell = unsafePerformIO $ mkOnceIO $ newIORef M.empty +{-# NOINLINE termCacheCell #-} + +typeMemoizedCache :: forall a. (Interned a, Typeable a) => Cache a +typeMemoizedCache = unsafeDupablePerformIO $ do + c <- termCacheCell + atomicModifyIORef' c $ \m -> + case M.lookup (typeRep (Proxy @a)) m of + Just d -> (m, unsafeCoerce d) + Nothing -> (M.insert (typeRep (Proxy @a)) (unsafeCoerce r1) m, r1) + where + r1 :: Cache a + !r1 = mkCache + {-# NOINLINE r1 #-} diff --git a/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/BVPEval.hs b/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/BVPEval.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/BVPEval.hs @@ -0,0 +1,582 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# HLINT ignore "Eta reduce" #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +module Grisette.Internal.SymPrim.Prim.Internal.Instances.BVPEval () where + +import Data.Maybe (isJust) +import Data.Proxy (Proxy (Proxy)) +import qualified Data.SBV as SBV +import Data.Typeable (type (:~:) (Refl)) +import GHC.TypeNats (KnownNat, natVal, sameNat, type (+), type (-), type (<=)) +import Grisette.Internal.Core.Data.Class.BitVector + ( SizedBV + ( sizedBVConcat, + sizedBVFromIntegral, + sizedBVSelect, + sizedBVSext, + sizedBVZext + ), + ) +import Grisette.Internal.Core.Data.Class.SignConversion + ( SignConversion (toSigned, toUnsigned), + ) +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.Prim.Internal.Instances.SupportedPrim + ( bvIsNonZeroFromGEq1, + ) +import Grisette.Internal.SymPrim.Prim.Internal.Term + ( PEvalBVSignConversionTerm + ( pevalBVToSignedTerm, + pevalBVToUnsignedTerm, + sbvToSigned, + sbvToUnsigned, + withSbvSignConversionTermConstraint + ), + PEvalBVTerm + ( pevalBVConcatTerm, + pevalBVExtendTerm, + pevalBVSelectTerm, + sbvBVConcatTerm, + sbvBVExtendTerm, + sbvBVSelectTerm + ), + SupportedPrim (withPrim), + Term + ( BVConcatTerm, + BVExtendTerm, + BVSelectTerm, + ConTerm, + ToSignedTerm, + ToUnsignedTerm + ), + bvconcatTerm, + bvextendTerm, + bvselectTerm, + conTerm, + toSignedTerm, + toUnsignedTerm, + ) +import Grisette.Internal.SymPrim.Prim.Internal.Unfold + ( binaryUnfoldOnce, + unaryUnfoldOnce, + ) +import Grisette.Internal.SymPrim.Prim.TermUtils (castTerm) +import Grisette.Internal.Utils.Parameterized + ( LeqProof (LeqProof), + NatRepr, + SomeNatRepr (SomeNatRepr), + SomePositiveNatRepr (SomePositiveNatRepr), + addNat, + mkNatRepr, + mkPositiveNatRepr, + natRepr, + unsafeAxiom, + unsafeKnownProof, + unsafeLeqProof, + withKnownNat, + withKnownProof, + ) + +instance PEvalBVSignConversionTerm WordN IntN where + pevalBVToSignedTerm = unaryUnfoldOnce doPevalToSignedTerm toSignedTerm + where + doPevalToSignedTerm :: + forall n. + (KnownNat n, 1 <= n) => + Term (WordN n) -> + Maybe (Term (IntN n)) + doPevalToSignedTerm (ConTerm _ b) = Just $ conTerm $ toSigned b + doPevalToSignedTerm (ToUnsignedTerm _ b) = Just b >>= castTerm + doPevalToSignedTerm (BVConcatTerm _ b1 b2) = + Just $ + pevalBVConcatTerm (pevalBVToSignedTerm b1) (pevalBVToSignedTerm b2) + doPevalToSignedTerm (BVExtendTerm _ signed pr b) = + Just $ pevalBVExtendTerm signed pr $ pevalBVToSignedTerm b + doPevalToSignedTerm _ = Nothing + pevalBVToUnsignedTerm = unaryUnfoldOnce doPevalToUnsignedTerm toUnsignedTerm + where + doPevalToUnsignedTerm :: + forall n. + (KnownNat n, 1 <= n) => + Term (IntN n) -> + Maybe (Term (WordN n)) + doPevalToUnsignedTerm (ConTerm _ b) = Just $ conTerm $ toUnsigned b + doPevalToUnsignedTerm (ToSignedTerm _ b) = Just b >>= castTerm + doPevalToUnsignedTerm (BVConcatTerm _ b1 b2) = + Just $ + pevalBVConcatTerm + (pevalBVToUnsignedTerm b1) + (pevalBVToUnsignedTerm b2) + doPevalToUnsignedTerm (BVExtendTerm _ signed pr b) = + Just $ pevalBVExtendTerm signed pr $ pevalBVToUnsignedTerm b + doPevalToUnsignedTerm _ = Nothing + withSbvSignConversionTermConstraint (_ :: p n) qint r = + withPrim @(WordN n) qint r + +pevalDefaultBVSelectTerm :: + forall bv n ix w p q. + ( KnownNat n, + KnownNat ix, + KnownNat w, + 1 <= n, + 1 <= w, + ix + w <= n, + PEvalBVTerm bv + ) => + p ix -> + q w -> + Term (bv n) -> + Term (bv w) +pevalDefaultBVSelectTerm ix w = + unaryUnfoldOnce (doPevalDefaultBVSelectTerm ix w) (bvselectTerm ix w) + +unsafePevalBVSelectTerm :: + forall bv n ix w. + (PEvalBVTerm bv) => + NatRepr n -> + NatRepr ix -> + NatRepr w -> + Term (bv n) -> + Term (bv w) +unsafePevalBVSelectTerm n ix w term = + withKnownNat n $ + withKnownNat ix $ + withKnownNat w $ + case ( unsafeLeqProof @1 @n, + unsafeLeqProof @1 @w, + unsafeLeqProof @(ix + w) @n + ) of + (LeqProof, LeqProof, LeqProof) -> pevalBVSelectTerm ix w term + +doPevalDefaultBVSelectTerm :: + forall bv n ix w p q. + ( KnownNat n, + KnownNat ix, + KnownNat w, + 1 <= n, + 1 <= w, + ix + w <= n, + PEvalBVTerm bv + ) => + p ix -> + q w -> + Term (bv n) -> + Maybe (Term (bv w)) +doPevalDefaultBVSelectTerm _ _ rhs + | isJust (sameNat (Proxy @ix) (Proxy @0)) + && isJust (sameNat (Proxy @w) (Proxy @n)) = + Just rhs >>= castTerm +doPevalDefaultBVSelectTerm ix w (ConTerm _ b) = + Just $ conTerm $ sizedBVSelect ix w b +doPevalDefaultBVSelectTerm ix w (ToSignedTerm _ b) = + Just $ pevalBVToSignedTerm $ pevalBVSelectTerm ix w b +doPevalDefaultBVSelectTerm ix w (ToUnsignedTerm _ b) = + Just $ pevalBVToUnsignedTerm $ pevalBVSelectTerm ix w b +doPevalDefaultBVSelectTerm + pix + pw + (BVConcatTerm _ (b1 :: Term (bv n1)) (b2 :: Term (bv n2))) + | ix + w <= n2 = Just $ unsafePevalBVSelectTerm n2Repr ixRepr wRepr b2 + | ix >= n2 = + case mkNatRepr (ix - n2) of + SomeNatRepr ixpn2Repr -> + Just $ unsafePevalBVSelectTerm n1Repr ixpn2Repr wRepr b1 + | otherwise = + case (mkNatRepr (w + ix - n2), mkNatRepr (n2 - ix)) of + (SomeNatRepr wixpn2Repr, SomeNatRepr n2pixRepr) -> + let b1Part = + unsafePevalBVSelectTerm n1Repr (natRepr @0) wixpn2Repr b1 + b2Part = unsafePevalBVSelectTerm n2Repr ixRepr n2pixRepr b2 + in Just $ + unsafePevalBVConcatTerm + wixpn2Repr + n2pixRepr + wRepr + b1Part + b2Part + where + ixRepr = natRepr @ix + wRepr = natRepr @w + n1Repr = natRepr @n1 + n2Repr = natRepr @n2 + ix = natVal @ix pix + w = natVal @w pw + n2 = natVal @n2 (Proxy @n2) +doPevalDefaultBVSelectTerm + _ + _ + (BVSelectTerm _ (_ :: proxy ix1) _ (b :: Term (bv n1))) = + Just $ + unsafePevalBVSelectTerm + (natRepr @n1) + (addNat (natRepr @ix) (natRepr @ix1)) + (natRepr @w) + b +doPevalDefaultBVSelectTerm + pix + pw + (BVExtendTerm _ signed _ (b :: Term (bv n1))) + | ix + w <= n1 = Just $ unsafePevalBVSelectTerm n1Repr ixRepr wRepr b + | ix < n1 = + case mkNatRepr (n1 - ix) of + SomeNatRepr n1pixRepr -> + let bPart = unsafePevalBVSelectTerm n1Repr ixRepr n1pixRepr b + in Just $ unsafePevalBVExtendTerm n1pixRepr wRepr signed bPart + | otherwise = Nothing + where + ixRepr = natRepr @ix + wRepr = natRepr @w + n1Repr = natRepr @n1 + ix = natVal @ix pix + w = natVal @w pw + n1 = natVal @n1 (Proxy @n1) +doPevalDefaultBVSelectTerm _ _ _ = Nothing + +pevalDefaultBVExtendTerm :: + forall proxy l r bv. + ( PEvalBVTerm bv, + KnownNat l, + KnownNat r, + 1 <= l, + 1 <= r, + l <= r + ) => + Bool -> + proxy r -> + Term (bv l) -> + Term (bv r) +pevalDefaultBVExtendTerm signed p = + unaryUnfoldOnce (doPevalDefaultBVExtendTerm signed p) (bvextendTerm signed p) + +unsafePevalBVExtendTerm :: + forall bv l r. + (PEvalBVTerm bv) => + NatRepr l -> + NatRepr r -> + Bool -> + Term (bv l) -> + Term (bv r) +unsafePevalBVExtendTerm lRepr rRepr signed v = + case (unsafeLeqProof @1 @l, unsafeLeqProof @1 @r, unsafeLeqProof @l @r) of + (LeqProof, LeqProof, LeqProof) -> + withKnownNat lRepr $ + withKnownNat rRepr $ + pevalBVExtendTerm signed (Proxy @r) v + +doPevalDefaultBVExtendTerm :: + forall proxy l r bv. + ( PEvalBVTerm bv, + KnownNat l, + KnownNat r, + 1 <= l, + 1 <= r, + l <= r + ) => + Bool -> + proxy r -> + Term (bv l) -> + Maybe (Term (bv r)) +doPevalDefaultBVExtendTerm signed p (ConTerm _ b) = + Just $ conTerm $ if signed then sizedBVSext p b else sizedBVZext p b +doPevalDefaultBVExtendTerm _ _ b + | isJust $ sameNat (Proxy @l) (Proxy @r) = + Just b >>= castTerm +doPevalDefaultBVExtendTerm False pr b = + case (mkPositiveNatRepr $ r - l) of + SomePositiveNatRepr (rplRepr :: NatRepr lpr) -> + Just $ + unsafePevalBVConcatTerm + rplRepr + lRepr + rRepr + (conTerm $ sizedBVFromIntegral 0) + b + where + lRepr = natRepr @l + rRepr = natRepr @r + l = natVal @l (Proxy @l) + r = natVal @r pr +doPevalDefaultBVExtendTerm True p (BVExtendTerm _ True _ (b :: Term (bv l1))) = + case unsafeLeqProof @l1 @r of + LeqProof -> Just $ pevalBVExtendTerm True p b +doPevalDefaultBVExtendTerm _ _ _ = Nothing + +pevalDefaultBVConcatTerm :: + forall bv a b. + ( KnownNat a, + KnownNat b, + 1 <= a, + 1 <= b, + PEvalBVTerm bv + ) => + Term (bv a) -> + Term (bv b) -> + Term (bv (a + b)) +pevalDefaultBVConcatTerm = + withKnownNat (addNat (natRepr @a) (natRepr @b)) $ + case (unsafeLeqProof @1 @(a + b)) of + LeqProof -> + binaryUnfoldOnce doPevalDefaultBVConcatTerm bvconcatTerm + +unsafeBVConcatTerm :: + forall bv n1 n2 r. + (PEvalBVTerm bv) => + NatRepr n1 -> + NatRepr n2 -> + NatRepr r -> + Term (bv n1) -> + Term (bv n2) -> + Term (bv r) +unsafeBVConcatTerm n1Repr n2Repr rRepr lhs rhs = + case ( unsafeAxiom :: (n1 + n2) :~: r, + unsafeLeqProof @1 @r, + unsafeLeqProof @1 @n1, + unsafeLeqProof @1 @n2 + ) of + (Refl, LeqProof, LeqProof, LeqProof) -> + withKnownNat n1Repr $ + withKnownNat n2Repr $ + withKnownNat rRepr $ + bvconcatTerm lhs rhs + +unsafePevalBVConcatTerm :: + forall bv n1 n2 r. + (PEvalBVTerm bv) => + NatRepr n1 -> + NatRepr n2 -> + NatRepr r -> + Term (bv n1) -> + Term (bv n2) -> + Term (bv r) +unsafePevalBVConcatTerm n1Repr n2Repr rRepr lhs rhs = + case ( unsafeAxiom :: (n1 + n2) :~: r, + unsafeLeqProof @1 @r, + unsafeLeqProof @1 @n1, + unsafeLeqProof @1 @n2 + ) of + (Refl, LeqProof, LeqProof, LeqProof) -> + withKnownNat n1Repr $ + withKnownNat n2Repr $ + withKnownNat rRepr $ + pevalBVConcatTerm lhs rhs + +doPevalDefaultBVConcatTerm :: + forall bv l r. + ( KnownNat l, + KnownNat r, + 1 <= l, + 1 <= r, + 1 <= (l + r), + PEvalBVTerm bv + ) => + Term (bv l) -> + Term (bv r) -> + Maybe (Term (bv (l + r))) +-- 1. [c1 c2] -> c1c2 +doPevalDefaultBVConcatTerm (ConTerm _ v) (ConTerm _ v') = + withKnownNat (addNat (natRepr @l) (natRepr @r)) $ + Just $ + conTerm $ + sizedBVConcat v v' +-- 2. [c1 (c2 ?)] -> (c1c2 ?) +doPevalDefaultBVConcatTerm + (ConTerm _ vl) + (BVConcatTerm _ (ConTerm _ (vrl :: bv rl)) (rr :: Term (bv rr))) = + case unsafeLeqProof @1 @(l + rl) of + LeqProof -> + Just $ + withKnownNat lRlRepr $ + unsafeBVConcatTerm + lRlRepr + (natRepr @rr) + (addNat (natRepr @l) (natRepr @r)) + (conTerm $ sizedBVConcat vl vrl) + rr + where + lRlRepr = addNat (natRepr @l) (natRepr @rl) +-- 3. [c1 (s c2)] -> (c1 (s c2)) +doPevalDefaultBVConcatTerm (ConTerm {}) (BVConcatTerm _ _ ConTerm {}) = Nothing +-- 4. [(c s) ?) -> (c [s ?]) +doPevalDefaultBVConcatTerm + (BVConcatTerm _ (ll@ConTerm {} :: Term (bv ll)) (lr :: Term (bv lr))) + r = + Just $ unsafeBVConcatTerm llRepr lrRRepr lRRepr ll rhs + where + llRepr = natRepr @ll + lrRepr = natRepr @lr + lRepr = natRepr @l + rRepr = natRepr @r + lrRRepr = addNat lrRepr rRepr + lRRepr = addNat lRepr rRepr + rhs :: Term (bv (lr + r)) + rhs = unsafePevalBVConcatTerm lrRepr rRepr lrRRepr lr r +-- 5. [? (c1 (s2 c2))] -> (([? c1] s2) c2) +doPevalDefaultBVConcatTerm + l + ( BVConcatTerm + _ + (rl@ConTerm {} :: Term (bv rl)) + (BVConcatTerm _ (rrl :: Term (bv rrl)) (rrr@ConTerm {} :: Term (bv rrr))) + ) = + Just $ unsafeBVConcatTerm lRlRrlRepr rrrRepr lRRepr lRlRrl rrr + where + lRepr = natRepr @l + rlRepr = natRepr @rl + rrlRepr = natRepr @rrl + rrrRepr = natRepr @rrr + lRlRepr = addNat lRepr rlRepr + rRepr = natRepr @r + lRRepr = addNat lRepr rRepr + lRl = unsafePevalBVConcatTerm lRepr rlRepr lRlRepr l rl + lRlRrlRepr = addNat lRlRepr rrlRepr + lRlRrl = unsafeBVConcatTerm lRlRepr rrlRepr lRlRrlRepr lRl rrl +-- 6. [(s1 c1) c2] -> (s1 c1c2) +doPevalDefaultBVConcatTerm + (BVConcatTerm _ (ll :: Term (bv ll)) ((ConTerm _ vlr) :: Term (bv lr))) + (ConTerm _ vr) = + Just $ unsafeBVConcatTerm llRepr lrRRepr lRRepr ll rhs + where + llRepr = natRepr @ll + lrRepr = natRepr @lr + lRepr = natRepr @l + rRepr = natRepr @r + lrRRepr = addNat lrRepr rRepr + lRRepr = addNat lRepr rRepr + rhs :: Term (bv (lr + r)) + rhs = case unsafeLeqProof @1 @(lr + r) of + LeqProof -> + withKnownNat lrRRepr $ conTerm $ sizedBVConcat vlr vr +-- 7. [(s1 c1) (c2 s2)] -> (s1 (c1c2 s2)) +doPevalDefaultBVConcatTerm + (BVConcatTerm _ (ll :: Term (bv ll)) ((ConTerm _ vlr) :: Term (bv lr))) + (BVConcatTerm _ ((ConTerm _ vrl) :: Term (bv rl)) (rr :: Term (bv rr))) = + Just $ unsafeBVConcatTerm llRepr lrRlRrRepr lRRepr ll lrRlRR + where + lRepr = natRepr @l + rRepr = natRepr @r + llRepr = natRepr @ll + lrRepr = natRepr @lr + rlRepr = natRepr @rl + rrRepr = natRepr @rr + lRRepr = addNat lRepr rRepr + lrRlRepr :: NatRepr (lr + rl) + lrRlRepr = addNat lrRepr rlRepr + lrRlRrRepr :: NatRepr ((lr + rl) + rr) + lrRlRrRepr = addNat lrRlRepr rrRepr + lrRl :: Term (bv (lr + rl)) + lrRl = case unsafeLeqProof @1 @(lr + rl) of + LeqProof -> withKnownNat lrRlRepr $ conTerm $ sizedBVConcat vlr vrl + lrRlRR :: Term (bv ((lr + rl) + rr)) + lrRlRR = unsafeBVConcatTerm lrRlRepr rrRepr lrRlRrRepr lrRl rr +-- 8. [?notc (s2 c)] -> ((s1 s2) c) +doPevalDefaultBVConcatTerm + l + (BVConcatTerm _ (rl :: Term (bv rl)) (rr@ConTerm {} :: Term (bv rr))) = + Just $ + unsafeBVConcatTerm + lRlRepr + (natRepr @rr) + (addNat (natRepr @l) (natRepr @r)) + lhs + rr + where + lRepr = natRepr @l + rlRepr = natRepr @rl + lRlRepr = addNat lRepr rlRepr + lhs :: Term (bv (l + rl)) + lhs = unsafeBVConcatTerm lRepr rlRepr lRlRepr l rl +doPevalDefaultBVConcatTerm _ _ = Nothing + +instance PEvalBVTerm WordN where + pevalBVSelectTerm = pevalDefaultBVSelectTerm + pevalBVConcatTerm = pevalDefaultBVConcatTerm + pevalBVExtendTerm = pevalDefaultBVExtendTerm + sbvBVConcatTerm _ pl pr l r = + bvIsNonZeroFromGEq1 pl $ + bvIsNonZeroFromGEq1 pr $ + l SBV.# r + sbvBVSelectTerm _ (pix :: p0 ix) (pw :: p1 w) (pn :: p2 n) bv = + bvIsNonZeroFromGEq1 (Proxy @n) $ + bvIsNonZeroFromGEq1 (Proxy @w) $ + sbvDefaultBVSelectTerm pix pw pn bv + sbvBVExtendTerm _ (_ :: p0 l) (_ :: p1 r) signed bv = + withKnownProof + (unsafeKnownProof @(r - l) (natVal (Proxy @r) - natVal (Proxy @l))) + $ case (unsafeLeqProof @(l + 1) @r, unsafeLeqProof @1 @(r - l)) of + (LeqProof, LeqProof) -> + bvIsNonZeroFromGEq1 (Proxy @r) $ + bvIsNonZeroFromGEq1 (Proxy @l) $ + bvIsNonZeroFromGEq1 (Proxy @(r - l)) $ + if signed then SBV.signExtend bv else SBV.zeroExtend bv + +instance PEvalBVTerm IntN where + pevalBVSelectTerm = pevalDefaultBVSelectTerm + pevalBVConcatTerm = pevalDefaultBVConcatTerm + pevalBVExtendTerm = pevalDefaultBVExtendTerm + sbvBVConcatTerm pn (pl :: p l) (pr :: q r) l r = + bvIsNonZeroFromGEq1 pl $ + bvIsNonZeroFromGEq1 pr $ + withKnownNat (addNat (natRepr @l) (natRepr @r)) $ + case unsafeLeqProof @1 @(l + r) of + LeqProof -> + bvIsNonZeroFromGEq1 (Proxy @(l + r)) $ + sbvToSigned (Proxy @WordN) (Proxy @(l + r)) pn $ + sbvToUnsigned (Proxy @IntN) pl pn l + SBV.# sbvToUnsigned (Proxy @IntN) pr pn r + sbvBVSelectTerm _ (pix :: p0 ix) (pw :: p1 w) (pn :: p2 n) bv = + bvIsNonZeroFromGEq1 (Proxy @n) $ + bvIsNonZeroFromGEq1 (Proxy @w) $ + sbvDefaultBVSelectTerm pix pw pn bv + sbvBVExtendTerm _ (_ :: p0 l) (_ :: p1 r) signed bv = + withKnownProof + (unsafeKnownProof @(r - l) (natVal (Proxy @r) - natVal (Proxy @l))) + $ case (unsafeLeqProof @(l + 1) @r, unsafeLeqProof @1 @(r - l)) of + (LeqProof, LeqProof) -> + bvIsNonZeroFromGEq1 (Proxy @r) $ + bvIsNonZeroFromGEq1 (Proxy @l) $ + bvIsNonZeroFromGEq1 (Proxy @(r - l)) $ + if signed + then SBV.signExtend bv + else + SBV.sFromIntegral + ( SBV.zeroExtend + (SBV.sFromIntegral bv :: SBV.SBV (SBV.WordN l)) :: + SBV.SBV (SBV.WordN r) + ) + +sbvDefaultBVSelectTerm :: + ( KnownNat ix, + KnownNat w, + KnownNat n, + 1 <= n, + 1 <= w, + (ix + w) <= n, + SBV.SymVal (bv n) + ) => + p1 ix -> + p2 w -> + p3 n -> + SBV.SBV (bv n) -> + SBV.SBV (bv w) +sbvDefaultBVSelectTerm (_ :: p0 ix) (_ :: p1 w) (_ :: p2 n) bv = + withKnownProof + ( unsafeKnownProof @(w + ix - 1) + (natVal (Proxy @w) + natVal (Proxy @ix) - 1) + ) + $ case ( unsafeAxiom @(w + ix - 1 - ix + 1) @w, + unsafeLeqProof @(((w + ix) - 1) + 1) @n, + unsafeLeqProof @ix @(w + ix - 1) + ) of + (Refl, LeqProof, LeqProof) -> + bvIsNonZeroFromGEq1 (Proxy @n) $ + bvIsNonZeroFromGEq1 (Proxy @w) $ + SBV.bvExtract (Proxy @(w + ix - 1)) (Proxy @ix) bv diff --git a/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalBitwiseTerm.hs b/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalBitwiseTerm.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalBitwiseTerm.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Eta reduce" #-} + +-- | +-- Module : Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalBitwiseTerm +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalBitwiseTerm () where + +import Data.Bits (Bits (complement, xor, zeroBits, (.&.), (.|.))) +import GHC.TypeLits (KnownNat, type (<=)) +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.Prim.Internal.Instances.SupportedPrim () +import Grisette.Internal.SymPrim.Prim.Internal.Term + ( PEvalBitwiseTerm + ( pevalAndBitsTerm, + pevalComplementBitsTerm, + pevalOrBitsTerm, + pevalXorBitsTerm, + withSbvBitwiseTermConstraint + ), + SupportedPrim (withPrim), + Term (ComplementBitsTerm, ConTerm), + andBitsTerm, + complementBitsTerm, + conTerm, + orBitsTerm, + xorBitsTerm, + ) +import Grisette.Internal.SymPrim.Prim.Internal.Unfold + ( binaryUnfoldOnce, + unaryUnfoldOnce, + ) + +pevalDefaultAndBitsTerm :: + (Bits a, SupportedPrim a, PEvalBitwiseTerm a) => Term a -> Term a -> Term a +pevalDefaultAndBitsTerm = binaryUnfoldOnce doPevalAndBitsTerm andBitsTerm + where + doPevalAndBitsTerm (ConTerm _ a) (ConTerm _ b) = Just $ conTerm (a .&. b) + doPevalAndBitsTerm (ConTerm _ a) b + | a == zeroBits = Just $ conTerm zeroBits + | a == complement zeroBits = Just b + doPevalAndBitsTerm a (ConTerm _ b) + | b == zeroBits = Just $ conTerm zeroBits + | b == complement zeroBits = Just a + doPevalAndBitsTerm a b | a == b = Just a + doPevalAndBitsTerm _ _ = Nothing + +pevalDefaultOrBitsTerm :: + (Bits a, SupportedPrim a, PEvalBitwiseTerm a) => Term a -> Term a -> Term a +pevalDefaultOrBitsTerm = binaryUnfoldOnce doPevalOrBitsTerm orBitsTerm + where + doPevalOrBitsTerm (ConTerm _ a) (ConTerm _ b) = Just $ conTerm (a .|. b) + doPevalOrBitsTerm (ConTerm _ a) b + | a == zeroBits = Just b + | a == complement zeroBits = Just $ conTerm $ complement zeroBits + doPevalOrBitsTerm a (ConTerm _ b) + | b == zeroBits = Just a + | b == complement zeroBits = Just $ conTerm $ complement zeroBits + doPevalOrBitsTerm a b | a == b = Just a + doPevalOrBitsTerm _ _ = Nothing + +pevalDefaultXorBitsTerm :: + (PEvalBitwiseTerm a, SupportedPrim a) => Term a -> Term a -> Term a +pevalDefaultXorBitsTerm = binaryUnfoldOnce doPevalXorBitsTerm xorBitsTerm + where + doPevalXorBitsTerm (ConTerm _ a) (ConTerm _ b) = + Just $ conTerm (a `xor` b) + doPevalXorBitsTerm (ConTerm _ a) b + | a == zeroBits = Just b + | a == complement zeroBits = Just $ pevalComplementBitsTerm b + doPevalXorBitsTerm a (ConTerm _ b) + | b == zeroBits = Just a + | b == complement zeroBits = Just $ pevalComplementBitsTerm a + doPevalXorBitsTerm a b | a == b = Just $ conTerm zeroBits + doPevalXorBitsTerm (ComplementBitsTerm _ i) (ComplementBitsTerm _ j) = + Just $ pevalXorBitsTerm i j + doPevalXorBitsTerm (ComplementBitsTerm _ i) j = + Just $ pevalComplementBitsTerm $ pevalXorBitsTerm i j + doPevalXorBitsTerm i (ComplementBitsTerm _ j) = + Just $ pevalComplementBitsTerm $ pevalXorBitsTerm i j + doPevalXorBitsTerm _ _ = Nothing + +pevalDefaultComplementBitsTerm :: + (Bits a, SupportedPrim a, PEvalBitwiseTerm a) => Term a -> Term a +pevalDefaultComplementBitsTerm = + unaryUnfoldOnce doPevalComplementBitsTerm complementBitsTerm + where + doPevalComplementBitsTerm (ConTerm _ a) = Just $ conTerm $ complement a + doPevalComplementBitsTerm (ComplementBitsTerm _ a) = Just a + doPevalComplementBitsTerm _ = Nothing + +instance (KnownNat n, 1 <= n) => PEvalBitwiseTerm (WordN n) where + pevalAndBitsTerm = pevalDefaultAndBitsTerm + pevalOrBitsTerm = pevalDefaultOrBitsTerm + pevalXorBitsTerm = pevalDefaultXorBitsTerm + pevalComplementBitsTerm = pevalDefaultComplementBitsTerm + withSbvBitwiseTermConstraint p r = withPrim @(WordN n) p r + +instance (KnownNat n, 1 <= n) => PEvalBitwiseTerm (IntN n) where + pevalAndBitsTerm = pevalDefaultAndBitsTerm + pevalOrBitsTerm = pevalDefaultOrBitsTerm + pevalXorBitsTerm = pevalDefaultXorBitsTerm + pevalComplementBitsTerm = pevalDefaultComplementBitsTerm + withSbvBitwiseTermConstraint p r = withPrim @(IntN n) p r diff --git a/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalDivModIntegralTerm.hs b/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalDivModIntegralTerm.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalDivModIntegralTerm.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# HLINT ignore "Eta reduce" #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +-- | +-- Module : Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalDivModIntegralTerm +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalDivModIntegralTerm + ( pevalDefaultDivIntegralTerm, + pevalDefaultDivBoundedIntegralTerm, + pevalDefaultModIntegralTerm, + pevalDefaultQuotIntegralTerm, + pevalDefaultQuotBoundedIntegralTerm, + pevalDefaultRemIntegralTerm, + ) +where + +import GHC.TypeNats (KnownNat, type (<=)) +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.Prim.Internal.Instances.SupportedPrim () +import Grisette.Internal.SymPrim.Prim.Internal.IsZero + ( IsZeroCases (IsZeroEvidence, NonZeroEvidence), + KnownIsZero (isZero), + ) +import Grisette.Internal.SymPrim.Prim.Internal.Term + ( PEvalDivModIntegralTerm + ( pevalDivIntegralTerm, + pevalModIntegralTerm, + pevalQuotIntegralTerm, + pevalRemIntegralTerm, + withSbvDivModIntegralTermConstraint + ), + SupportedPrim (withPrim), + Term (ConTerm), + conTerm, + divIntegralTerm, + modIntegralTerm, + quotIntegralTerm, + remIntegralTerm, + ) +import Grisette.Internal.SymPrim.Prim.Internal.Unfold (binaryUnfoldOnce) + +-- div +pevalDefaultDivIntegralTerm :: + (PEvalDivModIntegralTerm a) => Term a -> Term a -> Term a +pevalDefaultDivIntegralTerm = + binaryUnfoldOnce doPevalDefaultDivIntegralTerm divIntegralTerm + +doPevalDefaultDivIntegralTerm :: + (PEvalDivModIntegralTerm a) => Term a -> Term a -> Maybe (Term a) +doPevalDefaultDivIntegralTerm (ConTerm _ a) (ConTerm _ b) + | b /= 0 = Just $ conTerm $ a `div` b +doPevalDefaultDivIntegralTerm a (ConTerm _ 1) = Just a +doPevalDefaultDivIntegralTerm _ _ = Nothing + +pevalDefaultDivBoundedIntegralTerm :: + (PEvalDivModIntegralTerm a, Bounded a) => Term a -> Term a -> Term a +pevalDefaultDivBoundedIntegralTerm = + binaryUnfoldOnce doPevalDefaultDivBoundedIntegralTerm divIntegralTerm + +doPevalDefaultDivBoundedIntegralTerm :: + (PEvalDivModIntegralTerm a, Bounded a) => + Term a -> + Term a -> + Maybe (Term a) +doPevalDefaultDivBoundedIntegralTerm (ConTerm _ a) (ConTerm _ b) + | b /= 0 && (b /= -1 || a /= minBound) = Just $ conTerm $ a `div` b +doPevalDefaultDivBoundedIntegralTerm a (ConTerm _ 1) = Just a +doPevalDefaultDivBoundedIntegralTerm _ _ = Nothing + +-- mod +pevalDefaultModIntegralTerm :: + (PEvalDivModIntegralTerm a) => Term a -> Term a -> Term a +pevalDefaultModIntegralTerm = + binaryUnfoldOnce doPevalDefaultModIntegralTerm modIntegralTerm + +doPevalDefaultModIntegralTerm :: + (PEvalDivModIntegralTerm a) => Term a -> Term a -> Maybe (Term a) +doPevalDefaultModIntegralTerm (ConTerm _ a) (ConTerm _ b) + | b /= 0 = Just $ conTerm $ a `mod` b +doPevalDefaultModIntegralTerm _ (ConTerm _ 1) = Just $ conTerm 0 +doPevalDefaultModIntegralTerm _ (ConTerm _ (-1)) = Just $ conTerm 0 +doPevalDefaultModIntegralTerm _ _ = Nothing + +-- quot +pevalDefaultQuotIntegralTerm :: + (PEvalDivModIntegralTerm a) => Term a -> Term a -> Term a +pevalDefaultQuotIntegralTerm = + binaryUnfoldOnce doPevalDefaultQuotIntegralTerm quotIntegralTerm + +doPevalDefaultQuotIntegralTerm :: + (PEvalDivModIntegralTerm a) => Term a -> Term a -> Maybe (Term a) +doPevalDefaultQuotIntegralTerm (ConTerm _ a) (ConTerm _ b) + | b /= 0 = Just $ conTerm $ a `quot` b +doPevalDefaultQuotIntegralTerm a (ConTerm _ 1) = Just a +doPevalDefaultQuotIntegralTerm _ _ = Nothing + +pevalDefaultQuotBoundedIntegralTerm :: + (PEvalDivModIntegralTerm a, Bounded a) => Term a -> Term a -> Term a +pevalDefaultQuotBoundedIntegralTerm = + binaryUnfoldOnce doPevalDefaultQuotBoundedIntegralTerm quotIntegralTerm + +doPevalDefaultQuotBoundedIntegralTerm :: + (PEvalDivModIntegralTerm a, Bounded a) => + Term a -> + Term a -> + Maybe (Term a) +doPevalDefaultQuotBoundedIntegralTerm (ConTerm _ a) (ConTerm _ b) + | b /= 0 && (b /= -1 || a /= minBound) = Just $ conTerm $ a `quot` b +doPevalDefaultQuotBoundedIntegralTerm a (ConTerm _ 1) = Just a +doPevalDefaultQuotBoundedIntegralTerm _ _ = Nothing + +-- rem +pevalDefaultRemIntegralTerm :: + (PEvalDivModIntegralTerm a) => Term a -> Term a -> Term a +pevalDefaultRemIntegralTerm = + binaryUnfoldOnce doPevalDefaultRemIntegralTerm remIntegralTerm + +doPevalDefaultRemIntegralTerm :: + (PEvalDivModIntegralTerm a) => Term a -> Term a -> Maybe (Term a) +doPevalDefaultRemIntegralTerm (ConTerm _ a) (ConTerm _ b) + | b /= 0 = Just $ conTerm $ a `rem` b +doPevalDefaultRemIntegralTerm _ (ConTerm _ 1) = Just $ conTerm 0 +doPevalDefaultRemIntegralTerm _ (ConTerm _ (-1)) = Just $ conTerm 0 +doPevalDefaultRemIntegralTerm _ _ = Nothing + +instance PEvalDivModIntegralTerm Integer where + pevalDivIntegralTerm = pevalDefaultDivIntegralTerm + pevalModIntegralTerm = pevalDefaultModIntegralTerm + pevalQuotIntegralTerm = pevalDefaultQuotIntegralTerm + pevalRemIntegralTerm = pevalDefaultRemIntegralTerm + withSbvDivModIntegralTermConstraint p r = case isZero p of + IsZeroEvidence -> r + NonZeroEvidence -> r + +instance (KnownNat n, 1 <= n) => PEvalDivModIntegralTerm (IntN n) where + pevalDivIntegralTerm = pevalDefaultDivBoundedIntegralTerm + pevalModIntegralTerm = pevalDefaultModIntegralTerm + pevalQuotIntegralTerm = pevalDefaultQuotBoundedIntegralTerm + pevalRemIntegralTerm = pevalDefaultRemIntegralTerm + withSbvDivModIntegralTermConstraint p r = withPrim @(IntN n) p r + +instance (KnownNat n, 1 <= n) => PEvalDivModIntegralTerm (WordN n) where + pevalDivIntegralTerm = pevalDefaultDivIntegralTerm + pevalModIntegralTerm = pevalDefaultModIntegralTerm + pevalQuotIntegralTerm = pevalDefaultQuotIntegralTerm + pevalRemIntegralTerm = pevalDefaultRemIntegralTerm + withSbvDivModIntegralTermConstraint p r = withPrim @(WordN n) p r diff --git a/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalNumTerm.hs b/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalNumTerm.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalNumTerm.hs @@ -0,0 +1,241 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# HLINT ignore "Eta reduce" #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +-- | +-- Module : Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalNumTerm +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalNumTerm + ( pevalDefaultAddNumTerm, + pevalDefaultNegNumTerm, + ) +where + +import Control.Monad (msum) +import Data.Bits (Bits) +import Data.SBV (Bits (isSigned)) +import GHC.TypeLits (KnownNat, type (<=)) +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.Prim.Internal.Instances.SupportedPrim () +import Grisette.Internal.SymPrim.Prim.Internal.IsZero + ( IsZeroCases (IsZeroEvidence, NonZeroEvidence), + KnownIsZero (isZero), + ) +import Grisette.Internal.SymPrim.Prim.Internal.Term + ( PEvalNumTerm + ( pevalAbsNumTerm, + pevalAddNumTerm, + pevalMulNumTerm, + pevalNegNumTerm, + pevalSignumNumTerm, + withSbvNumTermConstraint + ), + SupportedPrim (withPrim), + Term (AbsNumTerm, AddNumTerm, ConTerm, MulNumTerm, NegNumTerm), + absNumTerm, + addNumTerm, + conTerm, + mulNumTerm, + negNumTerm, + pevalSubNumTerm, + signumNumTerm, + ) +import Grisette.Internal.SymPrim.Prim.Internal.Unfold + ( binaryUnfoldOnce, + unaryUnfoldOnce, + ) + +-- Add +pevalDefaultAddNumTerm :: (PEvalNumTerm a) => Term a -> Term a -> Term a +pevalDefaultAddNumTerm = + binaryUnfoldOnce + doPevalDefaultAddNumTerm + (\a b -> normalizeAddNum $ addNumTerm a b) + +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 + (0, k) -> Just k + (l1, AddNumTerm _ (ConTerm _ j) k) -> + Just $ pevalAddNumTerm (conTerm $ l1 + j) k + _ -> doPevalDefaultAddNumTermNoCon l b +doPevalDefaultAddNumTerm a r@(ConTerm _ _) = doPevalDefaultAddNumTerm r a +doPevalDefaultAddNumTerm l r = doPevalDefaultAddNumTermNoCon l r + +doPevalDefaultAddNumTermNoCon :: + (PEvalNumTerm a) => Term a -> Term a -> Maybe (Term a) +doPevalDefaultAddNumTermNoCon (AddNumTerm _ i@ConTerm {} j) k = + Just $ pevalAddNumTerm i $ pevalAddNumTerm j k +doPevalDefaultAddNumTermNoCon i (AddNumTerm _ j@ConTerm {} k) = + Just $ pevalAddNumTerm j $ pevalAddNumTerm i k +doPevalDefaultAddNumTermNoCon (NegNumTerm _ i) (NegNumTerm _ j) = + Just $ pevalNegNumTerm $ pevalAddNumTerm i j +doPevalDefaultAddNumTermNoCon + (MulNumTerm _ (ConTerm _ i) j) + (MulNumTerm _ (ConTerm _ k) l) + | j == l = Just $ pevalMulNumTerm (conTerm $ i + k) j +doPevalDefaultAddNumTermNoCon + (MulNumTerm _ i@ConTerm {} j) + (MulNumTerm _ k@(ConTerm _ _) l) + | i == k = Just $ pevalMulNumTerm i (pevalAddNumTerm j l) +doPevalDefaultAddNumTermNoCon _ _ = Nothing + +normalizeAddNum :: (PEvalNumTerm a) => Term a -> Term a +normalizeAddNum (AddNumTerm _ l r@(ConTerm _ _)) = addNumTerm r l +normalizeAddNum v = v + +-- Neg +pevalDefaultNegNumTerm :: (PEvalNumTerm a) => Term a -> Term a +pevalDefaultNegNumTerm = unaryUnfoldOnce doPevalDefaultNegNumTerm negNumTerm + +doPevalDefaultNegNumTerm :: (PEvalNumTerm a) => Term a -> Maybe (Term a) +doPevalDefaultNegNumTerm (ConTerm _ a) = Just $ conTerm $ -a +doPevalDefaultNegNumTerm (NegNumTerm _ v) = Just v +doPevalDefaultNegNumTerm (AddNumTerm _ (ConTerm _ l) r) = + Just $ pevalSubNumTerm (conTerm $ -l) r +doPevalDefaultNegNumTerm (AddNumTerm _ (NegNumTerm _ l) r) = + Just $ pevalAddNumTerm l (pevalNegNumTerm r) +doPevalDefaultNegNumTerm (AddNumTerm _ l (NegNumTerm _ r)) = + Just $ pevalAddNumTerm (pevalNegNumTerm l) r +doPevalDefaultNegNumTerm (MulNumTerm _ (ConTerm _ l) r) = + Just $ pevalMulNumTerm (conTerm $ -l) r +doPevalDefaultNegNumTerm (MulNumTerm _ (NegNumTerm _ _) _) = + error "Should not happen" +doPevalDefaultNegNumTerm (MulNumTerm _ _ (NegNumTerm _ _)) = + error "Should not happen" +doPevalDefaultNegNumTerm (AddNumTerm _ _ ConTerm {}) = error "Should not happen" +doPevalDefaultNegNumTerm _ = Nothing + +-- Mul +pevalDefaultMulNumTerm :: (PEvalNumTerm a) => Term a -> Term a -> Term a +pevalDefaultMulNumTerm = + binaryUnfoldOnce + doPevalDefaultMulNumTerm + (\a b -> normalizeMulNum $ mulNumTerm a b) + +normalizeMulNum :: (PEvalNumTerm a) => Term a -> Term a +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 + (0, _) -> Just $ conTerm 0 + (1, k) -> Just k + (-1, k) -> Just $ pevalNegNumTerm k + (l1, MulNumTerm _ (ConTerm _ j) k) -> + Just $ pevalMulNumTerm (conTerm $ l1 * j) k + (l1, AddNumTerm _ (ConTerm _ j) k) -> + Just $ pevalAddNumTerm (conTerm $ l1 * j) (pevalMulNumTerm (conTerm l1) k) + (l1, NegNumTerm _ j) -> Just (pevalMulNumTerm (conTerm $ -l1) j) + (_, MulNumTerm _ _ ConTerm {}) -> error "Should not happen" + (_, AddNumTerm _ _ ConTerm {}) -> error "Should not happen" + _ -> doPevalDefaultMulNumTermNoCon l b +doPevalDefaultMulNumTerm a r@(ConTerm _ _) = doPevalDefaultMulNumTerm r a +doPevalDefaultMulNumTerm l r = doPevalDefaultMulNumTermNoCon l r + +doPevalDefaultMulNumTermNoCon :: + (PEvalNumTerm a) => Term a -> Term a -> Maybe (Term a) +doPevalDefaultMulNumTermNoCon (MulNumTerm _ i@ConTerm {} j) k = + Just $ pevalMulNumTerm i $ pevalMulNumTerm j k +doPevalDefaultMulNumTermNoCon i (MulNumTerm _ j@ConTerm {} k) = + Just $ pevalMulNumTerm j $ pevalMulNumTerm i k +doPevalDefaultMulNumTermNoCon (NegNumTerm _ i) j = + Just $ pevalNegNumTerm $ pevalMulNumTerm i j +doPevalDefaultMulNumTermNoCon i (NegNumTerm _ j) = + Just $ pevalNegNumTerm $ pevalMulNumTerm i j +doPevalDefaultMulNumTermNoCon i j@ConTerm {} = Just $ pevalMulNumTerm j i +doPevalDefaultMulNumTermNoCon (MulNumTerm _ _ ConTerm {}) _ = + error "Should not happen" +doPevalDefaultMulNumTermNoCon _ (MulNumTerm _ _ ConTerm {}) = + error "Should not happen" +doPevalDefaultMulNumTermNoCon _ _ = Nothing + +-- Abs +pevalBitsAbsNumTerm :: (PEvalNumTerm a, Bits a) => Term a -> Term a +pevalBitsAbsNumTerm = + unaryUnfoldOnce doPevalBitsAbsNumTerm absNumTerm + +doPevalGeneralAbsNumTerm :: (PEvalNumTerm a) => Term a -> Maybe (Term a) +doPevalGeneralAbsNumTerm (ConTerm _ a) = Just $ conTerm $ abs a +doPevalGeneralAbsNumTerm (NegNumTerm _ v) = Just $ pevalAbsNumTerm v +doPevalGeneralAbsNumTerm t@(AbsNumTerm _ _) = Just t +doPevalGeneralAbsNumTerm _ = Nothing + +doPevalBitsAbsNumTerm :: + forall a. (PEvalNumTerm a, Bits a) => Term a -> Maybe (Term a) +doPevalBitsAbsNumTerm t = + msum + [ if isSigned (undefined :: a) then Nothing else Just t, + doPevalGeneralAbsNumTerm t + ] + +-- Signum + +pevalGeneralSignumNumTerm :: (PEvalNumTerm a) => Term a -> Term a +pevalGeneralSignumNumTerm = + unaryUnfoldOnce doPevalGeneralSignumNumTerm signumNumTerm + +doPevalGeneralSignumNumTerm :: (PEvalNumTerm a) => Term a -> Maybe (Term a) +doPevalGeneralSignumNumTerm (ConTerm _ a) = Just $ conTerm $ signum a +doPevalGeneralSignumNumTerm _ = Nothing + +instance PEvalNumTerm Integer where + pevalAddNumTerm = pevalDefaultAddNumTerm + pevalNegNumTerm = pevalDefaultNegNumTerm + pevalMulNumTerm = pevalDefaultMulNumTerm + pevalAbsNumTerm = unaryUnfoldOnce doPevalIntegerAbsNumTerm absNumTerm + where + doPevalIntegerAbsNumTerm t = + msum + [ doPevalGeneralAbsNumTerm t, + case t of + MulNumTerm _ l r -> + Just $ pevalMulNumTerm (pevalAbsNumTerm l) $ pevalAbsNumTerm r + _ -> Nothing + ] + pevalSignumNumTerm = unaryUnfoldOnce doPevalIntegerSignumNumTerm signumNumTerm + where + doPevalIntegerSignumNumTerm t = + msum + [ doPevalGeneralSignumNumTerm t, + case t of + NegNumTerm _ v -> Just $ pevalNegNumTerm $ pevalSignumNumTerm v + MulNumTerm _ l r -> + Just $ + pevalMulNumTerm (pevalSignumNumTerm l) $ + pevalSignumNumTerm r + _ -> Nothing + ] + withSbvNumTermConstraint p r = case isZero p of + IsZeroEvidence -> r + NonZeroEvidence -> r + +instance (KnownNat n, 1 <= n) => PEvalNumTerm (WordN n) where + pevalAddNumTerm = pevalDefaultAddNumTerm + pevalNegNumTerm = pevalDefaultNegNumTerm + pevalMulNumTerm = pevalDefaultMulNumTerm + pevalAbsNumTerm = pevalBitsAbsNumTerm + pevalSignumNumTerm = pevalGeneralSignumNumTerm + withSbvNumTermConstraint p r = withPrim @(WordN n) p r + +instance (KnownNat n, 1 <= n) => PEvalNumTerm (IntN n) where + pevalAddNumTerm = pevalDefaultAddNumTerm + pevalNegNumTerm = pevalDefaultNegNumTerm + pevalMulNumTerm = pevalDefaultMulNumTerm + pevalAbsNumTerm = pevalBitsAbsNumTerm + pevalSignumNumTerm = pevalGeneralSignumNumTerm + withSbvNumTermConstraint p r = withPrim @(IntN n) p r diff --git a/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalOrdTerm.hs b/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalOrdTerm.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalOrdTerm.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Eta reduce" #-} + +-- | +-- Module : Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalOrdTerm +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalOrdTerm + ( pevalGeneralLtOrdTerm, + pevalGeneralLeOrdTerm, + ) +where + +import Control.Monad (msum) +import GHC.TypeNats (KnownNat, type (<=)) +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalNumTerm () +import Grisette.Internal.SymPrim.Prim.Internal.IsZero (IsZeroCases (IsZeroEvidence, NonZeroEvidence), KnownIsZero (isZero)) +import Grisette.Internal.SymPrim.Prim.Internal.Term + ( PEvalNumTerm (pevalNegNumTerm), + PEvalOrdTerm (pevalLeOrdTerm, pevalLtOrdTerm, withSbvOrdTermConstraint), + SupportedPrim (withPrim), + Term (AddNumTerm, ConTerm), + conTerm, + leOrdTerm, + ltOrdTerm, + pevalSubNumTerm, + ) +import Grisette.Internal.SymPrim.Prim.Internal.Unfold (binaryUnfoldOnce) + +-- Lt +pevalGeneralLtOrdTerm :: (PEvalOrdTerm 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 +doPevalGeneralLtOrdTerm _ _ = Nothing + +-- Le +pevalGeneralLeOrdTerm :: (PEvalOrdTerm 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 +doPevalGeneralLeOrdTerm _ _ = Nothing + +instance PEvalOrdTerm Integer where + pevalLtOrdTerm = binaryUnfoldOnce doPevalLtOrdTerm ltOrdTerm + where + doPevalLtOrdTerm l r = + msum + [ doPevalGeneralLtOrdTerm l r, + case (l, r) of + (ConTerm _ l, AddNumTerm _ (ConTerm _ j) k) -> + Just $ pevalLtOrdTerm (conTerm $ l - j) k + (AddNumTerm _ (ConTerm _ i) j, ConTerm _ k) -> + Just $ pevalLtOrdTerm j (conTerm $ k - i) + ((AddNumTerm _ (ConTerm _ j) k), l) -> + Just $ + pevalLtOrdTerm + (conTerm j) + (pevalSubNumTerm l k) + (j, (AddNumTerm _ (ConTerm _ k) l)) -> + Just $ pevalLtOrdTerm (conTerm $ -k) (pevalSubNumTerm l j) + (l, ConTerm _ r) -> + Just $ pevalLtOrdTerm (conTerm $ -r) (pevalNegNumTerm l) + _ -> Nothing + ] + pevalLeOrdTerm = binaryUnfoldOnce doPevalLeOrdTerm leOrdTerm + where + doPevalLeOrdTerm l r = + msum + [ doPevalGeneralLeOrdTerm l r, + case (l, r) of + (ConTerm _ l, AddNumTerm _ (ConTerm _ j) k) -> + Just $ pevalLeOrdTerm (conTerm $ l - j) k + (AddNumTerm _ (ConTerm _ i) j, ConTerm _ k) -> + Just $ pevalLeOrdTerm j (conTerm $ k - i) + (AddNumTerm _ (ConTerm _ j) k, l) -> + Just $ pevalLeOrdTerm (conTerm j) (pevalSubNumTerm l k) + (j, AddNumTerm _ (ConTerm _ k) l) -> + Just $ pevalLeOrdTerm (conTerm $ -k) (pevalSubNumTerm l j) + (l, ConTerm _ r) -> + Just $ pevalLeOrdTerm (conTerm $ -r) (pevalNegNumTerm l) + _ -> Nothing + ] + withSbvOrdTermConstraint p r = case isZero p of + IsZeroEvidence -> r + NonZeroEvidence -> r + +instance (KnownNat n, 1 <= n) => PEvalOrdTerm (WordN n) where + pevalLtOrdTerm = pevalGeneralLtOrdTerm + pevalLeOrdTerm = pevalGeneralLeOrdTerm + withSbvOrdTermConstraint p r = withPrim @(WordN n) p r + +instance (KnownNat n, 1 <= n) => PEvalOrdTerm (IntN n) where + pevalLtOrdTerm = pevalGeneralLtOrdTerm + pevalLeOrdTerm = pevalGeneralLeOrdTerm + withSbvOrdTermConstraint p r = withPrim @(IntN n) p r diff --git a/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalRotateTerm.hs b/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalRotateTerm.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalRotateTerm.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalRotateTerm +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalRotateTerm + ( pevalFiniteBitsSymRotateRotateLeftTerm, + pevalFiniteBitsSymRotateRotateRightTerm, + ) +where + +import Data.Bits (Bits (rotateR), FiniteBits (finiteBitSize)) +import Data.Proxy (Proxy (Proxy)) +import qualified Data.SBV as SBV +import GHC.TypeLits (KnownNat, type (<=)) +import Grisette.Internal.Core.Data.Class.SymRotate (SymRotate (symRotate)) +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.Prim.Internal.Instances.SupportedPrim (bvIsNonZeroFromGEq1) +import Grisette.Internal.SymPrim.Prim.Internal.Term + ( PEvalRotateTerm (pevalRotateLeftTerm, pevalRotateRightTerm, sbvRotateLeftTerm, sbvRotateRightTerm, withSbvRotateTermConstraint), + SupportedNonFuncPrim (withNonFuncPrim), + Term (ConTerm), + conTerm, + rotateLeftTerm, + rotateRightTerm, + ) +import Grisette.Internal.SymPrim.Prim.Internal.Unfold (unaryUnfoldOnce) + +pevalFiniteBitsSymRotateRotateLeftTerm :: + forall a. + (Integral a, SymRotate a, FiniteBits a, PEvalRotateTerm a) => + Term a -> + Term a -> + Term a +pevalFiniteBitsSymRotateRotateLeftTerm t n = + unaryUnfoldOnce + (`doPevalFiniteBitsSymRotateRotateLeftTerm` n) + (`rotateLeftTerm` n) + t + +doPevalFiniteBitsSymRotateRotateLeftTerm :: + forall a. + (Integral a, SymRotate a, FiniteBits a, PEvalRotateTerm a) => + Term a -> + Term a -> + Maybe (Term a) +doPevalFiniteBitsSymRotateRotateLeftTerm (ConTerm _ a) (ConTerm _ n) + | n >= 0 = Just $ conTerm $ symRotate a n -- Just $ conTerm $ rotateL a (fromIntegral n) +doPevalFiniteBitsSymRotateRotateLeftTerm x (ConTerm _ 0) = Just x +-- doPevalFiniteBitsSymRotateRotateLeftTerm (RotateLeftTerm _ x (ConTerm _ n)) (ConTerm _ n1) +-- | n >= 0 && n1 >= 0 = Just $ pevalFiniteBitsSymRotateRotateLeftTerm x (conTerm $ n + n1) +doPevalFiniteBitsSymRotateRotateLeftTerm x (ConTerm _ n) + | n >= 0 && (fromIntegral n :: Integer) >= fromIntegral bs = + Just $ + pevalFiniteBitsSymRotateRotateLeftTerm + x + (conTerm $ n `mod` fromIntegral bs) + where + bs = finiteBitSize n +doPevalFiniteBitsSymRotateRotateLeftTerm _ _ = Nothing + +pevalFiniteBitsSymRotateRotateRightTerm :: + forall a. + (Integral a, SymRotate a, FiniteBits a, PEvalRotateTerm a) => + Term a -> + Term a -> + Term a +pevalFiniteBitsSymRotateRotateRightTerm t n = + unaryUnfoldOnce + (`doPevalFiniteBitsSymRotateRotateRightTerm` n) + (`rotateRightTerm` n) + t + +doPevalFiniteBitsSymRotateRotateRightTerm :: + forall a. + (Integral a, SymRotate a, FiniteBits a, PEvalRotateTerm a) => + Term a -> + Term a -> + Maybe (Term a) +doPevalFiniteBitsSymRotateRotateRightTerm (ConTerm _ a) (ConTerm _ n) + | n >= 0 = + Just . conTerm $ + rotateR + a + ( fromIntegral $ + (fromIntegral n :: Integer) + `mod` fromIntegral (finiteBitSize n) + ) +doPevalFiniteBitsSymRotateRotateRightTerm x (ConTerm _ 0) = Just x +-- doPevalFiniteBitsSymRotateRotateRightTerm (RotateRightTerm _ x (ConTerm _ n)) (ConTerm _ n1) +-- | n >= 0 && n1 >= 0 = Just $ pevalFiniteBitsSymRotateRotateRightTerm x (conTerm $ n + n1) +doPevalFiniteBitsSymRotateRotateRightTerm x (ConTerm _ n) + | n >= 0 && (fromIntegral n :: Integer) >= fromIntegral bs = + Just $ + pevalFiniteBitsSymRotateRotateRightTerm + x + (conTerm $ n `mod` fromIntegral bs) + where + bs = finiteBitSize n +doPevalFiniteBitsSymRotateRotateRightTerm _ _ = Nothing + +instance (KnownNat n, 1 <= n) => PEvalRotateTerm (IntN n) where + pevalRotateLeftTerm = pevalFiniteBitsSymRotateRotateLeftTerm + pevalRotateRightTerm = pevalFiniteBitsSymRotateRotateRightTerm + withSbvRotateTermConstraint p r = + bvIsNonZeroFromGEq1 (Proxy @n) $ + withNonFuncPrim @(IntN n) p r + + -- SBV's rotateLeft and rotateRight are broken for signed values, so we have to + -- do this + -- https://github.com/LeventErkok/sbv/issues/673 + sbvRotateLeftTerm p l r = + withNonFuncPrim @(IntN n) p $ + withSbvRotateTermConstraint @(IntN n) p $ + SBV.sFromIntegral $ + SBV.sRotateLeft + (SBV.sFromIntegral l :: SBV.SWord n) + (SBV.sFromIntegral r :: SBV.SWord n) + sbvRotateRightTerm p l r = + withNonFuncPrim @(IntN n) p $ + withSbvRotateTermConstraint @(IntN n) p $ + SBV.sFromIntegral $ + SBV.sRotateRight + (SBV.sFromIntegral l :: SBV.SWord n) + (SBV.sFromIntegral r :: SBV.SWord n) + +instance (KnownNat n, 1 <= n) => PEvalRotateTerm (WordN n) where + pevalRotateLeftTerm = pevalFiniteBitsSymRotateRotateLeftTerm + pevalRotateRightTerm = pevalFiniteBitsSymRotateRotateRightTerm + withSbvRotateTermConstraint p r = + bvIsNonZeroFromGEq1 (Proxy @n) $ + withNonFuncPrim @(WordN n) p r diff --git a/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalShiftTerm.hs b/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalShiftTerm.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalShiftTerm.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalShiftTerm +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalShiftTerm + ( pevalFiniteBitsSymShiftShiftLeftTerm, + pevalFiniteBitsSymShiftShiftRightTerm, + ) +where + +import Data.Bits (Bits (isSigned, shiftR, zeroBits), FiniteBits (finiteBitSize)) +import Data.Proxy (Proxy (Proxy)) +import GHC.TypeLits (KnownNat, type (<=)) +import Grisette.Internal.Core.Data.Class.SymShift (SymShift (symShift)) +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.Prim.Internal.Instances.SupportedPrim (bvIsNonZeroFromGEq1) +import Grisette.Internal.SymPrim.Prim.Internal.Term + ( PEvalShiftTerm (pevalShiftLeftTerm, pevalShiftRightTerm, withSbvShiftTermConstraint), + SupportedNonFuncPrim (withNonFuncPrim), + SupportedPrim, + Term (ConTerm), + conTerm, + shiftLeftTerm, + shiftRightTerm, + ) +import Grisette.Internal.SymPrim.Prim.Internal.Unfold (unaryUnfoldOnce) + +pevalFiniteBitsSymShiftShiftLeftTerm :: + forall a. + (Integral a, SymShift a, FiniteBits a, PEvalShiftTerm a) => + Term a -> + Term a -> + Term a +pevalFiniteBitsSymShiftShiftLeftTerm t n = + unaryUnfoldOnce + (`doPevalFiniteBitsSymShiftShiftLeftTerm` n) + (`shiftLeftTerm` n) + t + +doPevalFiniteBitsSymShiftShiftLeftTerm :: + forall a. + (Integral a, SymShift a, FiniteBits a, SupportedPrim a) => + Term a -> + Term a -> + Maybe (Term a) +doPevalFiniteBitsSymShiftShiftLeftTerm (ConTerm _ a) (ConTerm _ n) + | n >= 0 = + if (fromIntegral n :: Integer) >= fromIntegral (finiteBitSize n) + then Just $ conTerm zeroBits + else Just $ conTerm $ symShift a n +doPevalFiniteBitsSymShiftShiftLeftTerm x (ConTerm _ 0) = Just x +-- TODO: Need to handle the overflow case. +-- doPevalShiftLeftTerm (ShiftLeftTerm _ x (ConTerm _ n)) (ConTerm _ n1) +-- | n >= 0 && n1 >= 0 = Just $ pevalShiftLeftTerm x (conTerm $ n + n1) +doPevalFiniteBitsSymShiftShiftLeftTerm _ (ConTerm _ n) + | n >= 0 && (fromIntegral n :: Integer) >= fromIntegral (finiteBitSize n) = + Just $ conTerm zeroBits +doPevalFiniteBitsSymShiftShiftLeftTerm _ _ = Nothing + +pevalFiniteBitsSymShiftShiftRightTerm :: + forall a. + (Integral a, SymShift a, FiniteBits a, PEvalShiftTerm a) => + Term a -> + Term a -> + Term a +pevalFiniteBitsSymShiftShiftRightTerm t n = + unaryUnfoldOnce + (`doPevalFiniteBitsSymShiftShiftRightTerm` n) + (`shiftRightTerm` n) + t + +doPevalFiniteBitsSymShiftShiftRightTerm :: + forall a. + (Integral a, SymShift a, FiniteBits a, SupportedPrim a) => + Term a -> + Term a -> + Maybe (Term a) +doPevalFiniteBitsSymShiftShiftRightTerm (ConTerm _ a) (ConTerm _ n) + | n >= 0 && not (isSigned a) = + if (fromIntegral n :: Integer) >= fromIntegral (finiteBitSize n) + then Just $ conTerm zeroBits + else Just $ conTerm $ shiftR a (fromIntegral n) +doPevalFiniteBitsSymShiftShiftRightTerm (ConTerm _ a) (ConTerm _ n) + -- if n >= 0 then -n must be in the range + | n >= 0 = Just $ conTerm $ symShift a (-n) +doPevalFiniteBitsSymShiftShiftRightTerm x (ConTerm _ 0) = Just x +-- doPevalFiniteBitsSymShiftShiftRightTerm (ShiftRightTerm _ x (ConTerm _ n)) (ConTerm _ n1) +-- | n >= 0 && n1 >= 0 = Just $ pevalFiniteBitsSymShiftShiftRightTerm x (conTerm $ n + n1) +doPevalFiniteBitsSymShiftShiftRightTerm _ (ConTerm _ n) + | not (isSigned n) + && (fromIntegral n :: Integer) >= fromIntegral (finiteBitSize n) = + Just $ conTerm zeroBits +doPevalFiniteBitsSymShiftShiftRightTerm _ _ = Nothing + +instance (KnownNat n, 1 <= n) => PEvalShiftTerm (IntN n) where + pevalShiftLeftTerm = pevalFiniteBitsSymShiftShiftLeftTerm + pevalShiftRightTerm = pevalFiniteBitsSymShiftShiftRightTerm + withSbvShiftTermConstraint p r = + bvIsNonZeroFromGEq1 (Proxy @n) $ + withNonFuncPrim @(IntN n) p r + +instance (KnownNat n, 1 <= n) => PEvalShiftTerm (WordN n) where + pevalShiftLeftTerm = pevalFiniteBitsSymShiftShiftLeftTerm + pevalShiftRightTerm = pevalFiniteBitsSymShiftShiftRightTerm + withSbvShiftTermConstraint p r = + bvIsNonZeroFromGEq1 (Proxy @n) $ + withNonFuncPrim @(WordN n) p r diff --git a/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/SupportedPrim.hs b/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/SupportedPrim.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/SupportedPrim.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# HLINT ignore "Eta reduce" #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +-- | +-- Module : Grisette.Internal.SymPrim.Prim.Internal.Instances.SupportedPrim +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.SymPrim.Prim.Internal.Instances.SupportedPrim + ( bvIsNonZeroFromGEq1, + ) +where + +import Data.Proxy (Proxy (Proxy)) +import Data.SBV (BVIsNonZero, FiniteBits (finiteBitSize)) +import qualified Data.SBV as SBV +import qualified Data.SBV.Dynamic as SBVD +import Data.Type.Bool (If) +import Data.Type.Equality ((:~:) (Refl)) +import Debug.Trace (trace) +import GHC.TypeNats (KnownNat, type (<=)) +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.Prim.Internal.IsZero + ( IsZero, + IsZeroCases (IsZeroEvidence, NonZeroEvidence), + KnownIsZero (isZero), + ) +import Grisette.Internal.SymPrim.Prim.Internal.Term + ( NonFuncSBVRep (NonFuncSBVBaseType), + SBVRep + ( SBVType + ), + SupportedNonFuncPrim (conNonFuncSBVTerm, symNonFuncSBVTerm, withNonFuncPrim), + SupportedPrim + ( conSBVTerm, + defaultValue, + defaultValueDynamic, + parseSMTModelResult, + pevalEqTerm, + pevalITETerm, + pformatCon, + symSBVName, + symSBVTerm, + withPrim + ), + SupportedPrimConstraint + ( PrimConstraint + ), + parseSMTModelResultError, + pevalDefaultEqTerm, + pevalITEBasicTerm, + sbvFresh, + ) +import Grisette.Internal.SymPrim.Prim.ModelValue (ModelValue, toModelValue) +import Grisette.Internal.Utils.Parameterized (unsafeAxiom) +import Type.Reflection (typeRep) + +defaultValueForInteger :: Integer +defaultValueForInteger = 0 + +defaultValueForIntegerDyn :: ModelValue +defaultValueForIntegerDyn = toModelValue defaultValueForInteger + +-- Basic Integer +instance SBVRep Integer where + type SBVType n Integer = SBV.SBV (If (IsZero n) (Integer) (SBV.IntN n)) + +instance SupportedPrimConstraint Integer + +instance SupportedPrim Integer where + pformatCon = show + defaultValue = defaultValueForInteger + defaultValueDynamic _ = defaultValueForIntegerDyn + pevalITETerm = pevalITEBasicTerm + pevalEqTerm = pevalDefaultEqTerm + conSBVTerm p n = case isZero p of + IsZeroEvidence -> fromInteger n + NonZeroEvidence -> fromInteger n + symSBVName symbol _ = show symbol + symSBVTerm p name = case isZero p of + IsZeroEvidence -> sbvFresh name + NonZeroEvidence -> sbvFresh name + withPrim p r = case isZero p of + IsZeroEvidence -> r + NonZeroEvidence -> r + parseSMTModelResult :: Int -> ([([SBVD.CV], SBVD.CV)], SBVD.CV) -> Integer + parseSMTModelResult _ ([], SBVD.CV SBVD.KUnbounded (SBVD.CInteger i)) = i + parseSMTModelResult _ ([([], SBVD.CV SBVD.KUnbounded (SBVD.CInteger i))], _) = i + parseSMTModelResult _ cv = trace (show cv) $ parseSMTModelResultError (typeRep @Integer) cv + +instance NonFuncSBVRep Integer where + type NonFuncSBVBaseType n Integer = If (IsZero n) Integer (SBV.IntN n) + +instance SupportedNonFuncPrim Integer where + conNonFuncSBVTerm = conSBVTerm + symNonFuncSBVTerm = symSBVTerm @Integer + withNonFuncPrim p r = case isZero p of + IsZeroEvidence -> r + NonZeroEvidence -> bvIsNonZeroFromGEq1 p r + +-- Signed BV +instance (KnownNat w, 1 <= w) => SupportedPrimConstraint (IntN w) where + type PrimConstraint _ (IntN w) = (KnownNat w, 1 <= w, BVIsNonZero w) + +instance (KnownNat w, 1 <= w) => SBVRep (IntN w) where + type SBVType _ (IntN w) = SBV.SBV (SBV.IntN w) + +instance (KnownNat w, 1 <= w) => SupportedPrim (IntN w) where + pformatCon = show + defaultValue = 0 + pevalITETerm = pevalITEBasicTerm + pevalEqTerm = pevalDefaultEqTerm + conSBVTerm _ n = bvIsNonZeroFromGEq1 (Proxy @w) $ fromIntegral n + symSBVName symbol _ = show symbol + symSBVTerm _ name = bvIsNonZeroFromGEq1 (Proxy @w) $ sbvFresh name + withPrim _ r = bvIsNonZeroFromGEq1 (Proxy @w) r + parseSMTModelResult :: Int -> ([([SBVD.CV], SBVD.CV)], SBVD.CV) -> IntN w + parseSMTModelResult + _ + ([], SBVD.CV (SBVD.KBounded _ bitWidth) (SBVD.CInteger i)) + | bitWidth == finiteBitSize (undefined :: IntN w) = fromIntegral i + parseSMTModelResult + _ + ([([], SBVD.CV (SBVD.KBounded _ bitWidth) (SBVD.CInteger i))], _) + | bitWidth == finiteBitSize (undefined :: IntN w) = fromIntegral i + parseSMTModelResult _ cv = parseSMTModelResultError (typeRep @(IntN w)) cv + +bvIsNonZeroFromGEq1 :: + forall w r proxy. + (1 <= w) => + proxy w -> + ((SBV.BVIsNonZero w) => r) -> + r +bvIsNonZeroFromGEq1 _ r1 = case unsafeAxiom :: w :~: 1 of + Refl -> r1 + +instance (KnownNat w, 1 <= w) => NonFuncSBVRep (IntN w) where + type NonFuncSBVBaseType _ (IntN w) = SBV.IntN w + +instance (KnownNat w, 1 <= w) => SupportedNonFuncPrim (IntN w) where + conNonFuncSBVTerm = conSBVTerm + symNonFuncSBVTerm = symSBVTerm @(IntN w) + withNonFuncPrim _ r = bvIsNonZeroFromGEq1 (Proxy @w) r + +-- Unsigned BV +instance (KnownNat w, 1 <= w) => SupportedPrimConstraint (WordN w) where + type PrimConstraint _ (WordN w) = (KnownNat w, 1 <= w, BVIsNonZero w) + +instance (KnownNat w, 1 <= w) => SBVRep (WordN w) where + type SBVType _ (WordN w) = SBV.SBV (SBV.WordN w) + +instance (KnownNat w, 1 <= w) => SupportedPrim (WordN w) where + pformatCon = show + defaultValue = 0 + pevalITETerm = pevalITEBasicTerm + pevalEqTerm = pevalDefaultEqTerm + conSBVTerm _ n = bvIsNonZeroFromGEq1 (Proxy @w) $ fromIntegral n + symSBVName symbol _ = show symbol + symSBVTerm _ name = bvIsNonZeroFromGEq1 (Proxy @w) $ sbvFresh name + withPrim _ r = bvIsNonZeroFromGEq1 (Proxy @w) r + parseSMTModelResult + _ + ([], SBVD.CV (SBVD.KBounded _ bitWidth) (SBVD.CInteger i)) + | bitWidth == finiteBitSize (undefined :: WordN w) = fromIntegral i + parseSMTModelResult + _ + ([([], SBVD.CV (SBVD.KBounded _ bitWidth) (SBVD.CInteger i))], _) + | bitWidth == finiteBitSize (undefined :: WordN w) = fromIntegral i + parseSMTModelResult _ cv = parseSMTModelResultError (typeRep @(WordN w)) cv + +instance (KnownNat w, 1 <= w) => NonFuncSBVRep (WordN w) where + type NonFuncSBVBaseType _ (WordN w) = SBV.WordN w + +instance (KnownNat w, 1 <= w) => SupportedNonFuncPrim (WordN w) where + conNonFuncSBVTerm = conSBVTerm + symNonFuncSBVTerm = symSBVTerm @(WordN w) + withNonFuncPrim _ r = bvIsNonZeroFromGEq1 (Proxy @w) r diff --git a/src/Grisette/Internal/SymPrim/Prim/Internal/IsZero.hs b/src/Grisette/Internal/SymPrim/Prim/Internal/IsZero.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/SymPrim/Prim/Internal/IsZero.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Grisette.Internal.SymPrim.Prim.Internal.IsZero + ( IsZero, + KnownIsZero (..), + IsZeroCases (..), + ) +where + +import qualified Data.SBV as SBV +import GHC.TypeNats (KnownNat, Nat, type (<=)) + +type family IsZero (a :: Nat) :: Bool where + IsZero 0 = 'True + IsZero _ = 'False + +data IsZeroCases (a :: Nat) where + IsZeroEvidence :: (IsZero a ~ 'True) => IsZeroCases a + NonZeroEvidence :: + (IsZero a ~ 'False, SBV.BVIsNonZero a, 1 <= a) => + IsZeroCases a + +instance Show (IsZeroCases a) where + show IsZeroEvidence = "IsZeroEvidence" + show NonZeroEvidence = "NonZeroEvidence" + +class (KnownNat a) => KnownIsZero (a :: Nat) where + isZero :: proxy a -> IsZeroCases a + +instance KnownIsZero 0 where + isZero _ = IsZeroEvidence + +instance + {-# OVERLAPPABLE #-} + (KnownNat a, IsZero a ~ 'False, 1 <= a, SBV.BVIsNonZero a) => + KnownIsZero a + where + isZero _ = NonZeroEvidence diff --git a/src/Grisette/Internal/SymPrim/Prim/Internal/PartialEval.hs b/src/Grisette/Internal/SymPrim/Prim/Internal/PartialEval.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/SymPrim/Prim/Internal/PartialEval.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +-- | +-- Module : Grisette.Internal.SymPrim.Prim.PartialEval.PartialEval +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.SymPrim.Prim.Internal.PartialEval + ( PartialFun, + PartialRuleUnary, + TotalRuleUnary, + PartialRuleBinary, + TotalRuleBinary, + totalize, + totalize2, + UnaryPartialStrategy (..), + unaryPartial, + BinaryCommPartialStrategy (..), + BinaryPartialStrategy (..), + binaryPartial, + ) +where + +import Control.Monad.Except (MonadError (catchError)) +import Grisette.Internal.SymPrim.Prim.Internal.Term (Term) + +type PartialFun a b = a -> Maybe b + +type PartialRuleUnary a b = PartialFun (Term a) (Term b) + +type TotalRuleUnary a b = Term a -> Term b + +type PartialRuleBinary a b c = Term a -> PartialFun (Term b) (Term c) + +type TotalRuleBinary a b c = Term a -> Term b -> Term c + +totalize :: PartialFun a b -> (a -> b) -> a -> b +totalize partial fallback a = + case partial a of + Just b -> b + Nothing -> fallback a + +totalize2 :: (a -> PartialFun b c) -> (a -> b -> c) -> a -> b -> c +totalize2 partial fallback a b = + case partial a b of + Just c -> c + Nothing -> fallback a b + +class UnaryPartialStrategy tag a b | tag a -> b where + extractor :: tag -> Term a -> Maybe a + constantHandler :: tag -> a -> Maybe (Term b) + nonConstantHandler :: tag -> Term a -> Maybe (Term b) + +unaryPartial :: forall tag a b. (UnaryPartialStrategy tag a b) => tag -> PartialRuleUnary a b +unaryPartial tag a = case extractor tag a of + Nothing -> nonConstantHandler tag a + Just a' -> constantHandler tag a' + +class BinaryCommPartialStrategy tag a c | tag a -> c where + singleConstantHandler :: tag -> a -> Term a -> Maybe (Term c) + +class BinaryPartialStrategy tag a b c | tag a b -> c where + extractora :: tag -> Term a -> Maybe a + extractorb :: tag -> Term b -> Maybe b + allConstantHandler :: tag -> a -> b -> Maybe (Term c) + leftConstantHandler :: tag -> a -> Term b -> Maybe (Term c) + default leftConstantHandler :: (a ~ b, BinaryCommPartialStrategy tag a c) => tag -> a -> Term b -> Maybe (Term c) + leftConstantHandler = singleConstantHandler @tag @a + rightConstantHandler :: tag -> Term a -> b -> Maybe (Term c) + default rightConstantHandler :: (a ~ b, BinaryCommPartialStrategy tag a c) => tag -> Term a -> b -> Maybe (Term c) + rightConstantHandler tag = flip $ singleConstantHandler @tag @a tag + nonBinaryConstantHandler :: tag -> Term a -> Term b -> Maybe (Term c) + +binaryPartial :: forall tag a b c. (BinaryPartialStrategy tag a b c) => tag -> PartialRuleBinary a b c +binaryPartial tag a b = case (extractora @tag @a @b @c tag a, extractorb @tag @a @b @c tag b) of + (Nothing, Nothing) -> nonBinaryConstantHandler @tag @a @b @c tag a b + (Just a', Nothing) -> + leftConstantHandler @tag @a @b @c tag a' b + `catchError` \_ -> nonBinaryConstantHandler @tag @a @b @c tag a b + (Nothing, Just b') -> + rightConstantHandler @tag @a @b @c tag a b' + `catchError` \_ -> nonBinaryConstantHandler @tag @a @b @c tag a b + (Just a', Just b') -> + allConstantHandler @tag @a @b @c tag a' b' diff --git a/src/Grisette/Internal/SymPrim/Prim/Internal/Term.hs b/src/Grisette/Internal/SymPrim/Prim/Internal/Term.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/SymPrim/Prim/Internal/Term.hs @@ -0,0 +1,2359 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- Module : Grisette.Internal.SymPrim.Prim.Internal.Term +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.SymPrim.Prim.Internal.Term + ( -- * Supported primitive types + SupportedPrimConstraint (..), + SupportedPrim (..), + SymRep (..), + ConRep (..), + LinkedRep (..), + + -- * Partial evaluation for the terms + UnaryOp (..), + BinaryOp (..), + TernaryOp (..), + PEvalApplyTerm (..), + PEvalBitwiseTerm (..), + PEvalShiftTerm (..), + PEvalRotateTerm (..), + PEvalNumTerm (..), + pevalSubNumTerm, + PEvalOrdTerm (..), + pevalGtOrdTerm, + pevalGeOrdTerm, + pevalNEqTerm, + PEvalDivModIntegralTerm (..), + PEvalBVSignConversionTerm (..), + PEvalBVTerm (..), + + -- * Typed symbols + TypedSymbol (..), + SomeTypedSymbol (..), + showUntyped, + withSymbolSupported, + someTypedSymbol, + + -- * Terms + Term (..), + identity, + identityWithTypeRep, + introSupportedPrimConstraint, + pformat, + + -- * Interning + UTerm (..), + prettyPrintTerm, + constructUnary, + constructBinary, + constructTernary, + conTerm, + symTerm, + ssymTerm, + isymTerm, + notTerm, + orTerm, + andTerm, + eqTerm, + iteTerm, + addNumTerm, + negNumTerm, + mulNumTerm, + absNumTerm, + signumNumTerm, + ltOrdTerm, + leOrdTerm, + andBitsTerm, + orBitsTerm, + xorBitsTerm, + complementBitsTerm, + shiftLeftTerm, + shiftRightTerm, + rotateLeftTerm, + rotateRightTerm, + toSignedTerm, + toUnsignedTerm, + bvconcatTerm, + bvselectTerm, + bvextendTerm, + bvsignExtendTerm, + bvzeroExtendTerm, + applyTerm, + divIntegralTerm, + modIntegralTerm, + quotIntegralTerm, + remIntegralTerm, + + -- * Support for boolean type + trueTerm, + falseTerm, + pattern BoolConTerm, + pattern TrueTerm, + pattern FalseTerm, + pattern BoolTerm, + pevalNotTerm, + pevalOrTerm, + pevalAndTerm, + pevalImplyTerm, + pevalXorTerm, + pevalITEBasic, + pevalITEBasicTerm, + pevalDefaultEqTerm, + -- + NonFuncSBVRep (..), + SupportedNonFuncPrim (..), + SBVRep (..), + SBVFreshMonad (..), + translateTypeError, + parseSMTModelResultError, + partitionCVArg, + ) +where + +import Control.DeepSeq (NFData (rnf)) +import Control.Monad (msum) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Reader (MonadTrans (lift), ReaderT) +import Control.Monad.State (StateT) +import Data.Array ((!)) +import Data.Bits (Bits) +import Data.Function (on) +import qualified Data.HashMap.Strict as M +import Data.Hashable (Hashable (hash, hashWithSalt)) +import Data.IORef (atomicModifyIORef') +import Data.Interned + ( Cache, + Id, + Interned (Description, Uninterned, cache, cacheWidth, describe, identify), + ) +import Data.Interned.Internal + ( Cache (getCache), + CacheState (CacheState), + ) +import Data.Kind (Constraint) +import Data.Maybe (fromMaybe) +import qualified Data.SBV as SBV +import qualified Data.SBV.Dynamic as SBVD +import qualified Data.SBV.Trans as SBVT +import qualified Data.SBV.Trans.Control as SBVTC +import Data.String (IsString (fromString)) +import Data.Typeable (Proxy (Proxy), cast) +import GHC.Exts (sortWith) +import GHC.IO (unsafeDupablePerformIO) +import GHC.Stack (HasCallStack) +import GHC.TypeNats (KnownNat, Nat, type (+), type (<=)) +import Grisette.Internal.Core.Data.Class.BitVector + ( SizedBV, + ) +import Grisette.Internal.Core.Data.Class.SignConversion (SignConversion) +import Grisette.Internal.Core.Data.Class.SymRotate (SymRotate) +import Grisette.Internal.Core.Data.Class.SymShift (SymShift) +import Grisette.Internal.Core.Data.Symbol + ( Identifier, + Symbol (IndexedSymbol, SimpleSymbol), + ) +import Grisette.Internal.SymPrim.Prim.Internal.Caches + ( typeMemoizedCache, + ) +import Grisette.Internal.SymPrim.Prim.Internal.IsZero (KnownIsZero) +import Grisette.Internal.SymPrim.Prim.Internal.Utils + ( eqHeteroRep, + eqTypeRepBool, + pattern Dyn, + ) +import Grisette.Internal.SymPrim.Prim.ModelValue + ( ModelValue, + toModelValue, + ) +import Language.Haskell.TH.Syntax (Lift (liftTyped)) +import Type.Reflection + ( SomeTypeRep (SomeTypeRep), + TypeRep, + Typeable, + eqTypeRep, + someTypeRep, + typeRep, + type (:~~:) (HRefl), + ) +import Unsafe.Coerce (unsafeCoerce) + +#if MIN_VERSION_prettyprinter(1,7,0) +import Prettyprinter + ( column, + pageWidth, + Doc, + PageWidth(Unbounded, AvailablePerLine), + Pretty(pretty), + ) +#else +import Data.Text.Prettyprint.Doc + ( column, + pageWidth, + Doc, + PageWidth(Unbounded, AvailablePerLine), + Pretty(pretty), + ) +#endif + +#if !MIN_VERSION_sbv(10, 0, 0) +#define SMTDefinable Uninterpreted +#endif + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim + +-- SBV Translation +class (Monad m) => SBVFreshMonad m where + sbvFresh :: (SBV.SymVal a) => String -> m (SBV.SBV a) + +instance (MonadIO m) => SBVFreshMonad (SBVT.SymbolicT m) where + sbvFresh = SBVT.free + +instance (MonadIO m) => SBVFreshMonad (SBVTC.QueryT m) where + sbvFresh = SBVTC.freshVar + +instance (SBVFreshMonad m) => SBVFreshMonad (ReaderT r m) where + sbvFresh = lift . sbvFresh + +instance (SBVFreshMonad m) => SBVFreshMonad (StateT s m) where + sbvFresh = lift . sbvFresh + +translateTypeError :: (HasCallStack) => Maybe String -> TypeRep a -> b +translateTypeError Nothing ta = + error $ + "Don't know how to translate the type " ++ show ta ++ " to SMT" +translateTypeError (Just reason) ta = + error $ + "Don't know how to translate the type " ++ show ta ++ " to SMT: " <> reason + +class (SupportedPrim a, Ord a) => NonFuncSBVRep a where + type NonFuncSBVBaseType (n :: Nat) a + +class (NonFuncSBVRep a) => SupportedNonFuncPrim a where + conNonFuncSBVTerm :: + (KnownIsZero n) => + proxy n -> + a -> + SBV.SBV (NonFuncSBVBaseType n a) + symNonFuncSBVTerm :: + (SBVFreshMonad m, KnownIsZero n) => + proxy n -> + String -> + m (SBV.SBV (NonFuncSBVBaseType n a)) + withNonFuncPrim :: + (KnownIsZero n) => + proxy n -> + ( ( SBV.SymVal (NonFuncSBVBaseType n a), + SBV.EqSymbolic (SBVType n a), + SBV.Mergeable (SBVType n a), + SBV.SMTDefinable (SBVType n a), + SBV.Mergeable (SBVType n a), + SBVType n a ~ SBV.SBV (NonFuncSBVBaseType n a), + PrimConstraint n a + ) => + r + ) -> + r + +partitionCVArg :: + forall a. + (SupportedNonFuncPrim a) => + [([SBVD.CV], SBVD.CV)] -> + [(a, [([SBVD.CV], SBVD.CV)])] +partitionCVArg cv = + partitionOrdCVArg $ + parseFirstCVArg cv + where + parseFirstCVArg :: + forall a. + (SupportedNonFuncPrim a) => + [([SBVD.CV], SBVD.CV)] -> + [(a, [([SBVD.CV], SBVD.CV)])] + parseFirstCVArg = + fmap + ( \case + (x : xs, v) -> + (parseSMTModelResult 0 ([([], x)], x), [(xs, v)]) + _ -> error "impossible" + ) + partitionOrdCVArg :: + forall a. + (SupportedNonFuncPrim a) => + [(a, [([SBVD.CV], SBVD.CV)])] -> + [(a, [([SBVD.CV], SBVD.CV)])] + partitionOrdCVArg v = go sorted + where + sorted = sortWith fst v :: [(a, [([SBVD.CV], SBVD.CV)])] + go (x : x1 : xs) = + if fst x == fst x1 + then go $ (fst x, snd x ++ snd x1) : xs + else x : go (x1 : xs) + go x = x + +class SBVRep t where + type SBVType (n :: Nat) t + +class SupportedPrimConstraint t where + type PrimConstraint (n :: Nat) t :: Constraint + type PrimConstraint _ _ = () + +-- | Indicates that a type is supported and can be represented as a symbolic +-- term. +class + ( Lift t, + Typeable t, + Hashable t, + Eq t, + Show t, + NFData t, + SupportedPrimConstraint t, + SBVRep t + ) => + SupportedPrim t + where + termCache :: Cache (Term t) + termCache = typeMemoizedCache + pformatCon :: t -> String + default pformatCon :: (Show t) => t -> String + pformatCon = show + pformatSym :: TypedSymbol t -> String + pformatSym = showUntyped + defaultValue :: t + defaultValueDynamic :: proxy t -> ModelValue + defaultValueDynamic _ = toModelValue (defaultValue @t) + pevalITETerm :: Term Bool -> Term t -> Term t -> Term t + pevalEqTerm :: Term t -> Term t -> Term Bool + conSBVTerm :: (KnownIsZero n) => proxy n -> t -> SBVType n t + symSBVName :: TypedSymbol t -> Int -> String + symSBVTerm :: + (SBVFreshMonad m, KnownIsZero n) => + proxy n -> + String -> + m (SBVType n t) + default withPrim :: + ( PrimConstraint n t, + SBV.SMTDefinable (SBVType n t), + SBV.Mergeable (SBVType n t), + Typeable (SBVType n t), + KnownIsZero n + ) => + p n -> + ( ( PrimConstraint n t, + SBV.SMTDefinable (SBVType n t), + SBV.Mergeable (SBVType n t), + Typeable (SBVType n t) + ) => + a + ) -> + a + withPrim :: + (KnownIsZero n) => + p n -> + ( ( PrimConstraint n t, + SBV.SMTDefinable (SBVType n t), + SBV.Mergeable (SBVType n t), + Typeable (SBVType n t) + ) => + a + ) -> + a + withPrim _ i = i + sbvIte :: + (KnownIsZero n) => + proxy n -> + SBV.SBV Bool -> + SBVType n t -> + SBVType n t -> + SBVType n t + sbvIte p = withPrim @t p SBV.ite + sbvEq :: + (KnownIsZero n) => + proxy n -> + SBVType n t -> + SBVType n t -> + SBV.SBV Bool + default sbvEq :: + (KnownIsZero n, SBVT.EqSymbolic (SBVType n t)) => + proxy n -> + SBVType n t -> + SBVType n t -> + SBV.SBV Bool + sbvEq _ = (SBV..==) + parseSMTModelResult :: Int -> ([([SBVD.CV], SBVD.CV)], SBVD.CV) -> t + +parseSMTModelResultError :: TypeRep a -> ([([SBVD.CV], SBVD.CV)], SBVD.CV) -> a +parseSMTModelResultError ty cv = + error $ + "BUG: cannot parse SBV model value \"" + <> show cv + <> "\" to Grisette model value with the type " + <> show ty + +pevalNEqTerm :: (SupportedPrim a) => Term a -> Term a -> Term Bool +pevalNEqTerm l r = pevalNotTerm $ pevalEqTerm l r +{-# INLINE pevalNEqTerm #-} + +-- | Type family to resolve the concrete type associated with a symbolic type. +class ConRep sym where + type ConType sym + +-- | Type family to resolve the symbolic type associated with a concrete type. +class (SupportedPrim con) => SymRep con where + type SymType con + +-- | One-to-one mapping between symbolic types and concrete types. +class + (ConRep sym, SymRep con, sym ~ SymType con, con ~ ConType sym) => + LinkedRep con sym + | con -> sym, + sym -> con + where + underlyingTerm :: sym -> Term con + wrapTerm :: Term con -> sym + +-- Partial Evaluation for the terms +class + (SupportedPrim f, SupportedPrim a, SupportedPrim b) => + PEvalApplyTerm f a b + | f -> a b + where + pevalApplyTerm :: Term f -> Term a -> Term b + sbvApplyTerm :: + (KnownIsZero n) => proxy n -> SBVType n f -> SBVType n a -> SBVType n b + +class (SupportedPrim t, Bits t) => PEvalBitwiseTerm t where + pevalAndBitsTerm :: Term t -> Term t -> Term t + pevalOrBitsTerm :: Term t -> Term t -> Term t + pevalXorBitsTerm :: Term t -> Term t -> Term t + pevalComplementBitsTerm :: Term t -> Term t + withSbvBitwiseTermConstraint :: + (KnownIsZero n) => + proxy n -> + (((Bits (SBVType n t)) => r)) -> + r + sbvAndBitsTerm :: + (KnownIsZero n) => proxy n -> SBVType n t -> SBVType n t -> SBVType n t + sbvAndBitsTerm p = withSbvBitwiseTermConstraint @t p (SBV..&.) + sbvOrBitsTerm :: + (KnownIsZero n) => proxy n -> SBVType n t -> SBVType n t -> SBVType n t + sbvOrBitsTerm p = withSbvBitwiseTermConstraint @t p (SBV..|.) + sbvXorBitsTerm :: + (KnownIsZero n) => proxy n -> SBVType n t -> SBVType n t -> SBVType n t + sbvXorBitsTerm p = withSbvBitwiseTermConstraint @t p SBV.xor + sbvComplementBitsTerm :: + (KnownIsZero n) => proxy n -> SBVType n t -> SBVType n t + sbvComplementBitsTerm p = withSbvBitwiseTermConstraint @t p SBV.complement + +class (SupportedNonFuncPrim t, SymShift t) => PEvalShiftTerm t where + pevalShiftLeftTerm :: Term t -> Term t -> Term t + pevalShiftRightTerm :: Term t -> Term t -> Term t + withSbvShiftTermConstraint :: + (KnownIsZero n) => + proxy n -> + (((SBV.SIntegral (NonFuncSBVBaseType n t)) => r)) -> + r + sbvShiftLeftTerm :: + forall proxy n. + (KnownIsZero n) => + proxy n -> + SBVType n t -> + SBVType n t -> + SBVType n t + sbvShiftLeftTerm p l r = + withNonFuncPrim @t p $ + withSbvShiftTermConstraint @t p $ + SBV.sShiftLeft l r + sbvShiftRightTerm :: + forall proxy n. + (KnownIsZero n) => + proxy n -> + SBVType n t -> + SBVType n t -> + SBVType n t + sbvShiftRightTerm p l r = + withNonFuncPrim @t p $ + withSbvShiftTermConstraint @t p $ + SBV.sShiftRight l r + +class (SupportedNonFuncPrim t, SymRotate t) => PEvalRotateTerm t where + pevalRotateLeftTerm :: Term t -> Term t -> Term t + pevalRotateRightTerm :: Term t -> Term t -> Term t + withSbvRotateTermConstraint :: + (KnownIsZero n) => + proxy n -> + (((SBV.SIntegral (NonFuncSBVBaseType n t)) => r)) -> + r + sbvRotateLeftTerm :: + forall proxy n. + (KnownIsZero n) => + proxy n -> + SBVType n t -> + SBVType n t -> + SBVType n t + sbvRotateLeftTerm p l r = + withNonFuncPrim @t p $ + withSbvRotateTermConstraint @t p $ + SBV.sRotateLeft l r + sbvRotateRightTerm :: + forall proxy n. + (KnownIsZero n) => + proxy n -> + SBVType n t -> + SBVType n t -> + SBVType n t + sbvRotateRightTerm p l r = + withNonFuncPrim @t p $ + withSbvRotateTermConstraint @t p $ + SBV.sRotateRight l r + +class (SupportedPrim t, Num t) => PEvalNumTerm t where + pevalAddNumTerm :: Term t -> Term t -> Term t + pevalNegNumTerm :: Term t -> Term t + pevalMulNumTerm :: Term t -> Term t -> Term t + pevalAbsNumTerm :: Term t -> Term t + pevalSignumNumTerm :: Term t -> Term t + withSbvNumTermConstraint :: + (KnownIsZero n) => + proxy n -> + (((Num (SBVType n t)) => r)) -> + r + sbvAddNumTerm :: + forall proxy n. + (KnownIsZero n) => + proxy n -> + SBVType n t -> + SBVType n t -> + SBVType n t + sbvAddNumTerm p l r = withSbvNumTermConstraint @t p $ l + r + sbvNegNumTerm :: + forall proxy n. + (KnownIsZero n) => + proxy n -> + SBVType n t -> + SBVType n t + sbvNegNumTerm p l = withSbvNumTermConstraint @t p $ -l + sbvMulNumTerm :: + forall proxy n. + (KnownIsZero n) => + proxy n -> + SBVType n t -> + SBVType n t -> + SBVType n t + sbvMulNumTerm p l r = withSbvNumTermConstraint @t p $ l * r + sbvAbsNumTerm :: + forall proxy n. + (KnownIsZero n) => + proxy n -> + SBVType n t -> + SBVType n t + sbvAbsNumTerm p l = withSbvNumTermConstraint @t p $ abs l + sbvSignumNumTerm :: + forall proxy n. + (KnownIsZero n) => + proxy n -> + SBVType n t -> + SBVType n t + sbvSignumNumTerm p l = withSbvNumTermConstraint @t p $ signum l + +pevalSubNumTerm :: (PEvalNumTerm a) => Term a -> Term a -> Term a +pevalSubNumTerm l r = pevalAddNumTerm l (pevalNegNumTerm r) + +class (SupportedPrim t, Ord t) => PEvalOrdTerm t where + pevalLtOrdTerm :: Term t -> Term t -> Term Bool + pevalLeOrdTerm :: Term t -> Term t -> Term Bool + withSbvOrdTermConstraint :: + (KnownIsZero n) => + proxy n -> + (((SBV.OrdSymbolic (SBVType n t)) => r)) -> + r + sbvLtOrdTerm :: + (KnownIsZero n) => + proxy n -> + SBVType n t -> + SBVType n t -> + SBV.SBV Bool + sbvLtOrdTerm p l r = withSbvOrdTermConstraint @t p $ l SBV..< r + sbvLeOrdTerm :: + (KnownIsZero n) => + proxy n -> + SBVType n t -> + SBVType n t -> + SBV.SBV Bool + sbvLeOrdTerm p l r = withSbvOrdTermConstraint @t p $ l SBV..<= r + +pevalGtOrdTerm :: (PEvalOrdTerm a) => Term a -> Term a -> Term Bool +pevalGtOrdTerm = flip pevalLtOrdTerm + +pevalGeOrdTerm :: (PEvalOrdTerm a) => Term a -> Term a -> Term Bool +pevalGeOrdTerm = flip pevalLeOrdTerm + +class (SupportedPrim t, Integral t) => PEvalDivModIntegralTerm t where + pevalDivIntegralTerm :: Term t -> Term t -> Term t + pevalModIntegralTerm :: Term t -> Term t -> Term t + pevalQuotIntegralTerm :: Term t -> Term t -> Term t + pevalRemIntegralTerm :: Term t -> Term t -> Term t + withSbvDivModIntegralTermConstraint :: + (KnownIsZero n) => + proxy n -> + (((SBV.SDivisible (SBVType n t)) => r)) -> + r + sbvDivIntegralTerm :: + forall proxy n. + (KnownIsZero n) => + proxy n -> + SBVType n t -> + SBVType n t -> + SBVType n t + sbvDivIntegralTerm p l r = + withSbvDivModIntegralTermConstraint @t p $ l `SBV.sDiv` r + sbvModIntegralTerm :: + forall proxy n. + (KnownIsZero n) => + proxy n -> + SBVType n t -> + SBVType n t -> + SBVType n t + sbvModIntegralTerm p l r = + withSbvDivModIntegralTermConstraint @t p $ l `SBV.sMod` r + sbvQuotIntegralTerm :: + forall proxy n. + (KnownIsZero n) => + proxy n -> + SBVType n t -> + SBVType n t -> + SBVType n t + sbvQuotIntegralTerm p l r = + withSbvDivModIntegralTermConstraint @t p $ l `SBV.sQuot` r + sbvRemIntegralTerm :: + forall proxy n. + (KnownIsZero n) => + proxy n -> + SBVType n t -> + SBVType n t -> + SBVType n t + sbvRemIntegralTerm p l r = + withSbvDivModIntegralTermConstraint @t p $ l `SBV.sRem` r + +class + ( PEvalBVTerm s, + PEvalBVTerm u, + forall n. (KnownNat n, 1 <= n) => SupportedNonFuncPrim (u n), + forall n. (KnownNat n, 1 <= n) => SupportedNonFuncPrim (s n), + forall n. (KnownNat n, 1 <= n) => SignConversion (u n) (s n) + ) => + PEvalBVSignConversionTerm u s + | u -> s, + s -> u + where + pevalBVToSignedTerm :: (KnownNat n, 1 <= n) => Term (u n) -> Term (s n) + pevalBVToUnsignedTerm :: (KnownNat n, 1 <= n) => Term (s n) -> Term (u n) + withSbvSignConversionTermConstraint :: + forall n integerBitwidth p q r. + (KnownIsZero integerBitwidth, KnownNat n, 1 <= n) => + p n -> + q integerBitwidth -> + ( ( ( Integral (NonFuncSBVBaseType integerBitwidth (u n)), + Integral (NonFuncSBVBaseType integerBitwidth (s n)) + ) => + r + ) + ) -> + r + sbvToSigned :: + forall n integerBitwidth o p q. + (KnownIsZero integerBitwidth, KnownNat n, 1 <= n) => + o u -> + p n -> + q integerBitwidth -> + SBVType integerBitwidth (u n) -> + SBVType integerBitwidth (s n) + sbvToSigned _ _ qint u = + withNonFuncPrim @(u n) qint $ + withNonFuncPrim @(s n) qint $ + withSbvSignConversionTermConstraint @u @s (Proxy @n) qint $ + SBV.sFromIntegral u + sbvToUnsigned :: + forall n integerBitwidth o p q. + (KnownIsZero integerBitwidth, KnownNat n, 1 <= n) => + o s -> + p n -> + q integerBitwidth -> + SBVType integerBitwidth (s n) -> + SBVType integerBitwidth (u n) + sbvToUnsigned _ _ qint u = + withNonFuncPrim @(u n) qint $ + withNonFuncPrim @(s n) qint $ + withSbvSignConversionTermConstraint @u @s (Proxy @n) qint $ + SBV.sFromIntegral u + +class + ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n), + SizedBV bv, + Typeable bv + ) => + PEvalBVTerm bv + where + pevalBVConcatTerm :: + (KnownNat l, KnownNat r, 1 <= l, 1 <= r) => + Term (bv l) -> + Term (bv r) -> + Term (bv (l + r)) + pevalBVExtendTerm :: + (KnownNat l, KnownNat r, 1 <= l, 1 <= r, l <= r) => + Bool -> + proxy r -> + Term (bv l) -> + Term (bv r) + pevalBVSelectTerm :: + (KnownNat n, KnownNat ix, KnownNat w, 1 <= n, 1 <= w, ix + w <= n) => + p ix -> + q w -> + Term (bv n) -> + Term (bv w) + sbvBVConcatTerm :: + (KnownIsZero n, KnownNat l, KnownNat r, 1 <= l, 1 <= r) => + p0 n -> + p1 l -> + p2 r -> + SBVType n (bv l) -> + SBVType n (bv r) -> + SBVType n (bv (l + r)) + sbvBVExtendTerm :: + (KnownIsZero n, KnownNat l, KnownNat r, 1 <= l, 1 <= r, l <= r) => + p0 n -> + p1 l -> + p2 r -> + Bool -> + SBVType n (bv l) -> + SBVType n (bv r) + sbvBVSelectTerm :: + ( KnownIsZero int, + KnownNat ix, + KnownNat w, + KnownNat n, + 1 <= n, + 1 <= w, + ix + w <= n + ) => + p0 int -> + p1 ix -> + p2 w -> + p3 n -> + SBVType int (bv n) -> + SBVType int (bv w) + +class + (SupportedPrim arg, SupportedPrim t, Lift tag, NFData tag, Show tag, Typeable tag, Eq tag, Hashable tag) => + UnaryOp tag arg t + | tag arg -> t + where + pevalUnary :: (Typeable tag, Typeable t) => tag -> Term arg -> Term t + pformatUnary :: tag -> Term arg -> String + +class + ( SupportedPrim arg1, + SupportedPrim arg2, + SupportedPrim t, + Lift tag, + NFData tag, + Show tag, + Typeable tag, + Eq tag, + Hashable tag + ) => + BinaryOp tag arg1 arg2 t + | tag arg1 arg2 -> t + where + pevalBinary :: (Typeable tag, Typeable t) => tag -> Term arg1 -> Term arg2 -> Term t + pformatBinary :: tag -> Term arg1 -> Term arg2 -> String + +class + ( SupportedPrim arg1, + SupportedPrim arg2, + SupportedPrim arg3, + SupportedPrim t, + Lift tag, + NFData tag, + Show tag, + Typeable tag, + Eq tag, + Hashable tag + ) => + TernaryOp tag arg1 arg2 arg3 t + | tag arg1 arg2 arg3 -> t + where + pevalTernary :: (Typeable tag, Typeable t) => tag -> Term arg1 -> Term arg2 -> Term arg3 -> Term t + pformatTernary :: tag -> Term arg1 -> Term arg2 -> Term arg3 -> String + +-- Typed Symbols + +-- | A typed symbol is a symbol that is associated with a type. Note that the +-- same symbol bodies with different types are considered different symbols +-- and can coexist in a term. +-- +-- Simple symbols can be created with the 'OverloadedStrings' extension: +-- +-- >>> :set -XOverloadedStrings +-- >>> "a" :: TypedSymbol Bool +-- a :: Bool +data TypedSymbol t where + TypedSymbol :: (SupportedPrim t) => {unTypedSymbol :: Symbol} -> TypedSymbol t + +instance Eq (TypedSymbol t) where + TypedSymbol x == TypedSymbol y = x == y + +instance Ord (TypedSymbol t) where + TypedSymbol x <= TypedSymbol y = x <= y + +instance Lift (TypedSymbol t) where + liftTyped (TypedSymbol x) = [||TypedSymbol x||] + +instance Show (TypedSymbol t) where + show (TypedSymbol symbol) = show symbol ++ " :: " ++ show (typeRep @t) + +showUntyped :: TypedSymbol t -> String +showUntyped (TypedSymbol symbol) = show symbol + +instance Hashable (TypedSymbol t) where + s `hashWithSalt` TypedSymbol x = s `hashWithSalt` x + +instance NFData (TypedSymbol t) where + rnf (TypedSymbol str) = rnf str + +instance (SupportedPrim t) => IsString (TypedSymbol t) where + fromString = TypedSymbol . fromString + +withSymbolSupported :: TypedSymbol t -> ((SupportedPrim t) => a) -> a +withSymbolSupported (TypedSymbol _) a = a + +data SomeTypedSymbol where + SomeTypedSymbol :: forall t. TypeRep t -> TypedSymbol t -> SomeTypedSymbol + +instance NFData SomeTypedSymbol where + rnf (SomeTypedSymbol p s) = rnf (SomeTypeRep p) `seq` rnf s + +instance Eq SomeTypedSymbol where + (SomeTypedSymbol t1 s1) == (SomeTypedSymbol t2 s2) = case eqTypeRep t1 t2 of + Just HRefl -> s1 == s2 + _ -> False + +instance Ord SomeTypedSymbol where + (SomeTypedSymbol t1 s1) <= (SomeTypedSymbol t2 s2) = + SomeTypeRep t1 < SomeTypeRep t2 + || ( case eqTypeRep t1 t2 of + Just HRefl -> s1 <= s2 + _ -> False + ) + +instance Hashable SomeTypedSymbol where + hashWithSalt s (SomeTypedSymbol t1 s1) = s `hashWithSalt` s1 `hashWithSalt` t1 + +instance Show SomeTypedSymbol where + show (SomeTypedSymbol _ s) = show s + +someTypedSymbol :: forall t. TypedSymbol t -> SomeTypedSymbol +someTypedSymbol s@(TypedSymbol _) = SomeTypedSymbol (typeRep @t) s + +-- Terms + +data Term t where + ConTerm :: (SupportedPrim t) => {-# UNPACK #-} !Id -> !t -> Term t + SymTerm :: (SupportedPrim t) => {-# UNPACK #-} !Id -> !(TypedSymbol t) -> Term t + UnaryTerm :: + (UnaryOp tag arg t) => + {-# UNPACK #-} !Id -> + !tag -> + !(Term arg) -> + Term t + BinaryTerm :: + (BinaryOp tag arg1 arg2 t) => + {-# UNPACK #-} !Id -> + !tag -> + !(Term arg1) -> + !(Term arg2) -> + Term t + TernaryTerm :: + (TernaryOp tag arg1 arg2 arg3 t) => + {-# UNPACK #-} !Id -> + !tag -> + !(Term arg1) -> + !(Term arg2) -> + !(Term arg3) -> + Term t + NotTerm :: {-# UNPACK #-} !Id -> !(Term Bool) -> Term Bool + OrTerm :: {-# UNPACK #-} !Id -> !(Term Bool) -> !(Term Bool) -> Term Bool + AndTerm :: {-# UNPACK #-} !Id -> !(Term Bool) -> !(Term Bool) -> Term Bool + EqTerm :: + (SupportedPrim t) => + {-# UNPACK #-} !Id -> + !(Term t) -> + !(Term t) -> + Term Bool + ITETerm :: + (SupportedPrim t) => + {-# UNPACK #-} !Id -> + !(Term Bool) -> + !(Term t) -> + !(Term t) -> + Term t + AddNumTerm :: + (PEvalNumTerm t) => + {-# UNPACK #-} !Id -> + !(Term t) -> + !(Term t) -> + Term t + NegNumTerm :: + (PEvalNumTerm t) => + {-# UNPACK #-} !Id -> + !(Term t) -> + Term t + MulNumTerm :: + (PEvalNumTerm t) => + {-# UNPACK #-} !Id -> + !(Term t) -> + !(Term t) -> + Term t + AbsNumTerm :: + (PEvalNumTerm t) => {-# UNPACK #-} !Id -> !(Term t) -> Term t + SignumNumTerm :: (PEvalNumTerm t) => {-# UNPACK #-} !Id -> !(Term t) -> Term t + LtOrdTerm :: + (PEvalOrdTerm t) => + {-# UNPACK #-} !Id -> + !(Term t) -> + !(Term t) -> + Term Bool + LeOrdTerm :: + (PEvalOrdTerm t) => + {-# UNPACK #-} !Id -> + !(Term t) -> + !(Term t) -> + Term Bool + AndBitsTerm :: + (PEvalBitwiseTerm t) => + {-# UNPACK #-} !Id -> + !(Term t) -> + !(Term t) -> + Term t + OrBitsTerm :: + (PEvalBitwiseTerm t) => + {-# UNPACK #-} !Id -> + !(Term t) -> + !(Term t) -> + Term t + XorBitsTerm :: + (PEvalBitwiseTerm t) => + {-# UNPACK #-} !Id -> + !(Term t) -> + !(Term t) -> + Term t + ComplementBitsTerm :: + (PEvalBitwiseTerm t) => + {-# UNPACK #-} !Id -> + !(Term t) -> + Term t + ShiftLeftTerm :: + (PEvalShiftTerm t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t + ShiftRightTerm :: + (PEvalShiftTerm t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t + RotateLeftTerm :: + (PEvalRotateTerm t) => + {-# UNPACK #-} !Id -> + !(Term t) -> + !(Term t) -> + Term t + RotateRightTerm :: + (PEvalRotateTerm t) => + {-# UNPACK #-} !Id -> + !(Term t) -> + !(Term t) -> + Term t + ToSignedTerm :: + (PEvalBVSignConversionTerm u s, KnownNat n, 1 <= n) => + {-# UNPACK #-} !Id -> + !(Term (u n)) -> + Term (s n) + ToUnsignedTerm :: + (PEvalBVSignConversionTerm u s, KnownNat n, 1 <= n) => + {-# UNPACK #-} !Id -> + !(Term (s n)) -> + Term (u n) + BVConcatTerm :: + ( PEvalBVTerm bv, + KnownNat l, + KnownNat r, + KnownNat (l + r), + 1 <= l, + 1 <= r, + 1 <= l + r + ) => + {-# UNPACK #-} !Id -> + !(Term (bv l)) -> + !(Term (bv r)) -> + Term (bv (l + r)) + BVSelectTerm :: + ( PEvalBVTerm bv, + KnownNat n, + KnownNat ix, + KnownNat w, + 1 <= n, + 1 <= w, + ix + w <= n + ) => + {-# UNPACK #-} !Id -> + !(TypeRep ix) -> + !(TypeRep w) -> + !(Term (bv n)) -> + Term (bv w) + BVExtendTerm :: + (PEvalBVTerm bv, KnownNat l, KnownNat r, 1 <= l, 1 <= r, l <= r) => + {-# UNPACK #-} !Id -> + !Bool -> + !(TypeRep r) -> + !(Term (bv l)) -> + Term (bv r) + ApplyTerm :: + ( SupportedPrim a, + SupportedPrim b, + SupportedPrim f, + PEvalApplyTerm f a b + ) => + {-# UNPACK #-} !Id -> + !(Term f) -> + !(Term a) -> + Term b + DivIntegralTerm :: + (PEvalDivModIntegralTerm t) => + {-# UNPACK #-} !Id -> + !(Term t) -> + !(Term t) -> + Term t + ModIntegralTerm :: + (PEvalDivModIntegralTerm t) => + {-# UNPACK #-} !Id -> + !(Term t) -> + !(Term t) -> + Term t + QuotIntegralTerm :: + (PEvalDivModIntegralTerm t) => + {-# UNPACK #-} !Id -> + !(Term t) -> + !(Term t) -> + Term t + RemIntegralTerm :: + (PEvalDivModIntegralTerm t) => + {-# UNPACK #-} !Id -> + !(Term t) -> + !(Term t) -> + Term t + +identity :: Term t -> Id +identity = snd . identityWithTypeRep +{-# INLINE identity #-} + +identityWithTypeRep :: forall t. Term t -> (SomeTypeRep, Id) +identityWithTypeRep (ConTerm i _) = (someTypeRep (Proxy @t), i) +identityWithTypeRep (SymTerm i _) = (someTypeRep (Proxy @t), i) +identityWithTypeRep (UnaryTerm i _ _) = (someTypeRep (Proxy @t), i) +identityWithTypeRep (BinaryTerm i _ _ _) = (someTypeRep (Proxy @t), i) +identityWithTypeRep (TernaryTerm i _ _ _ _) = (someTypeRep (Proxy @t), i) +identityWithTypeRep (NotTerm i _) = (someTypeRep (Proxy @t), i) +identityWithTypeRep (OrTerm i _ _) = (someTypeRep (Proxy @t), i) +identityWithTypeRep (AndTerm i _ _) = (someTypeRep (Proxy @t), i) +identityWithTypeRep (EqTerm i _ _) = (someTypeRep (Proxy @t), i) +identityWithTypeRep (ITETerm i _ _ _) = (someTypeRep (Proxy @t), i) +identityWithTypeRep (AddNumTerm i _ _) = (someTypeRep (Proxy @t), i) +identityWithTypeRep (NegNumTerm i _) = (someTypeRep (Proxy @t), i) +identityWithTypeRep (MulNumTerm i _ _) = (someTypeRep (Proxy @t), i) +identityWithTypeRep (AbsNumTerm i _) = (someTypeRep (Proxy @t), i) +identityWithTypeRep (SignumNumTerm i _) = (someTypeRep (Proxy @t), i) +identityWithTypeRep (LtOrdTerm i _ _) = (someTypeRep (Proxy @t), i) +identityWithTypeRep (LeOrdTerm i _ _) = (someTypeRep (Proxy @t), i) +identityWithTypeRep (AndBitsTerm i _ _) = (someTypeRep (Proxy @t), i) +identityWithTypeRep (OrBitsTerm i _ _) = (someTypeRep (Proxy @t), i) +identityWithTypeRep (XorBitsTerm i _ _) = (someTypeRep (Proxy @t), i) +identityWithTypeRep (ComplementBitsTerm i _) = (someTypeRep (Proxy @t), i) +identityWithTypeRep (ShiftLeftTerm i _ _) = (someTypeRep (Proxy @t), i) +identityWithTypeRep (ShiftRightTerm i _ _) = (someTypeRep (Proxy @t), i) +identityWithTypeRep (RotateLeftTerm i _ _) = (someTypeRep (Proxy @t), i) +identityWithTypeRep (RotateRightTerm i _ _) = (someTypeRep (Proxy @t), i) +identityWithTypeRep (ToSignedTerm i _) = (someTypeRep (Proxy @t), i) +identityWithTypeRep (ToUnsignedTerm i _) = (someTypeRep (Proxy @t), i) +identityWithTypeRep (BVConcatTerm i _ _) = (someTypeRep (Proxy @t), i) +identityWithTypeRep (BVSelectTerm i _ _ _) = (someTypeRep (Proxy @t), i) +identityWithTypeRep (BVExtendTerm i _ _ _) = (someTypeRep (Proxy @t), i) +identityWithTypeRep (ApplyTerm i _ _) = (someTypeRep (Proxy @t), i) +identityWithTypeRep (DivIntegralTerm i _ _) = (someTypeRep (Proxy @t), i) +identityWithTypeRep (ModIntegralTerm i _ _) = (someTypeRep (Proxy @t), i) +identityWithTypeRep (QuotIntegralTerm i _ _) = (someTypeRep (Proxy @t), i) +identityWithTypeRep (RemIntegralTerm i _ _) = (someTypeRep (Proxy @t), i) +{-# INLINE identityWithTypeRep #-} + +introSupportedPrimConstraint :: forall t a. Term t -> ((SupportedPrim t) => a) -> a +introSupportedPrimConstraint ConTerm {} x = x +introSupportedPrimConstraint SymTerm {} x = x +introSupportedPrimConstraint UnaryTerm {} x = x +introSupportedPrimConstraint BinaryTerm {} x = x +introSupportedPrimConstraint TernaryTerm {} x = x +introSupportedPrimConstraint NotTerm {} x = x +introSupportedPrimConstraint OrTerm {} x = x +introSupportedPrimConstraint AndTerm {} x = x +introSupportedPrimConstraint EqTerm {} x = x +introSupportedPrimConstraint ITETerm {} x = x +introSupportedPrimConstraint AddNumTerm {} x = x +introSupportedPrimConstraint NegNumTerm {} x = x +introSupportedPrimConstraint MulNumTerm {} x = x +introSupportedPrimConstraint AbsNumTerm {} x = x +introSupportedPrimConstraint SignumNumTerm {} x = x +introSupportedPrimConstraint LtOrdTerm {} x = x +introSupportedPrimConstraint LeOrdTerm {} x = x +introSupportedPrimConstraint AndBitsTerm {} x = x +introSupportedPrimConstraint OrBitsTerm {} x = x +introSupportedPrimConstraint XorBitsTerm {} x = x +introSupportedPrimConstraint ComplementBitsTerm {} x = x +introSupportedPrimConstraint ShiftLeftTerm {} x = x +introSupportedPrimConstraint RotateLeftTerm {} x = x +introSupportedPrimConstraint ShiftRightTerm {} x = x +introSupportedPrimConstraint RotateRightTerm {} x = x +introSupportedPrimConstraint ToSignedTerm {} x = x +introSupportedPrimConstraint ToUnsignedTerm {} x = x +introSupportedPrimConstraint BVConcatTerm {} x = x +introSupportedPrimConstraint BVSelectTerm {} x = x +introSupportedPrimConstraint BVExtendTerm {} x = x +introSupportedPrimConstraint ApplyTerm {} x = x +introSupportedPrimConstraint DivIntegralTerm {} x = x +introSupportedPrimConstraint ModIntegralTerm {} x = x +introSupportedPrimConstraint QuotIntegralTerm {} x = x +introSupportedPrimConstraint RemIntegralTerm {} x = x +{-# INLINE introSupportedPrimConstraint #-} + +pformat :: forall t. (SupportedPrim t) => Term t -> String +pformat (ConTerm _ t) = pformatCon t +pformat (SymTerm _ sym) = pformatSym sym +pformat (UnaryTerm _ tag arg1) = pformatUnary tag arg1 +pformat (BinaryTerm _ tag arg1 arg2) = pformatBinary tag arg1 arg2 +pformat (TernaryTerm _ tag arg1 arg2 arg3) = pformatTernary tag arg1 arg2 arg3 +pformat (NotTerm _ arg) = "(! " ++ pformat arg ++ ")" +pformat (OrTerm _ arg1 arg2) = "(|| " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" +pformat (AndTerm _ arg1 arg2) = "(&& " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" +pformat (EqTerm _ arg1 arg2) = "(= " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" +pformat (ITETerm _ cond arg1 arg2) = "(ite " ++ pformat cond ++ " " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" +pformat (AddNumTerm _ arg1 arg2) = "(+ " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" +pformat (NegNumTerm _ arg) = "(- " ++ pformat arg ++ ")" +pformat (MulNumTerm _ arg1 arg2) = "(* " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" +pformat (AbsNumTerm _ arg) = "(abs " ++ pformat arg ++ ")" +pformat (SignumNumTerm _ arg) = "(signum " ++ pformat arg ++ ")" +pformat (LtOrdTerm _ arg1 arg2) = "(< " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" +pformat (LeOrdTerm _ arg1 arg2) = "(<= " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" +pformat (AndBitsTerm _ arg1 arg2) = "(& " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" +pformat (OrBitsTerm _ arg1 arg2) = "(| " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" +pformat (XorBitsTerm _ arg1 arg2) = "(^ " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" +pformat (ComplementBitsTerm _ arg) = "(~ " ++ pformat arg ++ ")" +pformat (ShiftLeftTerm _ arg n) = "(shl " ++ pformat arg ++ " " ++ pformat n ++ ")" +pformat (ShiftRightTerm _ arg n) = "(shr " ++ pformat arg ++ " " ++ pformat n ++ ")" +pformat (RotateLeftTerm _ arg n) = "(rotl " ++ pformat arg ++ " " ++ pformat n ++ ")" +pformat (RotateRightTerm _ arg n) = "(rotr " ++ pformat arg ++ " " ++ pformat n ++ ")" +pformat (ToSignedTerm _ arg) = "(u2s " ++ pformat arg ++ " " ++ ")" +pformat (ToUnsignedTerm _ arg) = "(s2u " ++ pformat arg ++ " " ++ ")" +pformat (BVConcatTerm _ arg1 arg2) = "(bvconcat " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" +pformat (BVSelectTerm _ ix w arg) = "(bvselect " ++ show ix ++ " " ++ show w ++ " " ++ pformat arg ++ ")" +pformat (BVExtendTerm _ signed n arg) = + (if signed then "(bvsext " else "(bvzext ") ++ show n ++ " " ++ pformat arg ++ ")" +pformat (ApplyTerm _ func arg) = "(apply " ++ pformat func ++ " " ++ pformat arg ++ ")" +pformat (DivIntegralTerm _ arg1 arg2) = "(div " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" +pformat (ModIntegralTerm _ arg1 arg2) = "(mod " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" +pformat (QuotIntegralTerm _ arg1 arg2) = "(quot " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" +pformat (RemIntegralTerm _ arg1 arg2) = "(rem " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" +{-# INLINE pformat #-} + +instance NFData (Term a) where + rnf i = identity i `seq` () + +instance Lift (Term t) where + liftTyped (ConTerm _ i) = [||conTerm i||] + liftTyped (SymTerm _ sym) = [||symTerm (unTypedSymbol sym)||] + liftTyped (UnaryTerm _ tag arg) = [||constructUnary tag arg||] + liftTyped (BinaryTerm _ tag arg1 arg2) = [||constructBinary tag arg1 arg2||] + liftTyped (TernaryTerm _ tag arg1 arg2 arg3) = [||constructTernary tag arg1 arg2 arg3||] + liftTyped (NotTerm _ arg) = [||notTerm arg||] + liftTyped (OrTerm _ arg1 arg2) = [||orTerm arg1 arg2||] + liftTyped (AndTerm _ arg1 arg2) = [||andTerm arg1 arg2||] + liftTyped (EqTerm _ arg1 arg2) = [||eqTerm arg1 arg2||] + liftTyped (ITETerm _ cond arg1 arg2) = [||iteTerm cond arg1 arg2||] + liftTyped (AddNumTerm _ arg1 arg2) = [||addNumTerm arg1 arg2||] + liftTyped (NegNumTerm _ arg) = [||negNumTerm arg||] + liftTyped (MulNumTerm _ arg1 arg2) = [||mulNumTerm arg1 arg2||] + liftTyped (AbsNumTerm _ arg) = [||absNumTerm arg||] + liftTyped (SignumNumTerm _ arg) = [||signumNumTerm arg||] + liftTyped (LtOrdTerm _ arg1 arg2) = [||ltOrdTerm arg1 arg2||] + liftTyped (LeOrdTerm _ arg1 arg2) = [||leOrdTerm arg1 arg2||] + liftTyped (AndBitsTerm _ arg1 arg2) = [||andBitsTerm arg1 arg2||] + liftTyped (OrBitsTerm _ arg1 arg2) = [||orBitsTerm arg1 arg2||] + liftTyped (XorBitsTerm _ arg1 arg2) = [||xorBitsTerm arg1 arg2||] + liftTyped (ComplementBitsTerm _ arg) = [||complementBitsTerm arg||] + liftTyped (ShiftLeftTerm _ arg n) = [||shiftLeftTerm arg n||] + liftTyped (ShiftRightTerm _ arg n) = [||shiftRightTerm arg n||] + liftTyped (RotateLeftTerm _ arg n) = [||rotateLeftTerm arg n||] + liftTyped (RotateRightTerm _ arg n) = [||rotateRightTerm arg n||] + liftTyped (ToSignedTerm _ v) = [||toSignedTerm v||] + liftTyped (ToUnsignedTerm _ v) = [||toUnsignedTerm v||] + liftTyped (BVConcatTerm _ arg1 arg2) = [||bvconcatTerm arg1 arg2||] + liftTyped (BVSelectTerm _ (_ :: TypeRep ix) (_ :: TypeRep w) arg) = [||bvselectTerm (Proxy @ix) (Proxy @w) arg||] + liftTyped (BVExtendTerm _ signed (_ :: TypeRep n) arg) = [||bvextendTerm signed (Proxy @n) arg||] + liftTyped (ApplyTerm _ f arg) = [||applyTerm f arg||] + liftTyped (DivIntegralTerm _ arg1 arg2) = [||divIntegralTerm arg1 arg2||] + liftTyped (ModIntegralTerm _ arg1 arg2) = [||modIntegralTerm arg1 arg2||] + liftTyped (QuotIntegralTerm _ arg1 arg2) = [||quotIntegralTerm arg1 arg2||] + liftTyped (RemIntegralTerm _ arg1 arg2) = [||remIntegralTerm arg1 arg2||] + +instance Show (Term ty) where + show (ConTerm i v) = "ConTerm{id=" ++ show i ++ ", v=" ++ show v ++ "}" + show (SymTerm i name) = + "SymTerm{id=" + ++ show i + ++ ", name=" + ++ show name + ++ ", type=" + ++ show (typeRep @ty) + ++ "}" + show (UnaryTerm i tag arg) = "Unary{id=" ++ show i ++ ", tag=" ++ show tag ++ ", arg=" ++ show arg ++ "}" + show (BinaryTerm i tag arg1 arg2) = + "Binary{id=" + ++ show i + ++ ", tag=" + ++ show tag + ++ ", arg1=" + ++ show arg1 + ++ ", arg2=" + ++ show arg2 + ++ "}" + show (TernaryTerm i tag arg1 arg2 arg3) = + "Ternary{id=" + ++ show i + ++ ", tag=" + ++ show tag + ++ ", arg1=" + ++ show arg1 + ++ ", arg2=" + ++ show arg2 + ++ ", arg3=" + ++ show arg3 + ++ "}" + show (NotTerm i arg) = "Not{id=" ++ show i ++ ", arg=" ++ show arg ++ "}" + show (OrTerm i arg1 arg2) = "Or{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" + show (AndTerm i arg1 arg2) = "And{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" + show (EqTerm i arg1 arg2) = "Eqv{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" + show (ITETerm i cond l r) = + "ITE{id=" + ++ show i + ++ ", cond=" + ++ show cond + ++ ", then=" + ++ show l + ++ ", else=" + ++ show r + ++ "}" + show (AddNumTerm i arg1 arg2) = "AddNum{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" + show (NegNumTerm i arg) = "NegNum{id=" ++ show i ++ ", arg=" ++ show arg ++ "}" + show (MulNumTerm i arg1 arg2) = "MulNum{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" + show (AbsNumTerm i arg) = "AbsNum{id=" ++ show i ++ ", arg=" ++ show arg ++ "}" + show (SignumNumTerm i arg) = "SignumNum{id=" ++ show i ++ ", arg=" ++ show arg ++ "}" + show (LtOrdTerm i arg1 arg2) = "LTNum{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" + show (LeOrdTerm i arg1 arg2) = "LENum{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" + show (AndBitsTerm i arg1 arg2) = "AndBits{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" + show (OrBitsTerm i arg1 arg2) = "OrBits{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" + show (XorBitsTerm i arg1 arg2) = "XorBits{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" + show (ComplementBitsTerm i arg) = "ComplementBits{id=" ++ show i ++ ", arg=" ++ show arg ++ "}" + show (ShiftLeftTerm i arg n) = "ShiftLeft{id=" ++ show i ++ ", arg=" ++ show arg ++ ", n=" ++ show n ++ "}" + show (ShiftRightTerm i arg n) = "ShiftRight{id=" ++ show i ++ ", arg=" ++ show arg ++ ", n=" ++ show n ++ "}" + show (RotateLeftTerm i arg n) = "RotateLeft{id=" ++ show i ++ ", arg=" ++ show arg ++ ", n=" ++ show n ++ "}" + show (RotateRightTerm i arg n) = "RotateRight{id=" ++ show i ++ ", arg=" ++ show arg ++ ", n=" ++ show n ++ "}" + show (ToSignedTerm i arg) = "ToSigned{id=" ++ show i ++ ", arg=" ++ show arg ++ "}" + show (ToUnsignedTerm i arg) = "ToUnsigned{id=" ++ show i ++ ", arg=" ++ show arg ++ "}" + show (BVConcatTerm i arg1 arg2) = "BVConcat{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" + show (BVSelectTerm i ix w arg) = + "BVSelect{id=" ++ show i ++ ", ix=" ++ show ix ++ ", w=" ++ show w ++ ", arg=" ++ show arg ++ "}" + show (BVExtendTerm i signed n arg) = + "BVExtend{id=" ++ show i ++ ", signed=" ++ show signed ++ ", n=" ++ show n ++ ", arg=" ++ show arg ++ "}" + show (ApplyTerm i f arg) = + "Apply{id=" ++ show i ++ ", f=" ++ show f ++ ", arg=" ++ show arg ++ "}" + show (DivIntegralTerm i arg1 arg2) = + "DivIntegral{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" + show (ModIntegralTerm i arg1 arg2) = + "ModIntegral{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" + show (QuotIntegralTerm i arg1 arg2) = + "QuotIntegral{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" + show (RemIntegralTerm i arg1 arg2) = + "RemIntegral{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" + +prettyPrintTerm :: Term t -> Doc ann +prettyPrintTerm v = + column + ( \c -> + pageWidth $ \case + AvailablePerLine i r -> + if fromIntegral (c + len) > fromIntegral i * r + then "..." + else pretty formatted + Unbounded -> pretty formatted + ) + where + formatted = introSupportedPrimConstraint v $ pformat v + len = length formatted + +instance (SupportedPrim t) => Eq (Term t) where + (==) = (==) `on` identity + +instance (SupportedPrim t) => Hashable (Term t) where + hashWithSalt s t = hashWithSalt s $ identity t + +-- Interning + +data UTerm t where + UConTerm :: (SupportedPrim t) => !t -> UTerm t + USymTerm :: (SupportedPrim t) => !(TypedSymbol t) -> UTerm t + UUnaryTerm :: (UnaryOp tag arg t) => !tag -> !(Term arg) -> UTerm t + UBinaryTerm :: + (BinaryOp tag arg1 arg2 t) => + !tag -> + !(Term arg1) -> + !(Term arg2) -> + UTerm t + UTernaryTerm :: + (TernaryOp tag arg1 arg2 arg3 t) => + !tag -> + !(Term arg1) -> + !(Term arg2) -> + !(Term arg3) -> + UTerm t + UNotTerm :: !(Term Bool) -> UTerm Bool + UOrTerm :: !(Term Bool) -> !(Term Bool) -> UTerm Bool + UAndTerm :: !(Term Bool) -> !(Term Bool) -> UTerm Bool + UEqTerm :: (SupportedPrim t) => !(Term t) -> !(Term t) -> UTerm Bool + UITETerm :: + (SupportedPrim t) => + !(Term Bool) -> + !(Term t) -> + !(Term t) -> + UTerm t + UAddNumTerm :: (PEvalNumTerm t) => !(Term t) -> !(Term t) -> UTerm t + UNegNumTerm :: (PEvalNumTerm t) => !(Term t) -> UTerm t + UMulNumTerm :: (PEvalNumTerm t) => !(Term t) -> !(Term t) -> UTerm t + UAbsNumTerm :: (PEvalNumTerm t) => !(Term t) -> UTerm t + USignumNumTerm :: (PEvalNumTerm t) => !(Term t) -> UTerm t + ULtOrdTerm :: (PEvalOrdTerm t) => !(Term t) -> !(Term t) -> UTerm Bool + ULeOrdTerm :: (PEvalOrdTerm t) => !(Term t) -> !(Term t) -> UTerm Bool + UAndBitsTerm :: (PEvalBitwiseTerm t) => !(Term t) -> !(Term t) -> UTerm t + UOrBitsTerm :: (PEvalBitwiseTerm t) => !(Term t) -> !(Term t) -> UTerm t + UXorBitsTerm :: (PEvalBitwiseTerm t) => !(Term t) -> !(Term t) -> UTerm t + UComplementBitsTerm :: (PEvalBitwiseTerm t) => !(Term t) -> UTerm t + UShiftLeftTerm :: (PEvalShiftTerm t) => !(Term t) -> !(Term t) -> UTerm t + UShiftRightTerm :: (PEvalShiftTerm t) => !(Term t) -> !(Term t) -> UTerm t + URotateLeftTerm :: (PEvalRotateTerm t) => !(Term t) -> !(Term t) -> UTerm t + URotateRightTerm :: (PEvalRotateTerm t) => !(Term t) -> !(Term t) -> UTerm t + UToSignedTerm :: + (PEvalBVSignConversionTerm u s, KnownNat n, 1 <= n) => + !(Term (u n)) -> + UTerm (s n) + UToUnsignedTerm :: + (PEvalBVSignConversionTerm u s, KnownNat n, 1 <= n) => + !(Term (s n)) -> + UTerm (u n) + UBVConcatTerm :: + ( PEvalBVTerm bv, + KnownNat l, + KnownNat r, + KnownNat (l + r), + 1 <= l, + 1 <= r, + 1 <= l + r + ) => + !(Term (bv l)) -> + !(Term (bv r)) -> + UTerm (bv (l + r)) + UBVSelectTerm :: + ( PEvalBVTerm bv, + KnownNat n, + KnownNat ix, + KnownNat w, + 1 <= n, + 1 <= w, + ix + w <= n + ) => + !(TypeRep ix) -> + !(TypeRep w) -> + !(Term (bv n)) -> + UTerm (bv w) + UBVExtendTerm :: + (PEvalBVTerm bv, KnownNat l, KnownNat r, 1 <= l, 1 <= r, l <= r) => + !Bool -> + !(TypeRep r) -> + !(Term (bv l)) -> + UTerm (bv r) + UApplyTerm :: + ( SupportedPrim a, + SupportedPrim b, + SupportedPrim f, + PEvalApplyTerm f a b + ) => + Term f -> + Term a -> + UTerm b + UDivIntegralTerm :: + (PEvalDivModIntegralTerm t) => !(Term t) -> !(Term t) -> UTerm t + UModIntegralTerm :: + (PEvalDivModIntegralTerm t) => !(Term t) -> !(Term t) -> UTerm t + UQuotIntegralTerm :: + (PEvalDivModIntegralTerm t) => !(Term t) -> !(Term t) -> UTerm t + URemIntegralTerm :: + (PEvalDivModIntegralTerm t) => !(Term t) -> !(Term t) -> UTerm t + +eqTypedId :: (TypeRep a, Id) -> (TypeRep b, Id) -> Bool +eqTypedId (a, i1) (b, i2) = i1 == i2 && eqTypeRepBool a b +{-# INLINE eqTypedId #-} + +eqHeteroTag :: (Eq a) => (TypeRep a, a) -> (TypeRep b, b) -> Bool +eqHeteroTag (tpa, taga) (tpb, tagb) = eqHeteroRep tpa tpb taga tagb +{-# INLINE eqHeteroTag #-} + +instance (SupportedPrim t) => Interned (Term t) where + type Uninterned (Term t) = UTerm t + data Description (Term t) where + DConTerm :: t -> Description (Term t) + DSymTerm :: TypedSymbol t -> Description (Term t) + DUnaryTerm :: + (Eq tag, Hashable tag) => + {-# UNPACK #-} !(TypeRep tag, tag) -> + {-# UNPACK #-} !(TypeRep arg, Id) -> + Description (Term t) + DBinaryTerm :: + (Eq tag, Hashable tag) => + {-# UNPACK #-} !(TypeRep tag, tag) -> + {-# UNPACK #-} !(TypeRep arg1, Id) -> + {-# UNPACK #-} !(TypeRep arg2, Id) -> + Description (Term t) + DTernaryTerm :: + (Eq tag, Hashable tag) => + {-# UNPACK #-} !(TypeRep tag, tag) -> + {-# UNPACK #-} !(TypeRep arg1, Id) -> + {-# UNPACK #-} !(TypeRep arg2, Id) -> + {-# UNPACK #-} !(TypeRep arg3, Id) -> + Description (Term t) + DNotTerm :: {-# UNPACK #-} !Id -> Description (Term Bool) + DOrTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term Bool) + DAndTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term Bool) + DEqTerm :: TypeRep args -> {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term Bool) + DITETerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term t) + DAddNumTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term t) + DNegNumTerm :: {-# UNPACK #-} !Id -> Description (Term t) + DMulNumTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term t) + DAbsNumTerm :: {-# UNPACK #-} !Id -> Description (Term t) + DSignumNumTerm :: {-# UNPACK #-} !Id -> Description (Term t) + DLtOrdTerm :: TypeRep args -> {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term Bool) + DLeOrdTerm :: TypeRep args -> {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term Bool) + DAndBitsTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term t) + DOrBitsTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term t) + DXorBitsTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term t) + DComplementBitsTerm :: {-# UNPACK #-} !Id -> Description (Term t) + DShiftLeftTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term t) + DShiftRightTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term t) + DRotateLeftTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term t) + DRotateRightTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term t) + DBVConcatTerm :: TypeRep bv1 -> TypeRep bv2 -> {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term t) + DToSignedTerm :: + !(TypeRep u, Id) -> + Description (Term s) + DToUnsignedTerm :: + !(TypeRep s, Id) -> + Description (Term u) + DBVSelectTerm :: + forall bv (n :: Nat) (w :: Nat) (ix :: Nat). + !(TypeRep ix) -> + !(TypeRep (bv n), Id) -> + Description (Term (bv w)) + DBVExtendTerm :: + forall bv (l :: Nat) (r :: Nat). + !Bool -> + !(TypeRep r) -> + {-# UNPACK #-} !(TypeRep (bv l), Id) -> + Description (Term (bv r)) + DApplyTerm :: + ( PEvalApplyTerm f a b + ) => + {-# UNPACK #-} !(TypeRep f, Id) -> + {-# UNPACK #-} !(TypeRep a, Id) -> + Description (Term b) + DDivIntegralTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term a) + DModIntegralTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term a) + DQuotIntegralTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term a) + DRemIntegralTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term a) + + describe (UConTerm v) = DConTerm v + describe ((USymTerm name) :: UTerm t) = DSymTerm @t name + describe ((UUnaryTerm (tag :: tagt) (tm :: Term arg)) :: UTerm t) = + DUnaryTerm (typeRep, tag) (typeRep :: TypeRep arg, identity tm) + describe ((UBinaryTerm (tag :: tagt) (tm1 :: Term arg1) (tm2 :: Term arg2)) :: UTerm t) = + DBinaryTerm @tagt @arg1 @arg2 @t (typeRep, tag) (typeRep, identity tm1) (typeRep, identity tm2) + describe ((UTernaryTerm (tag :: tagt) (tm1 :: Term arg1) (tm2 :: Term arg2) (tm3 :: Term arg3)) :: UTerm t) = + DTernaryTerm @tagt @arg1 @arg2 @arg3 @t + (typeRep, tag) + (typeRep, identity tm1) + (typeRep, identity tm2) + (typeRep, identity tm3) + describe (UNotTerm arg) = DNotTerm (identity arg) + describe (UOrTerm arg1 arg2) = DOrTerm (identity arg1) (identity arg2) + describe (UAndTerm arg1 arg2) = DAndTerm (identity arg1) (identity arg2) + describe (UEqTerm (arg1 :: Term arg) arg2) = DEqTerm (typeRep :: TypeRep arg) (identity arg1) (identity arg2) + describe (UITETerm cond (l :: Term arg) r) = DITETerm (identity cond) (identity l) (identity r) + describe (UAddNumTerm arg1 arg2) = DAddNumTerm (identity arg1) (identity arg2) + describe (UNegNumTerm arg) = DNegNumTerm (identity arg) + describe (UMulNumTerm arg1 arg2) = DMulNumTerm (identity arg1) (identity arg2) + describe (UAbsNumTerm arg) = DAbsNumTerm (identity arg) + describe (USignumNumTerm arg) = DSignumNumTerm (identity arg) + describe (ULtOrdTerm (arg1 :: arg) arg2) = DLtOrdTerm (typeRep :: TypeRep arg) (identity arg1) (identity arg2) + describe (ULeOrdTerm (arg1 :: arg) arg2) = DLeOrdTerm (typeRep :: TypeRep arg) (identity arg1) (identity arg2) + describe (UAndBitsTerm arg1 arg2) = DAndBitsTerm (identity arg1) (identity arg2) + describe (UOrBitsTerm arg1 arg2) = DOrBitsTerm (identity arg1) (identity arg2) + describe (UXorBitsTerm arg1 arg2) = DXorBitsTerm (identity arg1) (identity arg2) + describe (UComplementBitsTerm arg) = DComplementBitsTerm (identity arg) + describe (UShiftLeftTerm arg n) = DShiftLeftTerm (identity arg) (identity n) + describe (UShiftRightTerm arg n) = DShiftRightTerm (identity arg) (identity n) + describe (URotateLeftTerm arg n) = DRotateLeftTerm (identity arg) (identity n) + describe (URotateRightTerm arg n) = DRotateRightTerm (identity arg) (identity n) + describe (UToSignedTerm (arg :: Term bv)) = DToSignedTerm (typeRep :: TypeRep bv, identity arg) + describe (UToUnsignedTerm (arg :: Term bv)) = DToSignedTerm (typeRep :: TypeRep bv, identity arg) + describe (UBVConcatTerm (arg1 :: bv1) (arg2 :: bv2)) = + DBVConcatTerm (typeRep :: TypeRep bv1) (typeRep :: TypeRep bv2) (identity arg1) (identity arg2) + describe (UBVSelectTerm (ix :: TypeRep ix) _ (arg :: Term arg)) = + DBVSelectTerm ix (typeRep :: TypeRep arg, identity arg) + describe (UBVExtendTerm signed (n :: TypeRep n) (arg :: Term arg)) = + DBVExtendTerm signed n (typeRep :: TypeRep arg, identity arg) + describe (UApplyTerm (f :: Term f) (arg :: Term a)) = + DApplyTerm (typeRep :: TypeRep f, identity f) (typeRep :: TypeRep a, identity arg) + describe (UDivIntegralTerm arg1 arg2) = DDivIntegralTerm (identity arg1) (identity arg2) + describe (UModIntegralTerm arg1 arg2) = DModIntegralTerm (identity arg1) (identity arg2) + describe (UQuotIntegralTerm arg1 arg2) = DRemIntegralTerm (identity arg1) (identity arg2) + describe (URemIntegralTerm arg1 arg2) = DQuotIntegralTerm (identity arg1) (identity arg2) + + identify i = go + where + go (UConTerm v) = ConTerm i v + go (USymTerm v) = SymTerm i v + go (UUnaryTerm tag tm) = UnaryTerm i tag tm + go (UBinaryTerm tag tm1 tm2) = BinaryTerm i tag tm1 tm2 + go (UTernaryTerm tag tm1 tm2 tm3) = TernaryTerm i tag tm1 tm2 tm3 + go (UNotTerm arg) = NotTerm i arg + go (UOrTerm arg1 arg2) = OrTerm i arg1 arg2 + go (UAndTerm arg1 arg2) = AndTerm i arg1 arg2 + go (UEqTerm arg1 arg2) = EqTerm i arg1 arg2 + go (UITETerm cond l r) = ITETerm i cond l r + go (UAddNumTerm arg1 arg2) = AddNumTerm i arg1 arg2 + go (UNegNumTerm arg) = NegNumTerm i arg + go (UMulNumTerm arg1 arg2) = MulNumTerm i arg1 arg2 + go (UAbsNumTerm arg) = AbsNumTerm i arg + go (USignumNumTerm arg) = SignumNumTerm i arg + go (ULtOrdTerm arg1 arg2) = LtOrdTerm i arg1 arg2 + go (ULeOrdTerm arg1 arg2) = LeOrdTerm i arg1 arg2 + go (UAndBitsTerm arg1 arg2) = AndBitsTerm i arg1 arg2 + go (UOrBitsTerm arg1 arg2) = OrBitsTerm i arg1 arg2 + go (UXorBitsTerm arg1 arg2) = XorBitsTerm i arg1 arg2 + go (UComplementBitsTerm arg) = ComplementBitsTerm i arg + go (UShiftLeftTerm arg n) = ShiftLeftTerm i arg n + go (UShiftRightTerm arg n) = ShiftRightTerm i arg n + go (URotateLeftTerm arg n) = RotateLeftTerm i arg n + go (URotateRightTerm arg n) = RotateRightTerm i arg n + go (UToSignedTerm arg) = ToSignedTerm i arg + go (UToUnsignedTerm arg) = ToUnsignedTerm i arg + go (UBVConcatTerm arg1 arg2) = BVConcatTerm i arg1 arg2 + go (UBVSelectTerm ix w arg) = BVSelectTerm i ix w arg + go (UBVExtendTerm signed n arg) = BVExtendTerm i signed n arg + go (UApplyTerm f arg) = ApplyTerm i f arg + go (UDivIntegralTerm arg1 arg2) = DivIntegralTerm i arg1 arg2 + go (UModIntegralTerm arg1 arg2) = ModIntegralTerm i arg1 arg2 + go (UQuotIntegralTerm arg1 arg2) = QuotIntegralTerm i arg1 arg2 + go (URemIntegralTerm arg1 arg2) = RemIntegralTerm i arg1 arg2 + cache = termCache + +instance (SupportedPrim t) => Eq (Description (Term t)) where + DConTerm (l :: tyl) == DConTerm (r :: tyr) = cast @tyl @tyr l == Just r + DSymTerm ls == DSymTerm rs = ls == rs + DUnaryTerm (tagl :: tagl) li == DUnaryTerm (tagr :: tagr) ri = eqHeteroTag tagl tagr && eqTypedId li ri + DBinaryTerm (tagl :: tagl) li1 li2 == DBinaryTerm (tagr :: tagr) ri1 ri2 = + eqHeteroTag tagl tagr && eqTypedId li1 ri1 && eqTypedId li2 ri2 + DTernaryTerm (tagl :: tagl) li1 li2 li3 == DTernaryTerm (tagr :: tagr) ri1 ri2 ri3 = + eqHeteroTag tagl tagr && eqTypedId li1 ri1 && eqTypedId li2 ri2 && eqTypedId li3 ri3 + DNotTerm li == DNotTerm ri = li == ri + DOrTerm li1 li2 == DOrTerm ri1 ri2 = li1 == ri1 && li2 == ri2 + DAndTerm li1 li2 == DAndTerm ri1 ri2 = li1 == ri1 && li2 == ri2 + DEqTerm lrep li1 li2 == DEqTerm rrep ri1 ri2 = eqTypeRepBool lrep rrep && li1 == ri1 && li2 == ri2 + DITETerm lc li1 li2 == DITETerm rc ri1 ri2 = lc == rc && li1 == ri1 && li2 == ri2 + DAddNumTerm li1 li2 == DAddNumTerm ri1 ri2 = li1 == ri1 && li2 == ri2 + DNegNumTerm li == DNegNumTerm ri = li == ri + DMulNumTerm li1 li2 == DMulNumTerm ri1 ri2 = li1 == ri1 && li2 == ri2 + DAbsNumTerm li == DAbsNumTerm ri = li == ri + DSignumNumTerm li == DSignumNumTerm ri = li == ri + DLtOrdTerm lrep li1 li2 == DLtOrdTerm rrep ri1 ri2 = eqTypeRepBool lrep rrep && li1 == ri1 && li2 == ri2 + DLeOrdTerm lrep li1 li2 == DLeOrdTerm rrep ri1 ri2 = eqTypeRepBool lrep rrep && li1 == ri1 && li2 == ri2 + DAndBitsTerm li1 li2 == DAndBitsTerm ri1 ri2 = li1 == ri1 && li2 == ri2 + DOrBitsTerm li1 li2 == DOrBitsTerm ri1 ri2 = li1 == ri1 && li2 == ri2 + DXorBitsTerm li1 li2 == DXorBitsTerm ri1 ri2 = li1 == ri1 && li2 == ri2 + DComplementBitsTerm li == DComplementBitsTerm ri = li == ri + DShiftLeftTerm li ln == DShiftLeftTerm ri rn = li == ri && ln == rn + DShiftRightTerm li ln == DShiftRightTerm ri rn = li == ri && ln == rn + DRotateLeftTerm li ln == DRotateLeftTerm ri rn = li == ri && ln == rn + DRotateRightTerm li ln == DRotateRightTerm ri rn = li == ri && ln == rn + DToSignedTerm li == DToSignedTerm ri = eqTypedId li ri + DToUnsignedTerm li == DToUnsignedTerm ri = eqTypedId li ri + DBVConcatTerm lrep1 lrep2 li1 li2 == DBVConcatTerm rrep1 rrep2 ri1 ri2 = + eqTypeRepBool lrep1 rrep1 && eqTypeRepBool lrep2 rrep2 && li1 == ri1 && li2 == ri2 + DBVSelectTerm lix li == DBVSelectTerm rix ri = + eqTypeRepBool lix rix && eqTypedId li ri + DBVExtendTerm lIsSigned ln li == DBVExtendTerm rIsSigned rn ri = + lIsSigned == rIsSigned + && eqTypeRepBool ln rn + && eqTypedId li ri + DApplyTerm lf li == DApplyTerm rf ri = eqTypedId lf rf && eqTypedId li ri + DDivIntegralTerm li1 li2 == DDivIntegralTerm ri1 ri2 = li1 == ri1 && li2 == ri2 + DModIntegralTerm li1 li2 == DModIntegralTerm ri1 ri2 = li1 == ri1 && li2 == ri2 + DQuotIntegralTerm li1 li2 == DQuotIntegralTerm ri1 ri2 = li1 == ri1 && li2 == ri2 + DRemIntegralTerm li1 li2 == DRemIntegralTerm ri1 ri2 = li1 == ri1 && li2 == ri2 + _ == _ = False + +instance (SupportedPrim t) => Hashable (Description (Term t)) where + hashWithSalt s (DConTerm c) = s `hashWithSalt` (0 :: Int) `hashWithSalt` c + hashWithSalt s (DSymTerm name) = s `hashWithSalt` (1 :: Int) `hashWithSalt` name + hashWithSalt s (DUnaryTerm tag id1) = s `hashWithSalt` (2 :: Int) `hashWithSalt` tag `hashWithSalt` id1 + hashWithSalt s (DBinaryTerm tag id1 id2) = + s `hashWithSalt` (3 :: Int) `hashWithSalt` tag `hashWithSalt` id1 `hashWithSalt` id2 + hashWithSalt s (DTernaryTerm tag id1 id2 id3) = + s `hashWithSalt` (4 :: Int) `hashWithSalt` tag `hashWithSalt` id1 `hashWithSalt` id2 `hashWithSalt` id3 + hashWithSalt s (DNotTerm id1) = s `hashWithSalt` (5 :: Int) `hashWithSalt` id1 + hashWithSalt s (DOrTerm id1 id2) = s `hashWithSalt` (6 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 + hashWithSalt s (DAndTerm id1 id2) = s `hashWithSalt` (7 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 + hashWithSalt s (DEqTerm rep id1 id2) = + s + `hashWithSalt` (8 :: Int) + `hashWithSalt` rep + `hashWithSalt` id1 + `hashWithSalt` id2 + hashWithSalt s (DITETerm idc id1 id2) = + s + `hashWithSalt` (9 :: Int) + `hashWithSalt` idc + `hashWithSalt` id1 + `hashWithSalt` id2 + hashWithSalt s (DAddNumTerm id1 id2) = s `hashWithSalt` (10 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 + hashWithSalt s (DNegNumTerm id1) = s `hashWithSalt` (11 :: Int) `hashWithSalt` id1 + hashWithSalt s (DMulNumTerm id1 id2) = s `hashWithSalt` (12 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 + hashWithSalt s (DAbsNumTerm id1) = s `hashWithSalt` (13 :: Int) `hashWithSalt` id1 + hashWithSalt s (DSignumNumTerm id1) = s `hashWithSalt` (14 :: Int) `hashWithSalt` id1 + hashWithSalt s (DLtOrdTerm rep id1 id2) = + s `hashWithSalt` (15 :: Int) `hashWithSalt` rep `hashWithSalt` id1 `hashWithSalt` id2 + hashWithSalt s (DLeOrdTerm rep id1 id2) = + s `hashWithSalt` (16 :: Int) `hashWithSalt` rep `hashWithSalt` id1 `hashWithSalt` id2 + hashWithSalt s (DAndBitsTerm id1 id2) = s `hashWithSalt` (17 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 + hashWithSalt s (DOrBitsTerm id1 id2) = s `hashWithSalt` (18 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 + hashWithSalt s (DXorBitsTerm id1 id2) = s `hashWithSalt` (19 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 + hashWithSalt s (DComplementBitsTerm id1) = s `hashWithSalt` (20 :: Int) `hashWithSalt` id1 + hashWithSalt s (DShiftLeftTerm id1 idn) = s `hashWithSalt` (38 :: Int) `hashWithSalt` id1 `hashWithSalt` idn + hashWithSalt s (DShiftRightTerm id1 idn) = s `hashWithSalt` (39 :: Int) `hashWithSalt` id1 `hashWithSalt` idn + hashWithSalt s (DRotateLeftTerm id1 idn) = s `hashWithSalt` (40 :: Int) `hashWithSalt` id1 `hashWithSalt` idn + hashWithSalt s (DRotateRightTerm id1 idn) = s `hashWithSalt` (41 :: Int) `hashWithSalt` id1 `hashWithSalt` idn + hashWithSalt s (DToSignedTerm id) = s `hashWithSalt` (23 :: Int) `hashWithSalt` id + hashWithSalt s (DToUnsignedTerm id) = s `hashWithSalt` (24 :: Int) `hashWithSalt` id + hashWithSalt s (DBVConcatTerm rep1 rep2 id1 id2) = + s `hashWithSalt` (25 :: Int) `hashWithSalt` rep1 `hashWithSalt` rep2 `hashWithSalt` id1 `hashWithSalt` id2 + hashWithSalt s (DBVSelectTerm ix id1) = s `hashWithSalt` (26 :: Int) `hashWithSalt` ix `hashWithSalt` id1 + hashWithSalt s (DBVExtendTerm signed n id1) = + s + `hashWithSalt` (27 :: Int) + `hashWithSalt` signed + `hashWithSalt` n + `hashWithSalt` id1 + hashWithSalt s (DDivIntegralTerm id1 id2) = s `hashWithSalt` (30 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 + hashWithSalt s (DModIntegralTerm id1 id2) = s `hashWithSalt` (31 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 + hashWithSalt s (DQuotIntegralTerm id1 id2) = s `hashWithSalt` (32 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 + hashWithSalt s (DRemIntegralTerm id1 id2) = s `hashWithSalt` (33 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 + hashWithSalt s (DApplyTerm id1 id2) = s `hashWithSalt` (38 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 + +internTerm :: forall t. (SupportedPrim t) => Uninterned (Term t) -> Term t +internTerm !bt = unsafeDupablePerformIO $ atomicModifyIORef' slot go + where + slot = getCache cache ! r + !dt = describe bt + !hdt = hash dt + !wid = cacheWidth dt + r = hdt `mod` wid + go (CacheState i m) = case M.lookup dt m of + Nothing -> let t = identify (wid * i + r) bt in (CacheState (i + 1) (M.insert dt t m), t) + Just t -> (CacheState i m, t) + +constructUnary :: + forall tag arg t. + (SupportedPrim t, UnaryOp tag arg t, Typeable tag, Typeable t, Show tag) => + tag -> + Term arg -> + Term t +constructUnary tag tm = let x = internTerm $ UUnaryTerm tag tm in x +{-# INLINE constructUnary #-} + +constructBinary :: + forall tag arg1 arg2 t. + (SupportedPrim t, BinaryOp tag arg1 arg2 t, Typeable tag, Typeable t, Show tag) => + tag -> + Term arg1 -> + Term arg2 -> + Term t +constructBinary tag tm1 tm2 = internTerm $ UBinaryTerm tag tm1 tm2 +{-# INLINE constructBinary #-} + +constructTernary :: + forall tag arg1 arg2 arg3 t. + (SupportedPrim t, TernaryOp tag arg1 arg2 arg3 t, Typeable tag, Typeable t, Show tag) => + tag -> + Term arg1 -> + Term arg2 -> + Term arg3 -> + Term t +constructTernary tag tm1 tm2 tm3 = internTerm $ UTernaryTerm tag tm1 tm2 tm3 +{-# INLINE constructTernary #-} + +conTerm :: (SupportedPrim t, Typeable t, Hashable t, Eq t, Show t) => t -> Term t +conTerm t = internTerm $ UConTerm t +{-# INLINE conTerm #-} + +symTerm :: forall t. (SupportedPrim t, Typeable t) => Symbol -> Term t +symTerm t = internTerm $ USymTerm $ TypedSymbol t +{-# INLINE symTerm #-} + +ssymTerm :: (SupportedPrim t, Typeable t) => Identifier -> Term t +ssymTerm = symTerm . SimpleSymbol +{-# INLINE ssymTerm #-} + +isymTerm :: (SupportedPrim t, Typeable t) => Identifier -> Int -> Term t +isymTerm str idx = symTerm $ IndexedSymbol str idx +{-# INLINE isymTerm #-} + +notTerm :: Term Bool -> Term Bool +notTerm = internTerm . UNotTerm +{-# INLINE notTerm #-} + +orTerm :: Term Bool -> Term Bool -> Term Bool +orTerm l r = internTerm $ UOrTerm l r +{-# INLINE orTerm #-} + +andTerm :: Term Bool -> Term Bool -> Term Bool +andTerm l r = internTerm $ UAndTerm l r +{-# INLINE andTerm #-} + +eqTerm :: (SupportedPrim a) => Term a -> Term a -> Term Bool +eqTerm l r = internTerm $ UEqTerm l r +{-# INLINE eqTerm #-} + +iteTerm :: (SupportedPrim a) => Term Bool -> Term a -> Term a -> Term a +iteTerm c l r = internTerm $ UITETerm c l r +{-# INLINE iteTerm #-} + +addNumTerm :: (PEvalNumTerm a) => Term a -> Term a -> Term a +addNumTerm l r = internTerm $ UAddNumTerm l r +{-# INLINE addNumTerm #-} + +negNumTerm :: (PEvalNumTerm a) => Term a -> Term a +negNumTerm = internTerm . UNegNumTerm +{-# INLINE negNumTerm #-} + +mulNumTerm :: (PEvalNumTerm a) => Term a -> Term a -> Term a +mulNumTerm l r = internTerm $ UMulNumTerm l r +{-# INLINE mulNumTerm #-} + +absNumTerm :: (PEvalNumTerm a) => Term a -> Term a +absNumTerm = internTerm . UAbsNumTerm +{-# INLINE absNumTerm #-} + +signumNumTerm :: (PEvalNumTerm a) => Term a -> Term a +signumNumTerm = internTerm . USignumNumTerm +{-# INLINE signumNumTerm #-} + +ltOrdTerm :: (PEvalOrdTerm a) => Term a -> Term a -> Term Bool +ltOrdTerm l r = internTerm $ ULtOrdTerm l r +{-# INLINE ltOrdTerm #-} + +leOrdTerm :: (PEvalOrdTerm a) => Term a -> Term a -> Term Bool +leOrdTerm l r = internTerm $ ULeOrdTerm l r +{-# INLINE leOrdTerm #-} + +andBitsTerm :: (PEvalBitwiseTerm a) => Term a -> Term a -> Term a +andBitsTerm l r = internTerm $ UAndBitsTerm l r +{-# INLINE andBitsTerm #-} + +orBitsTerm :: (PEvalBitwiseTerm a) => Term a -> Term a -> Term a +orBitsTerm l r = internTerm $ UOrBitsTerm l r +{-# INLINE orBitsTerm #-} + +xorBitsTerm :: (PEvalBitwiseTerm a) => Term a -> Term a -> Term a +xorBitsTerm l r = internTerm $ UXorBitsTerm l r +{-# INLINE xorBitsTerm #-} + +complementBitsTerm :: (PEvalBitwiseTerm a) => Term a -> Term a +complementBitsTerm = internTerm . UComplementBitsTerm +{-# INLINE complementBitsTerm #-} + +shiftLeftTerm :: (PEvalShiftTerm a) => Term a -> Term a -> Term a +shiftLeftTerm t n = internTerm $ UShiftLeftTerm t n +{-# INLINE shiftLeftTerm #-} + +shiftRightTerm :: (PEvalShiftTerm a) => Term a -> Term a -> Term a +shiftRightTerm t n = internTerm $ UShiftRightTerm t n +{-# INLINE shiftRightTerm #-} + +rotateLeftTerm :: (PEvalRotateTerm a) => Term a -> Term a -> Term a +rotateLeftTerm t n = internTerm $ URotateLeftTerm t n +{-# INLINE rotateLeftTerm #-} + +rotateRightTerm :: (PEvalRotateTerm a) => Term a -> Term a -> Term a +rotateRightTerm t n = internTerm $ URotateRightTerm t n +{-# INLINE rotateRightTerm #-} + +toSignedTerm :: + (PEvalBVSignConversionTerm u s, KnownNat n, 1 <= n) => + Term (u n) -> + Term (s n) +toSignedTerm = internTerm . UToSignedTerm + +toUnsignedTerm :: + (PEvalBVSignConversionTerm u s, KnownNat n, 1 <= n) => + Term (s n) -> + Term (u n) +toUnsignedTerm = internTerm . UToUnsignedTerm + +bvconcatTerm :: + ( PEvalBVTerm bv, + KnownNat l, + KnownNat r, + KnownNat (l + r), + 1 <= l, + 1 <= r, + 1 <= l + r + ) => + Term (bv l) -> + Term (bv r) -> + Term (bv (l + r)) +bvconcatTerm l r = internTerm $ UBVConcatTerm l r +{-# INLINE bvconcatTerm #-} + +bvselectTerm :: + forall bv n ix w p q. + ( PEvalBVTerm bv, + KnownNat n, + KnownNat ix, + KnownNat w, + 1 <= n, + 1 <= w, + ix + w <= n + ) => + p ix -> + q w -> + Term (bv n) -> + Term (bv w) +bvselectTerm _ _ v = internTerm $ UBVSelectTerm (typeRep @ix) (typeRep @w) v +{-# INLINE bvselectTerm #-} + +bvextendTerm :: + forall bv l r proxy. + (PEvalBVTerm bv, KnownNat l, KnownNat r, 1 <= l, 1 <= r, l <= r) => + Bool -> + proxy r -> + Term (bv l) -> + Term (bv r) +bvextendTerm signed _ v = internTerm $ UBVExtendTerm signed (typeRep @r) v +{-# INLINE bvextendTerm #-} + +bvsignExtendTerm :: + forall bv l r proxy. + (PEvalBVTerm bv, KnownNat l, KnownNat r, 1 <= l, 1 <= r, l <= r) => + proxy r -> + Term (bv l) -> + Term (bv r) +bvsignExtendTerm _ v = internTerm $ UBVExtendTerm True (typeRep @r) v +{-# INLINE bvsignExtendTerm #-} + +bvzeroExtendTerm :: + forall bv l r proxy. + (PEvalBVTerm bv, KnownNat l, KnownNat r, 1 <= l, 1 <= r, l <= r) => + proxy r -> + Term (bv l) -> + Term (bv r) +bvzeroExtendTerm _ v = internTerm $ UBVExtendTerm False (typeRep @r) v +{-# INLINE bvzeroExtendTerm #-} + +applyTerm :: + (SupportedPrim a, SupportedPrim b, SupportedPrim f, PEvalApplyTerm f a b) => + Term f -> + Term a -> + Term b +applyTerm f a = internTerm $ UApplyTerm f a +{-# INLINE applyTerm #-} + +divIntegralTerm :: (PEvalDivModIntegralTerm a) => Term a -> Term a -> Term a +divIntegralTerm l r = internTerm $ UDivIntegralTerm l r +{-# INLINE divIntegralTerm #-} + +modIntegralTerm :: (PEvalDivModIntegralTerm a) => Term a -> Term a -> Term a +modIntegralTerm l r = internTerm $ UModIntegralTerm l r +{-# INLINE modIntegralTerm #-} + +quotIntegralTerm :: (PEvalDivModIntegralTerm a) => Term a -> Term a -> Term a +quotIntegralTerm l r = internTerm $ UQuotIntegralTerm l r +{-# INLINE quotIntegralTerm #-} + +remIntegralTerm :: (PEvalDivModIntegralTerm a) => Term a -> Term a -> Term a +remIntegralTerm l r = internTerm $ URemIntegralTerm l r +{-# INLINE remIntegralTerm #-} + +-- Support for boolean type +defaultValueForBool :: Bool +defaultValueForBool = False + +defaultValueForBoolDyn :: ModelValue +defaultValueForBoolDyn = toModelValue defaultValueForBool + +trueTerm :: Term Bool +trueTerm = conTerm True +{-# INLINE trueTerm #-} + +falseTerm :: Term Bool +falseTerm = conTerm False +{-# INLINE falseTerm #-} + +boolConTermView :: forall a. Term a -> Maybe Bool +boolConTermView (ConTerm _ b) = cast b +boolConTermView _ = Nothing +{-# INLINE boolConTermView #-} + +pattern BoolConTerm :: Bool -> Term a +pattern BoolConTerm b <- (boolConTermView -> Just b) + +pattern TrueTerm :: Term a +pattern TrueTerm <- BoolConTerm True + +pattern FalseTerm :: Term a +pattern FalseTerm <- BoolConTerm False + +boolTermView :: forall a. Term a -> Maybe (Term Bool) +boolTermView t = introSupportedPrimConstraint t $ cast t +{-# INLINE boolTermView #-} + +pattern BoolTerm :: Term Bool -> Term a +pattern BoolTerm b <- (boolTermView -> Just b) + +-- Not +pevalNotTerm :: Term Bool -> Term Bool +pevalNotTerm (NotTerm _ tm) = tm +pevalNotTerm (ConTerm _ a) = if a then falseTerm else trueTerm +pevalNotTerm (OrTerm _ (NotTerm _ n1) n2) = pevalAndTerm n1 (pevalNotTerm n2) +pevalNotTerm (OrTerm _ n1 (NotTerm _ n2)) = pevalAndTerm (pevalNotTerm n1) n2 +pevalNotTerm (AndTerm _ (NotTerm _ n1) n2) = pevalOrTerm n1 (pevalNotTerm n2) +pevalNotTerm (AndTerm _ n1 (NotTerm _ n2)) = pevalOrTerm (pevalNotTerm n1) n2 +pevalNotTerm tm = notTerm tm +{-# INLINEABLE pevalNotTerm #-} + +orEqFirst :: Term Bool -> Term Bool -> Bool +orEqFirst _ (ConTerm _ False) = True +orEqFirst + (NotTerm _ (EqTerm _ (e1 :: Term a) (ec1@(ConTerm _ _) :: Term b))) + (EqTerm _ (Dyn (e2 :: Term a)) (Dyn (ec2@(ConTerm _ _) :: Term b))) + | e1 == e2 && ec1 /= ec2 = True +orEqFirst x y + | x == y = True + | otherwise = False +{-# INLINE orEqFirst #-} + +orEqTrue :: Term Bool -> Term Bool -> Bool +orEqTrue (ConTerm _ True) _ = True +orEqTrue _ (ConTerm _ True) = True +-- orEqTrue (NotTerm _ e1) (NotTerm _ e2) = andEqFalse e1 e2 +orEqTrue + (NotTerm _ (EqTerm _ (e1 :: Term a) (ec1@(ConTerm _ _) :: Term b))) + (NotTerm _ (EqTerm _ (Dyn (e2 :: Term a)) (Dyn (ec2@(ConTerm _ _) :: Term b)))) + | e1 == e2 && ec1 /= ec2 = True +orEqTrue (NotTerm _ l) r | l == r = True +orEqTrue l (NotTerm _ r) | l == r = True +orEqTrue _ _ = False +{-# INLINE orEqTrue #-} + +andEqFirst :: Term Bool -> Term Bool -> Bool +andEqFirst _ (ConTerm _ True) = True +-- andEqFirst x (NotTerm _ y) = andEqFalse x y +andEqFirst + (EqTerm _ (e1 :: Term a) (ec1@(ConTerm _ _) :: Term b)) + (NotTerm _ (EqTerm _ (Dyn (e2 :: Term a)) (Dyn (ec2@(ConTerm _ _) :: Term b)))) + | e1 == e2 && ec1 /= ec2 = True +andEqFirst x y + | x == y = True + | otherwise = False +{-# INLINE andEqFirst #-} + +andEqFalse :: Term Bool -> Term Bool -> Bool +andEqFalse (ConTerm _ False) _ = True +andEqFalse _ (ConTerm _ False) = True +-- andEqFalse (NotTerm _ e1) (NotTerm _ e2) = orEqTrue e1 e2 +andEqFalse + (EqTerm _ (e1 :: Term a) (ec1@(ConTerm _ _) :: Term b)) + (EqTerm _ (Dyn (e2 :: Term a)) (Dyn (ec2@(ConTerm _ _) :: Term b))) + | e1 == e2 && ec1 /= ec2 = True +andEqFalse (NotTerm _ x) y | x == y = True +andEqFalse x (NotTerm _ y) | x == y = True +andEqFalse _ _ = False +{-# INLINE andEqFalse #-} + +-- Or +pevalOrTerm :: Term Bool -> Term Bool -> Term Bool +pevalOrTerm l r + | orEqTrue l r = trueTerm + | orEqFirst l r = l + | orEqFirst r l = r +pevalOrTerm l r@(OrTerm _ r1 r2) + | orEqTrue l r1 = trueTerm + | orEqTrue l r2 = trueTerm + | orEqFirst r1 l = r + | orEqFirst r2 l = r + | orEqFirst l r1 = pevalOrTerm l r2 + | orEqFirst l r2 = pevalOrTerm l r1 +pevalOrTerm l@(OrTerm _ l1 l2) r + | orEqTrue l1 r = trueTerm + | orEqTrue l2 r = trueTerm + | orEqFirst l1 r = l + | orEqFirst l2 r = l + | orEqFirst r l1 = pevalOrTerm l2 r + | orEqFirst r l2 = pevalOrTerm l1 r +pevalOrTerm l (AndTerm _ r1 r2) + | orEqFirst l r1 = l + | orEqFirst l r2 = l + | orEqTrue l r1 = pevalOrTerm l r2 + | orEqTrue l r2 = pevalOrTerm l r1 +pevalOrTerm (AndTerm _ l1 l2) r + | orEqFirst r l1 = r + | orEqFirst r l2 = r + | orEqTrue l1 r = pevalOrTerm l2 r + | orEqTrue l2 r = pevalOrTerm l1 r +pevalOrTerm (NotTerm _ nl) (NotTerm _ nr) = pevalNotTerm $ pevalAndTerm nl nr +pevalOrTerm l r = orTerm l r +{-# INLINEABLE pevalOrTerm #-} + +pevalAndTerm :: Term Bool -> Term Bool -> Term Bool +pevalAndTerm l r + | andEqFalse l r = falseTerm + | andEqFirst l r = l + | andEqFirst r l = r +pevalAndTerm l r@(AndTerm _ r1 r2) + | andEqFalse l r1 = falseTerm + | andEqFalse l r2 = falseTerm + | andEqFirst r1 l = r + | andEqFirst r2 l = r + | andEqFirst l r1 = pevalAndTerm l r2 + | andEqFirst l r2 = pevalAndTerm l r1 +pevalAndTerm l@(AndTerm _ l1 l2) r + | andEqFalse l1 r = falseTerm + | andEqFalse l2 r = falseTerm + | andEqFirst l1 r = l + | andEqFirst l2 r = l + | andEqFirst r l1 = pevalAndTerm l2 r + | andEqFirst r l2 = pevalAndTerm l1 r +pevalAndTerm l (OrTerm _ r1 r2) + | andEqFirst l r1 = l + | andEqFirst l r2 = l + | andEqFalse l r1 = pevalAndTerm l r2 + | andEqFalse l r2 = pevalAndTerm l r1 +pevalAndTerm (OrTerm _ l1 l2) r + | andEqFirst r l1 = r + | andEqFirst r l2 = r + | andEqFalse l1 r = pevalAndTerm l2 r + | andEqFalse l2 r = pevalAndTerm l1 r +pevalAndTerm (NotTerm _ nl) (NotTerm _ nr) = pevalNotTerm $ pevalOrTerm nl nr +pevalAndTerm l r = andTerm l r +{-# INLINEABLE pevalAndTerm #-} + +pevalImplyTerm :: Term Bool -> Term Bool -> Term Bool +pevalImplyTerm l = pevalOrTerm (pevalNotTerm l) + +pevalXorTerm :: Term Bool -> Term Bool -> Term Bool +pevalXorTerm l r = pevalOrTerm (pevalAndTerm (pevalNotTerm l) r) (pevalAndTerm l (pevalNotTerm r)) + +pevalImpliesTerm :: Term Bool -> Term Bool -> Bool +pevalImpliesTerm (ConTerm _ False) _ = True +pevalImpliesTerm _ (ConTerm _ True) = True +pevalImpliesTerm + (EqTerm _ (e1 :: Term a) (ec1@(ConTerm _ _) :: Term b)) + (NotTerm _ (EqTerm _ (Dyn (e2 :: Term a)) (Dyn (ec2@(ConTerm _ _) :: Term b)))) + | e1 == e2 && ec1 /= ec2 = True +pevalImpliesTerm a b + | a == b = True + | otherwise = False +{-# INLINE pevalImpliesTerm #-} + +pevalITEBoolLeftNot :: Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) +pevalITEBoolLeftNot cond nIfTrue ifFalse + -- need test + | cond == nIfTrue = Just $ pevalAndTerm (pevalNotTerm cond) ifFalse + | otherwise = case nIfTrue of + AndTerm _ nt1 nt2 -> ra + where + ra + | pevalImpliesTerm cond nt1 = + Just $ pevalITETerm cond (pevalNotTerm nt2) ifFalse + | pevalImpliesTerm cond nt2 = + Just $ pevalITETerm cond (pevalNotTerm nt1) ifFalse + | pevalImpliesTerm cond (pevalNotTerm nt1) + || pevalImpliesTerm cond (pevalNotTerm nt2) = + Just $ pevalOrTerm cond ifFalse + | otherwise = Nothing + OrTerm _ nt1 nt2 -> ra + where + ra + | pevalImpliesTerm cond nt1 || pevalImpliesTerm cond nt2 = + Just $ pevalAndTerm (pevalNotTerm cond) ifFalse + | pevalImpliesTerm cond (pevalNotTerm nt1) = + Just $ pevalITETerm cond (pevalNotTerm nt2) ifFalse + | pevalImpliesTerm cond (pevalNotTerm nt2) = + Just $ pevalITETerm cond (pevalNotTerm nt1) ifFalse + | otherwise = Nothing + _ -> Nothing + +pevalITEBoolBothNot :: Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) +pevalITEBoolBothNot cond nIfTrue nIfFalse = + Just $ pevalNotTerm $ pevalITETerm cond nIfTrue nIfFalse + +pevalITEBoolRightNot :: Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) +pevalITEBoolRightNot cond ifTrue nIfFalse + -- need test + | cond == nIfFalse = Just $ pevalOrTerm (pevalNotTerm cond) ifTrue + | otherwise = Nothing -- need work + +pevalInferImplies :: Term Bool -> Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) +pevalInferImplies cond (NotTerm _ nt1) trueRes falseRes + | cond == nt1 = Just falseRes + | otherwise = case (cond, nt1) of + ( EqTerm _ (e1 :: Term a) (ec1@(ConTerm _ _) :: Term b), + EqTerm _ (Dyn (e2 :: Term a)) (Dyn (ec2@(ConTerm _ _) :: Term b)) + ) + | e1 == e2 && ec1 /= ec2 -> Just trueRes + _ -> Nothing +pevalInferImplies + (EqTerm _ (e1 :: Term a) (ec1@(ConTerm _ _) :: Term b)) + (EqTerm _ (Dyn (e2 :: Term a)) (Dyn (ec2@(ConTerm _ _) :: Term b))) + _ + falseRes + | e1 == e2 && ec1 /= ec2 = Just falseRes +pevalInferImplies _ _ _ _ = Nothing + +pevalITEBoolLeftAnd :: Term Bool -> Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) +pevalITEBoolLeftAnd cond t1 t2 ifFalse + | t1 == ifFalse = Just $ pevalAndTerm t1 $ pevalImplyTerm cond t2 + | t2 == ifFalse = Just $ pevalAndTerm t2 $ pevalImplyTerm cond t1 + | cond == t1 = Just $ pevalITETerm cond t2 ifFalse + | cond == t2 = Just $ pevalITETerm cond t1 ifFalse + | otherwise = + msum + [ pevalInferImplies cond t1 (pevalITETerm cond t2 ifFalse) (pevalAndTerm (pevalNotTerm cond) ifFalse), + pevalInferImplies cond t2 (pevalITETerm cond t1 ifFalse) (pevalAndTerm (pevalNotTerm cond) ifFalse) + ] + +pevalITEBoolBothAnd :: Term Bool -> Term Bool -> Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) +pevalITEBoolBothAnd cond t1 t2 f1 f2 + | t1 == f1 = Just $ pevalAndTerm t1 $ pevalITETerm cond t2 f2 + | t1 == f2 = Just $ pevalAndTerm t1 $ pevalITETerm cond t2 f1 + | t2 == f1 = Just $ pevalAndTerm t2 $ pevalITETerm cond t1 f2 + | t2 == f2 = Just $ pevalAndTerm t2 $ pevalITETerm cond t1 f1 + | otherwise = Nothing + +pevalITEBoolRightAnd :: Term Bool -> Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) +pevalITEBoolRightAnd cond ifTrue f1 f2 + | f1 == ifTrue = Just $ pevalAndTerm f1 $ pevalOrTerm cond f2 + | f2 == ifTrue = Just $ pevalAndTerm f2 $ pevalOrTerm cond f1 + | otherwise = Nothing + +pevalITEBoolLeftOr :: Term Bool -> Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) +pevalITEBoolLeftOr cond t1 t2 ifFalse + | t1 == ifFalse = Just $ pevalOrTerm t1 $ pevalAndTerm cond t2 + | t2 == ifFalse = Just $ pevalOrTerm t2 $ pevalAndTerm cond t1 + | cond == t1 = Just $ pevalOrTerm cond ifFalse + | cond == t2 = Just $ pevalOrTerm cond ifFalse + | otherwise = + msum + [ pevalInferImplies cond t1 (pevalOrTerm cond ifFalse) (pevalITETerm cond t2 ifFalse), + pevalInferImplies cond t2 (pevalOrTerm cond ifFalse) (pevalITETerm cond t1 ifFalse) + ] + +pevalITEBoolBothOr :: Term Bool -> Term Bool -> Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) +pevalITEBoolBothOr cond t1 t2 f1 f2 + | t1 == f1 = Just $ pevalOrTerm t1 $ pevalITETerm cond t2 f2 + | t1 == f2 = Just $ pevalOrTerm t1 $ pevalITETerm cond t2 f1 + | t2 == f1 = Just $ pevalOrTerm t2 $ pevalITETerm cond t1 f2 + | t2 == f2 = Just $ pevalOrTerm t2 $ pevalITETerm cond t1 f1 + | otherwise = Nothing + +pevalITEBoolRightOr :: Term Bool -> Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) +pevalITEBoolRightOr cond ifTrue f1 f2 + | f1 == ifTrue = Just $ pevalOrTerm f1 $ pevalAndTerm (pevalNotTerm cond) f2 + | f2 == ifTrue = Just $ pevalOrTerm f2 $ pevalAndTerm (pevalNotTerm cond) f1 + | otherwise = Nothing + +pevalITEBoolLeft :: Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) +pevalITEBoolLeft cond (AndTerm _ t1 t2) ifFalse = + msum + [ pevalITEBoolLeftAnd cond t1 t2 ifFalse, + case ifFalse of + AndTerm _ f1 f2 -> pevalITEBoolBothAnd cond t1 t2 f1 f2 + _ -> Nothing + ] +pevalITEBoolLeft cond (OrTerm _ t1 t2) ifFalse = + msum + [ pevalITEBoolLeftOr cond t1 t2 ifFalse, + case ifFalse of + OrTerm _ f1 f2 -> pevalITEBoolBothOr cond t1 t2 f1 f2 + _ -> Nothing + ] +pevalITEBoolLeft cond (NotTerm _ nIfTrue) ifFalse = + msum + [ pevalITEBoolLeftNot cond nIfTrue ifFalse, + case ifFalse of + NotTerm _ nIfFalse -> + pevalITEBoolBothNot cond nIfTrue nIfFalse + _ -> Nothing + ] +pevalITEBoolLeft _ _ _ = Nothing + +pevalITEBoolNoLeft :: Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) +pevalITEBoolNoLeft cond ifTrue (AndTerm _ f1 f2) = pevalITEBoolRightAnd cond ifTrue f1 f2 +pevalITEBoolNoLeft cond ifTrue (OrTerm _ f1 f2) = pevalITEBoolRightOr cond ifTrue f1 f2 +pevalITEBoolNoLeft cond ifTrue (NotTerm _ nIfFalse) = pevalITEBoolRightNot cond ifTrue nIfFalse +pevalITEBoolNoLeft _ _ _ = Nothing + +pevalITEBasic :: (SupportedPrim a) => Term Bool -> Term a -> Term a -> Maybe (Term a) +pevalITEBasic (ConTerm _ True) ifTrue _ = Just ifTrue +pevalITEBasic (ConTerm _ False) _ ifFalse = Just ifFalse +pevalITEBasic (NotTerm _ ncond) ifTrue ifFalse = Just $ pevalITETerm ncond ifFalse ifTrue +pevalITEBasic _ ifTrue ifFalse | ifTrue == ifFalse = Just ifTrue +pevalITEBasic (ITETerm _ cc ct cf) (ITETerm _ tc tt tf) (ITETerm _ fc ft ff) -- later + | cc == tc && cc == fc = Just $ pevalITETerm cc (pevalITETerm ct tt ft) (pevalITETerm cf tf ff) +pevalITEBasic cond (ITETerm _ tc tt tf) ifFalse -- later + | cond == tc = Just $ pevalITETerm cond tt ifFalse + | tt == ifFalse = Just $ pevalITETerm (pevalOrTerm (pevalNotTerm cond) tc) tt tf + | tf == ifFalse = Just $ pevalITETerm (pevalAndTerm cond tc) tt tf +pevalITEBasic cond ifTrue (ITETerm _ fc ft ff) -- later + | ifTrue == ft = Just $ pevalITETerm (pevalOrTerm cond fc) ifTrue ff + | ifTrue == ff = Just $ pevalITETerm (pevalOrTerm cond (pevalNotTerm fc)) ifTrue ft + | pevalImpliesTerm fc cond = Just $ pevalITETerm cond ifTrue ff +pevalITEBasic _ _ _ = Nothing + +pevalITEBoolBasic :: Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) +pevalITEBoolBasic cond ifTrue ifFalse + | cond == ifTrue = Just $ pevalOrTerm cond ifFalse + | cond == ifFalse = Just $ pevalAndTerm cond ifTrue +pevalITEBoolBasic cond (ConTerm _ v) ifFalse + | v = Just $ pevalOrTerm cond ifFalse + | otherwise = Just $ pevalAndTerm (pevalNotTerm cond) ifFalse +pevalITEBoolBasic cond ifTrue (ConTerm _ v) + | v = Just $ pevalOrTerm (pevalNotTerm cond) ifTrue + | otherwise = Just $ pevalAndTerm cond ifTrue +pevalITEBoolBasic _ _ _ = Nothing + +pevalITEBool :: Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) +pevalITEBool cond ifTrue ifFalse = + msum + [ pevalITEBasic cond ifTrue ifFalse, + pevalITEBoolBasic cond ifTrue ifFalse, + pevalITEBoolLeft cond ifTrue ifFalse, + pevalITEBoolNoLeft cond ifTrue ifFalse + ] + +pevalITEBasicTerm :: (SupportedPrim a) => Term Bool -> Term a -> Term a -> Term a +pevalITEBasicTerm cond ifTrue ifFalse = + fromMaybe (iteTerm cond ifTrue ifFalse) $ + pevalITEBasic cond ifTrue ifFalse + +pevalDefaultEqTerm :: (SupportedPrim a) => Term a -> Term a -> Term Bool +pevalDefaultEqTerm l@ConTerm {} r@ConTerm {} = conTerm $ l == r +pevalDefaultEqTerm l@ConTerm {} r = pevalDefaultEqTerm r l +pevalDefaultEqTerm l (BoolConTerm rv) = + if rv + then unsafeCoerce l + else pevalNotTerm (unsafeCoerce l) +pevalDefaultEqTerm (NotTerm _ lv) r + | lv == r = falseTerm +pevalDefaultEqTerm l (NotTerm _ rv) + | l == rv = falseTerm +pevalDefaultEqTerm (AddNumTerm _ (ConTerm _ c) v) (ConTerm _ c2) = + pevalDefaultEqTerm v (conTerm $ c2 - c) +pevalDefaultEqTerm l (ITETerm _ c t f) + | l == t = pevalOrTerm c (pevalDefaultEqTerm l f) + | l == f = pevalOrTerm (pevalNotTerm c) (pevalDefaultEqTerm l t) +pevalDefaultEqTerm (ITETerm _ c t f) r + | t == r = pevalOrTerm c (pevalDefaultEqTerm f r) + | f == r = pevalOrTerm (pevalNotTerm c) (pevalDefaultEqTerm t r) +pevalDefaultEqTerm l r + | l == r = trueTerm + | otherwise = eqTerm l r +{-# INLINEABLE pevalDefaultEqTerm #-} + +instance SBVRep Bool where + type SBVType _ Bool = SBV.SBV Bool + +instance SupportedPrimConstraint Bool + +instance SupportedPrim Bool where + pformatCon True = "true" + pformatCon False = "false" + defaultValue = defaultValueForBool + defaultValueDynamic _ = defaultValueForBoolDyn + pevalITETerm cond ifTrue ifFalse = + fromMaybe (iteTerm cond ifTrue ifFalse) $ + pevalITEBool cond ifTrue ifFalse + pevalEqTerm = pevalDefaultEqTerm + conSBVTerm _ n = if n then SBV.sTrue else SBV.sFalse + symSBVName symbol _ = show symbol + symSBVTerm _ = sbvFresh + withPrim _ r = r + parseSMTModelResult _ ([], SBVD.CV SBVD.KBool (SBVD.CInteger n)) = n /= 0 + parseSMTModelResult _ ([([], SBVD.CV SBVD.KBool (SBVD.CInteger n))], _) = n /= 0 + parseSMTModelResult _ cv = parseSMTModelResultError (typeRep @Bool) cv + +instance NonFuncSBVRep Bool where + type NonFuncSBVBaseType _ Bool = Bool + +instance SupportedNonFuncPrim Bool where + conNonFuncSBVTerm = conSBVTerm + symNonFuncSBVTerm = symSBVTerm @Bool + withNonFuncPrim _ r = r diff --git a/src/Grisette/Internal/SymPrim/Prim/Internal/Unfold.hs b/src/Grisette/Internal/SymPrim/Prim/Internal/Unfold.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/SymPrim/Prim/Internal/Unfold.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | +-- Module : Grisette.Internal.SymPrim.Prim.PartialEval.Unfold +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.SymPrim.Prim.Internal.Unfold + ( unaryUnfoldOnce, + binaryUnfoldOnce, + ) +where + +import Control.Monad.Except (MonadError (catchError)) +import Data.Typeable (Typeable) +import Grisette.Internal.SymPrim.Prim.Internal.PartialEval + ( PartialRuleBinary, + PartialRuleUnary, + TotalRuleBinary, + TotalRuleUnary, + totalize, + totalize2, + ) +import Grisette.Internal.SymPrim.Prim.Internal.Term + ( SupportedPrim (pevalITETerm), + Term (ITETerm), + ) + +unaryPartialUnfoldOnce :: + forall a b. + (SupportedPrim b) => + PartialRuleUnary a b -> + TotalRuleUnary a b -> + PartialRuleUnary a b +unaryPartialUnfoldOnce partial fallback = ret + where + oneLevel :: TotalRuleUnary a b -> PartialRuleUnary a b + oneLevel fallback' x = case (x, partial x) of + (ITETerm _ cond vt vf, pr) -> + let pt = partial vt + pf = partial vf + in case (pt, pf) of + (Nothing, Nothing) -> pr + (mt, mf) -> + pevalITETerm cond + <$> catchError mt (\_ -> Just $ totalize (oneLevel fallback') fallback' vt) + <*> catchError mf (\_ -> Just $ totalize (oneLevel fallback') fallback vf) + (_, pr) -> pr + ret :: PartialRuleUnary a b + ret = oneLevel (totalize @(Term a) @(Term b) partial fallback) + +unaryUnfoldOnce :: + forall a b. + (SupportedPrim b) => + PartialRuleUnary a b -> + TotalRuleUnary a b -> + TotalRuleUnary a b +unaryUnfoldOnce partial fallback = totalize (unaryPartialUnfoldOnce partial fallback) fallback + +binaryPartialUnfoldOnce :: + forall a b c. + (SupportedPrim c) => + PartialRuleBinary a b c -> + TotalRuleBinary a b c -> + PartialRuleBinary a b c +binaryPartialUnfoldOnce partial fallback = ret + where + oneLevel :: PartialRuleBinary x y c -> TotalRuleBinary x y c -> PartialRuleBinary x y c + oneLevel partial' fallback' x y = + catchError + (partial' x y) + ( \_ -> + catchError + ( case x of + ITETerm _ cond vt vf -> left cond vt vf y partial' fallback' + _ -> Nothing + ) + ( \_ -> case y of + ITETerm _ cond vt vf -> left cond vt vf x (flip partial') (flip fallback') + _ -> Nothing + ) + ) + left :: + Term Bool -> + Term x -> + Term x -> + Term y -> + PartialRuleBinary x y c -> + TotalRuleBinary x y c -> + Maybe (Term c) + left cond vt vf y partial' fallback' = + let pt = partial' vt y + pf = partial' vf y + in case (pt, pf) of + (Nothing, Nothing) -> Nothing + (mt, mf) -> + pevalITETerm cond + <$> catchError mt (\_ -> Just $ totalize2 (oneLevel partial' fallback') fallback' vt y) + <*> catchError mf (\_ -> Just $ totalize2 (oneLevel partial' fallback') fallback' vf y) + ret :: PartialRuleBinary a b c + ret = oneLevel partial (totalize2 @(Term a) @(Term b) @(Term c) partial fallback) + +binaryUnfoldOnce :: + forall a b c. + (Typeable a, Typeable b, SupportedPrim c) => + PartialRuleBinary a b c -> + TotalRuleBinary a b c -> + TotalRuleBinary a b c +binaryUnfoldOnce partial fallback = totalize2 (binaryPartialUnfoldOnce partial fallback) fallback diff --git a/src/Grisette/Internal/SymPrim/Prim/Internal/Utils.hs b/src/Grisette/Internal/SymPrim/Prim/Internal/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/SymPrim/Prim/Internal/Utils.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- Module : Grisette.Internal.SymPrim.Prim.Internal.Utils +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.SymPrim.Prim.Internal.Utils + ( pattern Dyn, + cmpHetero, + eqHetero, + cmpHeteroRep, + eqHeteroRep, + eqTypeRepBool, + ) +where + +import Data.Typeable (cast) +import Type.Reflection + ( TypeRep, + Typeable, + eqTypeRep, + typeRep, + type (:~~:) (HRefl), + ) + +pattern Dyn :: (Typeable a, Typeable b) => a -> b +pattern Dyn x <- (cast -> Just x) + +cmpHeteroRep :: forall a b. TypeRep a -> TypeRep b -> (a -> a -> Bool) -> a -> b -> Bool +cmpHeteroRep ta tb f a b = case eqTypeRep ta tb of + Just HRefl -> f a b + _ -> False +{-# INLINE cmpHeteroRep #-} + +cmpHetero :: forall a b. (Typeable a, Typeable b) => (a -> a -> Bool) -> a -> b -> Bool +cmpHetero = cmpHeteroRep (typeRep @a) (typeRep @b) +{-# INLINE cmpHetero #-} + +eqHetero :: forall a b. (Typeable a, Typeable b, Eq a) => a -> b -> Bool +eqHetero = cmpHetero (==) +{-# INLINE eqHetero #-} + +eqHeteroRep :: forall a b. (Eq a) => TypeRep a -> TypeRep b -> a -> b -> Bool +eqHeteroRep ta tb = cmpHeteroRep ta tb (==) +{-# INLINE eqHeteroRep #-} + +eqTypeRepBool :: forall ka kb (a :: ka) (b :: kb). TypeRep a -> TypeRep b -> Bool +eqTypeRepBool a b = case eqTypeRep a b of + Just HRefl -> True + _ -> False +{-# INLINE eqTypeRepBool #-} diff --git a/src/Grisette/Internal/SymPrim/Prim/Model.hs b/src/Grisette/Internal/SymPrim/Prim/Model.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/SymPrim/Prim/Model.hs @@ -0,0 +1,775 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Grisette.Internal.SymPrim.Prim.Model +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.SymPrim.Prim.Model + ( SymbolSet (..), + Model (..), + ModelValuePair (..), + equation, + evaluateTerm, + ) +where + +import qualified Data.HashMap.Strict as M +import qualified Data.HashSet as S +import Data.Hashable (Hashable) +import Data.List (sort, sortOn) +import Data.Proxy (Proxy (Proxy)) +import GHC.Generics (Generic) +import Grisette.Internal.Core.Data.Class.ModelOps + ( ModelOps + ( emptyModel, + exceptFor, + exceptFor', + extendTo, + insertValue, + isEmptyModel, + modelContains, + restrictTo, + valueOf + ), + ModelRep (buildModel), + SymbolSetOps + ( containsSymbol, + differenceSet, + emptySet, + insertSymbol, + intersectionSet, + isEmptySet, + unionSet + ), + SymbolSetRep (buildSymbolSet), + ) +import Grisette.Internal.Core.Data.MemoUtils (htmemo) +import Grisette.Internal.SymPrim.GeneralFun (type (-->) (GeneralFun)) +import Grisette.Internal.SymPrim.Prim.ModelValue + ( ModelValue, + toModelValue, + unsafeFromModelValue, + ) +import Grisette.Internal.SymPrim.Prim.SomeTerm + ( SomeTerm (SomeTerm), + ) +import Grisette.Internal.SymPrim.Prim.Term + ( BinaryOp (pevalBinary), + PEvalApplyTerm (pevalApplyTerm), + PEvalBVSignConversionTerm (pevalBVToSignedTerm, pevalBVToUnsignedTerm), + PEvalBVTerm (pevalBVConcatTerm, pevalBVExtendTerm, pevalBVSelectTerm), + PEvalBitwiseTerm + ( pevalAndBitsTerm, + pevalComplementBitsTerm, + pevalOrBitsTerm, + pevalXorBitsTerm + ), + PEvalDivModIntegralTerm + ( pevalDivIntegralTerm, + pevalModIntegralTerm, + pevalQuotIntegralTerm, + pevalRemIntegralTerm + ), + PEvalNumTerm + ( pevalAbsNumTerm, + pevalAddNumTerm, + pevalMulNumTerm, + pevalNegNumTerm, + pevalSignumNumTerm + ), + PEvalOrdTerm (pevalLeOrdTerm, pevalLtOrdTerm), + PEvalRotateTerm + ( pevalRotateLeftTerm, + pevalRotateRightTerm + ), + PEvalShiftTerm (pevalShiftLeftTerm, pevalShiftRightTerm), + SomeTypedSymbol (SomeTypedSymbol), + SupportedPrim (defaultValue, defaultValueDynamic, pevalITETerm), + Term + ( AbsNumTerm, + AddNumTerm, + AndBitsTerm, + AndTerm, + ApplyTerm, + BVConcatTerm, + BVExtendTerm, + BVSelectTerm, + BinaryTerm, + ComplementBitsTerm, + ConTerm, + DivIntegralTerm, + EqTerm, + ITETerm, + LeOrdTerm, + LtOrdTerm, + ModIntegralTerm, + MulNumTerm, + NegNumTerm, + NotTerm, + OrBitsTerm, + OrTerm, + QuotIntegralTerm, + RemIntegralTerm, + RotateLeftTerm, + RotateRightTerm, + ShiftLeftTerm, + ShiftRightTerm, + SignumNumTerm, + SymTerm, + TernaryTerm, + ToSignedTerm, + ToUnsignedTerm, + UnaryTerm, + XorBitsTerm + ), + TernaryOp (pevalTernary), + TypedSymbol (TypedSymbol, unTypedSymbol), + UnaryOp (pevalUnary), + conTerm, + pevalAndTerm, + pevalEqTerm, + pevalNotTerm, + pevalOrTerm, + showUntyped, + someTypedSymbol, + symTerm, + withSymbolSupported, + ) +import Grisette.Internal.Utils.Parameterized (unsafeAxiom) +import Type.Reflection + ( TypeRep, + eqTypeRep, + typeRep, + pattern App, + type (:~:) (Refl), + type (:~~:) (HRefl), + ) +import Unsafe.Coerce (unsafeCoerce) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim +-- >>> :set -XFlexibleContexts + +-- | Symbolic constant set. +newtype SymbolSet = SymbolSet {unSymbolSet :: S.HashSet SomeTypedSymbol} + deriving (Eq, Generic, Hashable, Semigroup, Monoid) + +instance Show SymbolSet where + showsPrec prec (SymbolSet s) = showParen (prec >= 10) $ \x -> + "SymbolSet {" + ++ go0 (sort $ show <$> S.toList s) + ++ "}" + ++ x + where + go0 [] = "" + go0 [x] = x + go0 (x : xs) = x ++ ", " ++ go0 xs + +-- | Model returned by the solver. +newtype Model = Model {unModel :: M.HashMap SomeTypedSymbol ModelValue} deriving (Eq, Generic, Hashable, Semigroup, Monoid) + +instance Show Model where + showsPrec prec (Model m) = showParen (prec >= 10) $ \x -> + "Model {" + ++ go0 (sortOn (\(x, _) -> show x) $ M.toList m) + ++ "}" + ++ x + where + go0 [] = "" + go0 [(SomeTypedSymbol _ s, v)] = showUntyped s ++ " -> " ++ show v + go0 ((SomeTypedSymbol _ s, v) : xs) = showUntyped s ++ " -> " ++ show v ++ ", " ++ go0 xs + +equation :: TypedSymbol a -> Model -> Maybe (Term Bool) +equation tsym@(TypedSymbol {}) m = withSymbolSupported tsym $ + case valueOf tsym m of + Just v -> Just $ pevalEqTerm (symTerm $ unTypedSymbol tsym) (conTerm v) + Nothing -> Nothing + +instance SymbolSetOps SymbolSet TypedSymbol where + emptySet = SymbolSet S.empty + isEmptySet (SymbolSet s) = S.null s + containsSymbol s = + S.member (someTypedSymbol s) . unSymbolSet + insertSymbol s = SymbolSet . S.insert (someTypedSymbol s) . unSymbolSet + intersectionSet (SymbolSet s1) (SymbolSet s2) = SymbolSet $ S.intersection s1 s2 + unionSet (SymbolSet s1) (SymbolSet s2) = SymbolSet $ S.union s1 s2 + differenceSet (SymbolSet s1) (SymbolSet s2) = SymbolSet $ S.difference s1 s2 + +instance SymbolSetRep (TypedSymbol t) SymbolSet TypedSymbol where + buildSymbolSet sym = insertSymbol sym emptySet + +instance + SymbolSetRep + ( TypedSymbol a, + TypedSymbol b + ) + SymbolSet + TypedSymbol + where + buildSymbolSet (sym1, sym2) = + insertSymbol sym2 + . insertSymbol sym1 + $ emptySet + +instance + SymbolSetRep + ( TypedSymbol a, + TypedSymbol b, + TypedSymbol c + ) + SymbolSet + TypedSymbol + where + buildSymbolSet (sym1, sym2, sym3) = + insertSymbol sym3 + . insertSymbol sym2 + . insertSymbol sym1 + $ emptySet + +instance + SymbolSetRep + ( TypedSymbol a, + TypedSymbol b, + TypedSymbol c, + TypedSymbol d + ) + SymbolSet + TypedSymbol + where + buildSymbolSet (sym1, sym2, sym3, sym4) = + insertSymbol sym4 + . insertSymbol sym3 + . insertSymbol sym2 + . insertSymbol sym1 + $ emptySet + +instance + SymbolSetRep + ( TypedSymbol a, + TypedSymbol b, + TypedSymbol c, + TypedSymbol d, + TypedSymbol e + ) + SymbolSet + TypedSymbol + where + buildSymbolSet (sym1, sym2, sym3, sym4, sym5) = + insertSymbol sym5 + . insertSymbol sym4 + . insertSymbol sym3 + . insertSymbol sym2 + . insertSymbol sym1 + $ emptySet + +instance + SymbolSetRep + ( TypedSymbol a, + TypedSymbol b, + TypedSymbol c, + TypedSymbol d, + TypedSymbol e, + TypedSymbol f + ) + SymbolSet + TypedSymbol + where + buildSymbolSet (sym1, sym2, sym3, sym4, sym5, sym6) = + insertSymbol sym6 + . insertSymbol sym5 + . insertSymbol sym4 + . insertSymbol sym3 + . insertSymbol sym2 + . insertSymbol sym1 + $ emptySet + +instance + SymbolSetRep + ( TypedSymbol a, + TypedSymbol b, + TypedSymbol c, + TypedSymbol d, + TypedSymbol e, + TypedSymbol f, + TypedSymbol g + ) + SymbolSet + TypedSymbol + where + buildSymbolSet (sym1, sym2, sym3, sym4, sym5, sym6, sym7) = + insertSymbol sym7 + . insertSymbol sym6 + . insertSymbol sym5 + . insertSymbol sym4 + . insertSymbol sym3 + . insertSymbol sym2 + . insertSymbol sym1 + $ emptySet + +instance + SymbolSetRep + ( TypedSymbol a, + TypedSymbol b, + TypedSymbol c, + TypedSymbol d, + TypedSymbol e, + TypedSymbol f, + TypedSymbol g, + TypedSymbol h + ) + SymbolSet + TypedSymbol + where + buildSymbolSet (sym1, sym2, sym3, sym4, sym5, sym6, sym7, sym8) = + insertSymbol sym8 + . insertSymbol sym7 + . insertSymbol sym6 + . insertSymbol sym5 + . insertSymbol sym4 + . insertSymbol sym3 + . insertSymbol sym2 + . insertSymbol sym1 + $ emptySet + +instance ModelOps Model SymbolSet TypedSymbol where + emptyModel = Model M.empty + isEmptyModel (Model m) = M.null m + valueOf :: forall t. TypedSymbol t -> Model -> Maybe t + valueOf sym (Model m) = + withSymbolSupported sym $ + (unsafeFromModelValue @t) + <$> M.lookup (someTypedSymbol sym) m + modelContains sym (Model m) = M.member (someTypedSymbol sym) m + exceptFor (SymbolSet s) (Model m) = Model $ S.foldl' (flip M.delete) m s + exceptFor' s (Model m) = Model $ M.delete (someTypedSymbol s) m + restrictTo (SymbolSet s) (Model m) = + Model $ + S.foldl' + ( \acc sym -> case M.lookup sym m of + Just v -> M.insert sym v acc + Nothing -> acc + ) + M.empty + s + extendTo (SymbolSet s) (Model m) = + Model $ + S.foldl' + ( \acc sym@(SomeTypedSymbol _ (tsym :: TypedSymbol t)) -> case M.lookup sym acc of + Just _ -> acc + Nothing -> withSymbolSupported tsym $ M.insert sym (defaultValueDynamic (Proxy @t)) acc + ) + m + s + insertValue sym (v :: t) (Model m) = + withSymbolSupported sym $ + Model $ + M.insert (someTypedSymbol sym) (toModelValue v) m + +evaluateSomeTerm :: Bool -> Model -> SomeTerm -> SomeTerm +evaluateSomeTerm fillDefault m@(Model ma) = gomemo + where + gomemo = htmemo go + gotyped :: (SupportedPrim a) => Term a -> Term a + gotyped a = case gomemo (SomeTerm a) of + SomeTerm v -> unsafeCoerce v + go c@(SomeTerm (ConTerm _ cv :: Term v)) = + case (typeRep :: TypeRep v) of + App (App gf _) _ -> + case eqTypeRep gf (typeRep @(-->)) of + Just HRefl -> case cv of + GeneralFun sym (tm :: Term r) -> + if modelContains sym m -- someTypedSymbol sym1 == someTypedSymbol sym + then case evaluateSomeTerm fillDefault (exceptFor' sym m) (SomeTerm tm) of + SomeTerm (tm' :: Term r1) -> + case unsafeAxiom @r @r1 of + Refl -> SomeTerm $ conTerm $ GeneralFun sym tm' -- stm + else SomeTerm $ conTerm $ GeneralFun sym (gotyped tm) + Nothing -> c + _ -> c + go c@(SomeTerm ((SymTerm _ sym) :: Term a)) = + case M.lookup (someTypedSymbol sym) ma of + Nothing -> if fillDefault then SomeTerm $ conTerm (defaultValue @a) else c + Just dy -> SomeTerm $ conTerm (unsafeFromModelValue @a dy) + go (SomeTerm (UnaryTerm _ tag (arg :: Term a))) = goUnary (pevalUnary tag) arg + go (SomeTerm (BinaryTerm _ tag (arg1 :: Term a1) (arg2 :: Term a2))) = + goBinary (pevalBinary tag) arg1 arg2 + go (SomeTerm (TernaryTerm _ tag (arg1 :: Term a1) (arg2 :: Term a2) (arg3 :: Term a3))) = do + goTernary (pevalTernary tag) arg1 arg2 arg3 + go (SomeTerm (NotTerm _ arg)) = goUnary pevalNotTerm arg + go (SomeTerm (OrTerm _ arg1 arg2)) = + goBinary pevalOrTerm arg1 arg2 + go (SomeTerm (AndTerm _ arg1 arg2)) = + goBinary pevalAndTerm arg1 arg2 + go (SomeTerm (EqTerm _ arg1 arg2)) = + goBinary pevalEqTerm arg1 arg2 + go (SomeTerm (ITETerm _ cond arg1 arg2)) = + goTernary pevalITETerm cond arg1 arg2 + go (SomeTerm (AddNumTerm _ arg1 arg2)) = + goBinary pevalAddNumTerm arg1 arg2 + go (SomeTerm (NegNumTerm _ arg)) = goUnary pevalNegNumTerm arg + go (SomeTerm (MulNumTerm _ arg1 arg2)) = + goBinary pevalMulNumTerm arg1 arg2 + go (SomeTerm (AbsNumTerm _ arg)) = goUnary pevalAbsNumTerm arg + go (SomeTerm (SignumNumTerm _ arg)) = goUnary pevalSignumNumTerm arg + go (SomeTerm (LtOrdTerm _ arg1 arg2)) = + goBinary pevalLtOrdTerm arg1 arg2 + go (SomeTerm (LeOrdTerm _ arg1 arg2)) = + goBinary pevalLeOrdTerm arg1 arg2 + go (SomeTerm (AndBitsTerm _ arg1 arg2)) = + goBinary pevalAndBitsTerm arg1 arg2 + go (SomeTerm (OrBitsTerm _ arg1 arg2)) = + goBinary pevalOrBitsTerm arg1 arg2 + go (SomeTerm (XorBitsTerm _ arg1 arg2)) = + goBinary pevalXorBitsTerm arg1 arg2 + go (SomeTerm (ComplementBitsTerm _ arg)) = goUnary pevalComplementBitsTerm arg + go (SomeTerm (ShiftLeftTerm _ arg n)) = goBinary pevalShiftLeftTerm arg n + go (SomeTerm (RotateLeftTerm _ arg n)) = goBinary pevalRotateLeftTerm arg n + go (SomeTerm (ShiftRightTerm _ arg n)) = goBinary pevalShiftRightTerm arg n + go (SomeTerm (RotateRightTerm _ arg n)) = goBinary pevalRotateRightTerm arg n + go (SomeTerm (ToSignedTerm _ arg)) = + goUnary pevalBVToSignedTerm arg + go (SomeTerm (ToUnsignedTerm _ arg)) = + goUnary pevalBVToUnsignedTerm arg + go (SomeTerm (BVConcatTerm _ arg1 arg2)) = + goBinary pevalBVConcatTerm arg1 arg2 + go (SomeTerm (BVSelectTerm _ ix w arg)) = + goUnary (pevalBVSelectTerm ix w) arg + go (SomeTerm (BVExtendTerm _ n signed arg)) = + goUnary (pevalBVExtendTerm n signed) arg + go (SomeTerm (ApplyTerm _ f arg)) = + goBinary pevalApplyTerm f arg + go (SomeTerm (DivIntegralTerm _ arg1 arg2)) = + goBinary pevalDivIntegralTerm arg1 arg2 + go (SomeTerm (ModIntegralTerm _ arg1 arg2)) = + goBinary pevalModIntegralTerm arg1 arg2 + go (SomeTerm (QuotIntegralTerm _ arg1 arg2)) = + goBinary pevalQuotIntegralTerm arg1 arg2 + go (SomeTerm (RemIntegralTerm _ arg1 arg2)) = + goBinary pevalRemIntegralTerm arg1 arg2 + goUnary :: (SupportedPrim a, SupportedPrim b) => (Term a -> Term b) -> Term a -> SomeTerm + goUnary f a = SomeTerm $ f (gotyped a) + goBinary :: + (SupportedPrim a, SupportedPrim b, SupportedPrim c) => + (Term a -> Term b -> Term c) -> + Term a -> + Term b -> + SomeTerm + goBinary f a b = SomeTerm $ f (gotyped a) (gotyped b) + goTernary :: + (SupportedPrim a, SupportedPrim b, SupportedPrim c, SupportedPrim d) => + (Term a -> Term b -> Term c -> Term d) -> + Term a -> + Term b -> + Term c -> + SomeTerm + goTernary f a b c = SomeTerm $ f (gotyped a) (gotyped b) (gotyped c) + +evaluateTerm :: forall a. (SupportedPrim a) => Bool -> Model -> Term a -> Term a +evaluateTerm fillDefault m t = case evaluateSomeTerm fillDefault m $ SomeTerm t of + SomeTerm (t1 :: Term b) -> unsafeCoerce @(Term b) @(Term a) t1 + +-- | +-- A type used for building a model by hand. +-- +-- >>> buildModel ("x" ::= (1 :: Integer), "y" ::= True) :: Model +-- Model {x -> 1 :: Integer, y -> True :: Bool} +data ModelValuePair t = (TypedSymbol t) ::= t deriving (Show) + +instance ModelRep (ModelValuePair t) Model where + buildModel (sym ::= val) = insertValue sym val emptyModel + +instance (ModelRep a Model, ModelRep b Model) => ModelRep (a, b) Model where + buildModel (a, b) = buildModel a <> buildModel b + +instance + ( ModelRep a Model, + ModelRep b Model, + ModelRep c Model + ) => + ModelRep (a, b, c) Model + where + buildModel (a, b, c) = buildModel a <> buildModel b <> buildModel c + +instance + ( ModelRep a Model, + ModelRep b Model, + ModelRep c Model, + ModelRep d Model + ) => + ModelRep (a, b, c, d) Model + where + buildModel (a, b, c, d) = + buildModel a <> buildModel b <> buildModel c <> buildModel d + +instance + ( ModelRep a Model, + ModelRep b Model, + ModelRep c Model, + ModelRep d Model, + ModelRep e Model + ) => + ModelRep (a, b, c, d, e) Model + where + buildModel (a, b, c, d, e) = + buildModel a <> buildModel b <> buildModel c <> buildModel d <> buildModel e + +instance + ( ModelRep a Model, + ModelRep b Model, + ModelRep c Model, + ModelRep d Model, + ModelRep e Model, + ModelRep f Model + ) => + ModelRep (a, b, c, d, e, f) Model + where + buildModel (a, b, c, d, e, f) = + buildModel a + <> buildModel b + <> buildModel c + <> buildModel d + <> buildModel e + <> buildModel f + +instance + ( ModelRep a Model, + ModelRep b Model, + ModelRep c Model, + ModelRep d Model, + ModelRep e Model, + ModelRep f Model, + ModelRep g Model + ) => + ModelRep (a, b, c, d, e, f, g) Model + where + buildModel (a, b, c, d, e, f, g) = + buildModel a + <> buildModel b + <> buildModel c + <> buildModel d + <> buildModel e + <> buildModel f + <> buildModel g + +instance + ( ModelRep a Model, + ModelRep b Model, + ModelRep c Model, + ModelRep d Model, + ModelRep e Model, + ModelRep f Model, + ModelRep g Model, + ModelRep h Model + ) => + ModelRep (a, b, c, d, e, f, g, h) Model + where + buildModel (a, b, c, d, e, f, g, h) = + buildModel a + <> buildModel b + <> buildModel c + <> buildModel d + <> buildModel e + <> buildModel f + <> buildModel g + <> buildModel h + +{- +instance + ModelRep + ( ModelValuePair a, + ModelValuePair b + ) + Model + SymbolSet + TypedSymbol + where + buildModel + ( sym1 ::= val1, + sym2 ::= val2 + ) = + insertValue sym2 val2 + . insertValue sym1 val1 + $ emptyModel + +instance + ModelRep + ( ModelValuePair a, + ModelValuePair b, + ModelValuePair c + ) + Model + SymbolSet + TypedSymbol + where + buildModel + ( sym1 ::= val1, + sym2 ::= val2, + sym3 ::= val3 + ) = + insertValue sym3 val3 + . insertValue sym2 val2 + . insertValue sym1 val1 + $ emptyModel + +instance + ModelRep + ( ModelValuePair a, + ModelValuePair b, + ModelValuePair c, + ModelValuePair d + ) + Model + SymbolSet + TypedSymbol + where + buildModel + ( sym1 ::= val1, + sym2 ::= val2, + sym3 ::= val3, + sym4 ::= val4 + ) = + insertValue sym4 val4 + . insertValue sym3 val3 + . insertValue sym2 val2 + . insertValue sym1 val1 + $ emptyModel + +instance + ModelRep + ( ModelValuePair a, + ModelValuePair b, + ModelValuePair c, + ModelValuePair d, + ModelValuePair e + ) + Model + SymbolSet + TypedSymbol + where + buildModel + ( sym1 ::= val1, + sym2 ::= val2, + sym3 ::= val3, + sym4 ::= val4, + sym5 ::= val5 + ) = + insertValue sym5 val5 + . insertValue sym4 val4 + . insertValue sym3 val3 + . insertValue sym2 val2 + . insertValue sym1 val1 + $ emptyModel + +instance + ModelRep + ( ModelValuePair a, + ModelValuePair b, + ModelValuePair c, + ModelValuePair d, + ModelValuePair e, + ModelValuePair f + ) + Model + SymbolSet + TypedSymbol + where + buildModel + ( sym1 ::= val1, + sym2 ::= val2, + sym3 ::= val3, + sym4 ::= val4, + sym5 ::= val5, + sym6 ::= val6 + ) = + insertValue sym6 val6 + . insertValue sym5 val5 + . insertValue sym4 val4 + . insertValue sym3 val3 + . insertValue sym2 val2 + . insertValue sym1 val1 + $ emptyModel + +instance + ModelRep + ( ModelValuePair a, + ModelValuePair b, + ModelValuePair c, + ModelValuePair d, + ModelValuePair e, + ModelValuePair f, + ModelValuePair g + ) + Model + SymbolSet + TypedSymbol + where + buildModel + ( sym1 ::= val1, + sym2 ::= val2, + sym3 ::= val3, + sym4 ::= val4, + sym5 ::= val5, + sym6 ::= val6, + sym7 ::= val7 + ) = + insertValue sym7 val7 + . insertValue sym6 val6 + . insertValue sym5 val5 + . insertValue sym4 val4 + . insertValue sym3 val3 + . insertValue sym2 val2 + . insertValue sym1 val1 + $ emptyModel + +instance + ModelRep + ( ModelValuePair a, + ModelValuePair b, + ModelValuePair c, + ModelValuePair d, + ModelValuePair e, + ModelValuePair f, + ModelValuePair g, + ModelValuePair h + ) + Model + SymbolSet + TypedSymbol + where + buildModel + ( sym1 ::= val1, + sym2 ::= val2, + sym3 ::= val3, + sym4 ::= val4, + sym5 ::= val5, + sym6 ::= val6, + sym7 ::= val7, + sym8 ::= val8 + ) = + insertValue sym8 val8 + . insertValue sym7 val7 + . insertValue sym6 val6 + . insertValue sym5 val5 + . insertValue sym4 val4 + . insertValue sym3 val3 + . insertValue sym2 val2 + . insertValue sym1 val1 + $ emptyModel + +-} diff --git a/src/Grisette/Internal/SymPrim/Prim/ModelValue.hs b/src/Grisette/Internal/SymPrim/Prim/ModelValue.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/SymPrim/Prim/ModelValue.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | +-- Module : Grisette.Internal.SymPrim.Prim.ModelValue +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.SymPrim.Prim.ModelValue + ( ModelValue (..), + toModelValue, + unsafeFromModelValue, + ) +where + +import Data.Hashable (Hashable (hashWithSalt)) +import Type.Reflection + ( TypeRep, + Typeable, + eqTypeRep, + typeRep, + type (:~~:) (HRefl), + ) + +data ModelValue where + ModelValue :: forall v. (Show v, Eq v, Hashable v) => TypeRep v -> v -> ModelValue + +instance Show ModelValue where + show (ModelValue t v) = show v ++ " :: " ++ show t + +instance Eq ModelValue where + (ModelValue t1 v1) == (ModelValue t2 v2) = + case eqTypeRep t1 t2 of + Just HRefl -> v1 == v2 + _ -> False + +instance Hashable ModelValue where + s `hashWithSalt` (ModelValue t v) = s `hashWithSalt` t `hashWithSalt` v + +unsafeFromModelValue :: forall a. (Typeable a) => ModelValue -> a +unsafeFromModelValue (ModelValue t v) = case eqTypeRep t (typeRep @a) of + Just HRefl -> v + _ -> error $ "Bad model value type, expected type: " ++ show (typeRep @a) ++ ", but got: " ++ show t + +toModelValue :: forall a. (Show a, Eq a, Hashable a, Typeable a) => a -> ModelValue +toModelValue = ModelValue (typeRep @a) diff --git a/src/Grisette/Internal/SymPrim/Prim/SomeTerm.hs b/src/Grisette/Internal/SymPrim/Prim/SomeTerm.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/SymPrim/Prim/SomeTerm.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | +-- Module : Grisette.Internal.SymPrim.Prim.SomeTerm +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.SymPrim.Prim.SomeTerm (SomeTerm (..)) where + +import Data.Hashable (Hashable (hashWithSalt)) +import Data.Typeable (Proxy (Proxy), typeRep) +import Grisette.Internal.SymPrim.Prim.Internal.Term + ( SupportedPrim, + Term, + identityWithTypeRep, + ) + +data SomeTerm where + SomeTerm :: forall a. (SupportedPrim a) => Term a -> SomeTerm + +instance Eq SomeTerm where + (SomeTerm t1) == (SomeTerm t2) = + identityWithTypeRep t1 == identityWithTypeRep t2 + +instance Hashable SomeTerm where + hashWithSalt s (SomeTerm t) = hashWithSalt s $ identityWithTypeRep t + +instance Show SomeTerm where + show (SomeTerm (t :: Term a)) = + "<<" ++ show t ++ " :: " ++ show (typeRep (Proxy @a)) ++ ">>" diff --git a/src/Grisette/Internal/SymPrim/Prim/Term.hs b/src/Grisette/Internal/SymPrim/Prim/Term.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/SymPrim/Prim/Term.hs @@ -0,0 +1,29 @@ +{-# OPTIONS_GHC -Wno-missing-import-lists #-} + +-- | +-- Module : Grisette.Internal.SymPrim.Prim.Term +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.SymPrim.Prim.Term + ( module Grisette.Internal.SymPrim.Prim.Internal.Term, + module Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalShiftTerm, + module Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalRotateTerm, + module Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalNumTerm, + module Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalOrdTerm, + module Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalDivModIntegralTerm, + ) +where + +import Grisette.Internal.SymPrim.Prim.Internal.Instances.BVPEval () +import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalBitwiseTerm () +import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalDivModIntegralTerm +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 diff --git a/src/Grisette/Internal/SymPrim/Prim/TermUtils.hs b/src/Grisette/Internal/SymPrim/Prim/TermUtils.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/SymPrim/Prim/TermUtils.hs @@ -0,0 +1,285 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | +-- Module : Grisette.Internal.SymPrim.Prim.TermUtils +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.SymPrim.Prim.TermUtils + ( extractSymbolicsTerm, + castTerm, + someTermsSize, + someTermSize, + termSize, + termsSize, + ) +where + +import Control.Monad.State + ( MonadState (get, put), + State, + evalState, + execState, + gets, + modify', + ) +import qualified Data.HashMap.Strict as M +import qualified Data.HashSet as S +import Data.Typeable + ( Typeable, + cast, + ) +import Grisette.Internal.SymPrim.Prim.Internal.Term + ( SomeTypedSymbol (SomeTypedSymbol), + SupportedPrim, + Term + ( AbsNumTerm, + AddNumTerm, + AndBitsTerm, + AndTerm, + ApplyTerm, + BVConcatTerm, + BVExtendTerm, + BVSelectTerm, + BinaryTerm, + ComplementBitsTerm, + ConTerm, + DivIntegralTerm, + EqTerm, + ITETerm, + LeOrdTerm, + LtOrdTerm, + ModIntegralTerm, + MulNumTerm, + NegNumTerm, + NotTerm, + OrBitsTerm, + OrTerm, + QuotIntegralTerm, + RemIntegralTerm, + RotateLeftTerm, + RotateRightTerm, + ShiftLeftTerm, + ShiftRightTerm, + SignumNumTerm, + SymTerm, + TernaryTerm, + ToSignedTerm, + ToUnsignedTerm, + UnaryTerm, + XorBitsTerm + ), + TypedSymbol, + introSupportedPrimConstraint, + ) +import Grisette.Internal.SymPrim.Prim.SomeTerm + ( SomeTerm (SomeTerm), + ) +import qualified Type.Reflection as R + +extractSymbolicsSomeTerm :: SomeTerm -> S.HashSet SomeTypedSymbol +extractSymbolicsSomeTerm t1 = evalState (gocached t1) M.empty + where + gocached :: SomeTerm -> State (M.HashMap SomeTerm (S.HashSet SomeTypedSymbol)) (S.HashSet SomeTypedSymbol) + gocached t = do + v <- gets (M.lookup t) + case v of + Just x -> return x + Nothing -> do + res <- go t + st <- get + put $ M.insert t res st + return res + go :: SomeTerm -> State (M.HashMap SomeTerm (S.HashSet SomeTypedSymbol)) (S.HashSet SomeTypedSymbol) + go (SomeTerm ConTerm {}) = return S.empty + go (SomeTerm (SymTerm _ (sym :: TypedSymbol a))) = return $ S.singleton $ SomeTypedSymbol (R.typeRep @a) sym + go (SomeTerm (UnaryTerm _ _ arg)) = goUnary arg + go (SomeTerm (BinaryTerm _ _ arg1 arg2)) = goBinary arg1 arg2 + go (SomeTerm (TernaryTerm _ _ arg1 arg2 arg3)) = goTernary arg1 arg2 arg3 + go (SomeTerm (NotTerm _ arg)) = goUnary arg + go (SomeTerm (OrTerm _ arg1 arg2)) = goBinary arg1 arg2 + go (SomeTerm (AndTerm _ arg1 arg2)) = goBinary arg1 arg2 + go (SomeTerm (EqTerm _ arg1 arg2)) = goBinary arg1 arg2 + go (SomeTerm (ITETerm _ cond arg1 arg2)) = goTernary cond arg1 arg2 + go (SomeTerm (AddNumTerm _ arg1 arg2)) = goBinary arg1 arg2 + go (SomeTerm (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 n1)) = goBinary arg n1 + go (SomeTerm (ShiftRightTerm _ arg n1)) = goBinary arg n1 + go (SomeTerm (RotateLeftTerm _ arg n1)) = goBinary arg n1 + go (SomeTerm (RotateRightTerm _ arg n1)) = goBinary arg n1 + go (SomeTerm (ToSignedTerm _ arg)) = goUnary arg + go (SomeTerm (ToUnsignedTerm _ arg)) = goUnary arg + go (SomeTerm (BVConcatTerm _ arg1 arg2)) = goBinary arg1 arg2 + go (SomeTerm (BVSelectTerm _ _ _ arg)) = goUnary arg + go (SomeTerm (BVExtendTerm _ _ _ arg)) = goUnary arg + go (SomeTerm (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 + goUnary arg = gocached (SomeTerm arg) + goBinary arg1 arg2 = do + r1 <- gocached (SomeTerm arg1) + r2 <- gocached (SomeTerm arg2) + return $ r1 <> r2 + goTernary arg1 arg2 arg3 = do + r1 <- gocached (SomeTerm arg1) + r2 <- gocached (SomeTerm arg2) + r3 <- gocached (SomeTerm arg3) + return $ r1 <> r2 <> r3 +{-# INLINEABLE extractSymbolicsSomeTerm #-} + +extractSymbolicsTerm :: (SupportedPrim a) => Term a -> S.HashSet SomeTypedSymbol +extractSymbolicsTerm t = extractSymbolicsSomeTerm (SomeTerm t) +{-# INLINE extractSymbolicsTerm #-} + +castTerm :: forall a b. (Typeable b) => Term a -> Maybe (Term b) +castTerm t@ConTerm {} = cast t +castTerm t@SymTerm {} = cast t +castTerm t@UnaryTerm {} = cast t +castTerm t@BinaryTerm {} = cast t +castTerm t@TernaryTerm {} = cast t +castTerm t@NotTerm {} = cast t +castTerm t@OrTerm {} = cast t +castTerm t@AndTerm {} = cast t +castTerm t@EqTerm {} = cast t +castTerm t@ITETerm {} = cast t +castTerm t@AddNumTerm {} = cast t +castTerm t@NegNumTerm {} = cast t +castTerm t@MulNumTerm {} = cast t +castTerm t@AbsNumTerm {} = cast t +castTerm t@SignumNumTerm {} = cast t +castTerm t@LtOrdTerm {} = cast t +castTerm t@LeOrdTerm {} = cast t +castTerm t@AndBitsTerm {} = cast t +castTerm t@OrBitsTerm {} = cast t +castTerm t@XorBitsTerm {} = cast t +castTerm t@ComplementBitsTerm {} = cast t +castTerm t@ShiftLeftTerm {} = cast t +castTerm t@ShiftRightTerm {} = cast t +castTerm t@RotateLeftTerm {} = cast t +castTerm t@RotateRightTerm {} = cast t +castTerm t@ToSignedTerm {} = cast t +castTerm t@ToUnsignedTerm {} = cast t +castTerm t@BVConcatTerm {} = cast t +castTerm t@BVSelectTerm {} = cast t +castTerm t@BVExtendTerm {} = cast t +castTerm t@ApplyTerm {} = cast t +castTerm t@DivIntegralTerm {} = cast t +castTerm t@ModIntegralTerm {} = cast t +castTerm t@QuotIntegralTerm {} = cast t +castTerm t@RemIntegralTerm {} = cast t +{-# INLINE castTerm #-} + +someTermsSize :: [SomeTerm] -> Int +someTermsSize terms = S.size $ execState (traverse goSome terms) S.empty + where + exists t = gets (S.member (SomeTerm t)) + add t = modify' (S.insert (SomeTerm t)) + goSome :: SomeTerm -> State (S.HashSet SomeTerm) () + goSome (SomeTerm b) = go b + go :: forall b. Term b -> State (S.HashSet SomeTerm) () + go t@ConTerm {} = add t + go t@SymTerm {} = add t + go t@(UnaryTerm _ _ arg) = goUnary t arg + go t@(BinaryTerm _ _ arg1 arg2) = goBinary t arg1 arg2 + go t@(TernaryTerm _ _ arg1 arg2 arg3) = goTernary t arg1 arg2 arg3 + go t@(NotTerm _ arg) = goUnary t arg + go t@(OrTerm _ arg1 arg2) = goBinary t arg1 arg2 + go t@(AndTerm _ arg1 arg2) = goBinary t arg1 arg2 + go t@(EqTerm _ arg1 arg2) = goBinary t arg1 arg2 + go t@(ITETerm _ cond arg1 arg2) = goTernary t cond arg1 arg2 + go t@(AddNumTerm _ arg1 arg2) = goBinary t arg1 arg2 + go t@(NegNumTerm _ arg) = goUnary t arg + go t@(MulNumTerm _ arg1 arg2) = goBinary t arg1 arg2 + go t@(AbsNumTerm _ arg) = goUnary t arg + go t@(SignumNumTerm _ arg) = goUnary t arg + go t@(LtOrdTerm _ arg1 arg2) = goBinary t arg1 arg2 + go t@(LeOrdTerm _ arg1 arg2) = goBinary t arg1 arg2 + go t@(AndBitsTerm _ arg1 arg2) = goBinary t arg1 arg2 + go t@(OrBitsTerm _ arg1 arg2) = goBinary t arg1 arg2 + go t@(XorBitsTerm _ arg1 arg2) = goBinary t arg1 arg2 + go t@(ComplementBitsTerm _ arg) = goUnary t arg + go t@(ShiftLeftTerm _ arg n) = goBinary t arg n + go t@(ShiftRightTerm _ arg n) = goBinary t arg n + go t@(RotateLeftTerm _ arg n) = goBinary t arg n + go t@(RotateRightTerm _ arg n) = goBinary t arg n + go t@(ToSignedTerm _ arg) = goUnary t arg + go t@(ToUnsignedTerm _ arg) = goUnary t arg + go t@(BVConcatTerm _ arg1 arg2) = goBinary t arg1 arg2 + go t@(BVSelectTerm _ _ _ arg) = goUnary t arg + go t@(BVExtendTerm _ _ _ arg) = goUnary t arg + go t@(ApplyTerm _ func arg) = goBinary t func arg + go t@(DivIntegralTerm _ arg1 arg2) = goBinary t arg1 arg2 + go t@(ModIntegralTerm _ arg1 arg2) = goBinary t arg1 arg2 + go t@(QuotIntegralTerm _ arg1 arg2) = goBinary t arg1 arg2 + go t@(RemIntegralTerm _ arg1 arg2) = goBinary t arg1 arg2 + goUnary :: forall a b. (SupportedPrim a) => Term a -> Term b -> State (S.HashSet SomeTerm) () + goUnary t arg = do + b <- exists t + if b + then return () + else do + add t + go arg + goBinary :: + forall a b c. + (SupportedPrim a, SupportedPrim b) => + Term a -> + Term b -> + Term c -> + State (S.HashSet SomeTerm) () + goBinary t arg1 arg2 = do + b <- exists t + if b + then return () + else do + add t + go arg1 + go arg2 + goTernary :: + forall a b c d. + (SupportedPrim a, SupportedPrim b, SupportedPrim c) => + Term a -> + Term b -> + Term c -> + Term d -> + State (S.HashSet SomeTerm) () + goTernary t arg1 arg2 arg3 = do + b <- exists t + if b + then return () + else do + add t + go arg1 + go arg2 + go arg3 +{-# INLINEABLE someTermsSize #-} + +someTermSize :: SomeTerm -> Int +someTermSize term = someTermsSize [term] +{-# INLINE someTermSize #-} + +termsSize :: [Term a] -> Int +termsSize terms = someTermsSize $ (\x -> introSupportedPrimConstraint x $ SomeTerm x) <$> terms +{-# INLINEABLE termsSize #-} + +termSize :: Term a -> Int +termSize term = termsSize [term] +{-# INLINE termSize #-} diff --git a/src/Grisette/Internal/SymPrim/SomeBV.hs b/src/Grisette/Internal/SymPrim/SomeBV.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/SymPrim/SomeBV.hs @@ -0,0 +1,975 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- Module : Grisette.Internal.SymPrim.SomeBV +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.SymPrim.SomeBV + ( SomeBV (..), + + -- * Constructing and pattern matching on SomeBV + unsafeSomeBV, + conBV, + conBVView, + pattern ConBV, + symBV, + ssymBV, + isymBV, + arbitraryBV, + + -- * Synonyms + pattern SomeIntN, + type SomeIntN, + pattern SomeWordN, + type SomeWordN, + pattern SomeSymIntN, + type SomeSymIntN, + pattern SomeSymWordN, + type SomeSymWordN, + + -- * Helpers for manipulating SomeBV + unarySomeBV, + unarySomeBVR1, + binSomeBV, + binSomeBVR1, + binSomeBVR2, + binSomeBVSafe, + binSomeBVSafeR1, + binSomeBVSafeR2, + ) +where + +import Control.DeepSeq (NFData (rnf)) +import Control.Exception (throw) +import Control.Monad.Except (ExceptT, MonadError) +import Data.Bifunctor (Bifunctor (bimap)) +import Data.Bits + ( Bits + ( bit, + bitSize, + bitSizeMaybe, + clearBit, + complement, + complementBit, + isSigned, + popCount, + rotate, + rotateL, + rotateR, + setBit, + shift, + shiftL, + shiftR, + testBit, + unsafeShiftL, + unsafeShiftR, + xor, + zeroBits, + (.&.), + (.|.) + ), + FiniteBits (countLeadingZeros, countTrailingZeros, finiteBitSize), + ) +import Data.Data (Proxy (Proxy)) +import Data.Hashable (Hashable (hashWithSalt)) +import Data.Maybe (fromJust) +import Data.Type.Equality (type (:~:) (Refl)) +import GHC.TypeNats + ( KnownNat, + Nat, + natVal, + sameNat, + type (+), + type (<=), + ) +import Grisette.Internal.Core.Control.Monad.UnionM (UnionM) +import Grisette.Internal.Core.Data.Class.BitVector + ( BV (bv, bvConcat, bvExt, bvSelect, bvSext, bvZext), + SizedBV + ( sizedBVConcat, + sizedBVExt, + sizedBVFromIntegral, + sizedBVSelect, + sizedBVSext, + sizedBVZext + ), + ) +import Grisette.Internal.Core.Data.Class.EvaluateSym + ( EvaluateSym (evaluateSym), + ) +import Grisette.Internal.Core.Data.Class.ExtractSymbolics + ( ExtractSymbolics (extractSymbolics), + ) +import Grisette.Internal.Core.Data.Class.GPretty + ( GPretty (gpretty), + ) +import Grisette.Internal.Core.Data.Class.GenSym + ( GenSym (fresh), + GenSymSimple (simpleFresh), + ) +import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp (symIte)) +import Grisette.Internal.Core.Data.Class.Mergeable + ( Mergeable (rootStrategy), + MergingStrategy (SortedStrategy), + wrapStrategy, + ) +import Grisette.Internal.Core.Data.Class.SEq (SEq ((./=), (.==))) +import Grisette.Internal.Core.Data.Class.SOrd + ( SOrd (symCompare, (.<), (.<=), (.>), (.>=)), + ) +import Grisette.Internal.Core.Data.Class.SafeDivision + ( SafeDivision (safeDiv, safeDivMod, safeMod, safeQuot, safeQuotRem, safeRem), + ) +import Grisette.Internal.Core.Data.Class.SafeLinearArith + ( SafeLinearArith (safeAdd, safeNeg, safeSub), + ) +import Grisette.Internal.Core.Data.Class.SafeSymRotate + ( SafeSymRotate (safeSymRotateL, safeSymRotateR), + ) +import Grisette.Internal.Core.Data.Class.SafeSymShift + ( SafeSymShift + ( safeSymShiftL, + safeSymShiftR, + safeSymStrictShiftL, + safeSymStrictShiftR + ), + ) +import Grisette.Internal.Core.Data.Class.SignConversion + ( SignConversion (toSigned, toUnsigned), + ) +import Grisette.Internal.Core.Data.Class.Solvable + ( Solvable (con, conView, isym, ssym, sym), + ) +import Grisette.Internal.Core.Data.Class.SubstituteSym + ( SubstituteSym (substituteSym), + ) +import Grisette.Internal.Core.Data.Class.SymRotate (SymRotate (symRotate, symRotateNegated)) +import Grisette.Internal.Core.Data.Class.SymShift (SymShift (symShift, symShiftNegated)) +import Grisette.Internal.Core.Data.Class.ToCon (ToCon (toCon)) +import Grisette.Internal.Core.Data.Class.ToSym (ToSym (toSym)) +import Grisette.Internal.Core.Data.Class.TryMerge (TryMerge) +import Grisette.Internal.Core.Data.Symbol (Identifier, Symbol) +import Grisette.Internal.SymPrim.AllSyms (AllSyms (allSyms, allSymsS)) +import Grisette.Internal.SymPrim.BV + ( BitwidthMismatch (BitwidthMismatch), + IntN, + WordN, + ) +import Grisette.Internal.SymPrim.SymBV + ( SymIntN, + SymWordN, + ) +import Grisette.Internal.Utils.Parameterized + ( KnownProof (KnownProof), + LeqProof (LeqProof), + NatRepr, + SomePositiveNatRepr (SomePositiveNatRepr), + knownAdd, + leqAddPos, + mkPositiveNatRepr, + unsafeKnownProof, + unsafeLeqProof, + ) +import Grisette.Lib.Control.Monad.Except (mrgModifyError, mrgThrowError) +import Grisette.Lib.Data.Functor (mrgFmap) +import Language.Haskell.TH.Syntax (Lift (liftTyped)) +import Test.QuickCheck (Arbitrary (arbitrary), Gen) +import Unsafe.Coerce (unsafeCoerce) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim +-- >>> :set -XDataKinds +-- >>> :set -XBinaryLiterals +-- >>> :set -XFlexibleContexts +-- >>> :set -XFlexibleInstances +-- >>> :set -XFunctionalDependencies + +-- | Non-indexed bitvectors. +data SomeBV bv where + SomeBV :: (KnownNat n, 1 <= n) => bv n -> SomeBV bv + +instance + (forall n. (KnownNat n, 1 <= n) => Hashable (bv n)) => + Hashable (SomeBV bv) + where + hashWithSalt s (SomeBV (bv :: bv n)) = + s `hashWithSalt` (natVal (Proxy @n)) `hashWithSalt` bv + {-# INLINE hashWithSalt #-} + +instance + (forall n. (KnownNat n, 1 <= n) => Lift (bv n)) => + Lift (SomeBV bv) + where + liftTyped (SomeBV bv) = [||SomeBV bv||] + +instance + (forall n. (KnownNat n, 1 <= n) => Show (bv n)) => + Show (SomeBV bv) + where + show (SomeBV bv) = show bv + {-# INLINE show #-} + +instance + (forall n. (KnownNat n, 1 <= n) => NFData (bv n)) => + NFData (SomeBV bv) + where + rnf (SomeBV bv) = rnf bv + {-# INLINE rnf #-} + +instance (forall n. (KnownNat n, 1 <= n) => Eq (bv n)) => Eq (SomeBV bv) where + (==) = binSomeBV (==) + {-# INLINE (==) #-} + (/=) = binSomeBV (/=) + {-# INLINE (/=) #-} + +instance (forall n. (KnownNat n, 1 <= n) => Ord (bv n)) => Ord (SomeBV bv) where + (<) = binSomeBV (<) + {-# INLINE (<) #-} + (<=) = binSomeBV (<=) + {-# INLINE (<=) #-} + (>) = binSomeBV (>) + {-# INLINE (>) #-} + (>=) = binSomeBV (>=) + {-# INLINE (>=) #-} + max = binSomeBVR1 max + {-# INLINE max #-} + min = binSomeBVR1 min + {-# INLINE min #-} + compare = binSomeBV compare + {-# INLINE compare #-} + +instance (forall n. (KnownNat n, 1 <= n) => Num (bv n)) => Num (SomeBV bv) where + (+) = binSomeBVR1 (+) + {-# INLINE (+) #-} + (-) = binSomeBVR1 (-) + {-# INLINE (-) #-} + (*) = binSomeBVR1 (*) + {-# INLINE (*) #-} + negate = unarySomeBVR1 negate + {-# INLINE negate #-} + abs = unarySomeBVR1 abs + {-# INLINE abs #-} + signum = unarySomeBVR1 signum + {-# INLINE signum #-} + fromInteger = + error $ + "fromInteger is not defined for SomeBV as no bitwidth is known, use " + <> "(bv ) instead" + {-# INLINE fromInteger #-} + +instance + (forall n. (KnownNat n, 1 <= n) => Bits (bv n)) => + Bits (SomeBV bv) + where + (.&.) = binSomeBVR1 (.&.) + (.|.) = binSomeBVR1 (.|.) + xor = binSomeBVR1 xor + complement = unarySomeBVR1 complement + shift s i = unarySomeBVR1 (`shift` i) s + rotate s i = unarySomeBVR1 (`rotate` i) s + zeroBits = + error $ + "zeroBits is not defined for SomeBV as no bitwidth is known, use " + <> "(bv 0) or (SomeBV (zeroBits :: bv )) instead" + bit = + error $ + "bit is not defined for SomeBV as no bitwidth is known, use " + <> "(SomeBV (bit :: bv )) instead" + setBit s i = unarySomeBVR1 (`setBit` i) s + clearBit s i = unarySomeBVR1 (`clearBit` i) s + complementBit s i = unarySomeBVR1 (`complementBit` i) s + testBit s i = unarySomeBV (`testBit` i) s + bitSizeMaybe = unarySomeBV bitSizeMaybe + bitSize = fromJust . unarySomeBV bitSizeMaybe + isSigned _ = False + shiftL s i = unarySomeBVR1 (`shiftL` i) s + unsafeShiftL s i = unarySomeBVR1 (`unsafeShiftL` i) s + shiftR s i = unarySomeBVR1 (`shiftR` i) s + unsafeShiftR s i = unarySomeBVR1 (`unsafeShiftR` i) s + rotateL s i = unarySomeBVR1 (`rotateL` i) s + rotateR s i = unarySomeBVR1 (`rotateR` i) s + popCount = unarySomeBV popCount + +instance + (forall n. (KnownNat n, 1 <= n) => FiniteBits (bv n)) => + FiniteBits (SomeBV bv) + where + finiteBitSize = unarySomeBV finiteBitSize + {-# INLINE finiteBitSize #-} + countLeadingZeros = unarySomeBV countLeadingZeros + {-# INLINE countLeadingZeros #-} + countTrailingZeros = unarySomeBV countTrailingZeros + {-# INLINE countTrailingZeros #-} + +instance + (forall n. (KnownNat n, 1 <= n) => Enum (bv n)) => + Enum (SomeBV bv) + where + toEnum = + error $ + "toEnum is not defined for SomeBV, use " + <> "(SomeBV (toEnum :: bv )) instead" + {-# INLINE toEnum #-} + fromEnum = unarySomeBV fromEnum + {-# INLINE fromEnum #-} + +instance + (forall n. (KnownNat n, 1 <= n) => Real (bv n)) => + Real (SomeBV bv) + where + toRational = unarySomeBV toRational + {-# INLINE toRational #-} + +instance + (forall n. (KnownNat n, 1 <= n) => Integral (bv n)) => + Integral (SomeBV bv) + where + toInteger = unarySomeBV toInteger + {-# INLINE toInteger #-} + quot = binSomeBVR1 quot + {-# INLINE quot #-} + rem = binSomeBVR1 rem + {-# INLINE rem #-} + div = binSomeBVR1 div + {-# INLINE div #-} + mod = binSomeBVR1 mod + {-# INLINE mod #-} + quotRem = binSomeBVR2 quotRem + {-# INLINE quotRem #-} + divMod = binSomeBVR2 divMod + {-# INLINE divMod #-} + +instance (SizedBV bv) => BV (SomeBV bv) where + bvConcat (SomeBV (a :: bv l)) (SomeBV (b :: bv r)) = + case ( leqAddPos (Proxy @l) (Proxy @r), + knownAdd @l @r KnownProof KnownProof + ) of + (LeqProof, KnownProof) -> + SomeBV $ sizedBVConcat a b + {-# INLINE bvConcat #-} + bvZext l (SomeBV (a :: bv n)) + | l < n = error "bvZext: trying to zero extend a value to a smaller size" + | otherwise = res (Proxy @n) + where + n = fromIntegral $ natVal (Proxy @n) + res :: forall (l :: Nat). Proxy l -> SomeBV bv + res p = + case ( unsafeKnownProof @l (fromIntegral l), + unsafeLeqProof @1 @l, + unsafeLeqProof @n @l + ) of + (KnownProof, LeqProof, LeqProof) -> SomeBV $ sizedBVZext p a + {-# INLINE bvZext #-} + bvSext l (SomeBV (a :: bv n)) + | l < n = error "bvSext: trying to zero extend a value to a smaller size" + | otherwise = res (Proxy @n) + where + n = fromIntegral $ natVal (Proxy @n) + res :: forall (l :: Nat). Proxy l -> SomeBV bv + res p = + case ( unsafeKnownProof @l (fromIntegral l), + unsafeLeqProof @1 @l, + unsafeLeqProof @n @l + ) of + (KnownProof, LeqProof, LeqProof) -> SomeBV $ sizedBVSext p a + {-# INLINE bvSext #-} + bvExt l (SomeBV (a :: bv n)) + | l < n = error "bvExt: trying to zero extend a value to a smaller size" + | otherwise = res (Proxy @n) + where + n = fromIntegral $ natVal (Proxy @n) + res :: forall (l :: Nat). Proxy l -> SomeBV bv + res p = + case ( unsafeKnownProof @l (fromIntegral l), + unsafeLeqProof @1 @l, + unsafeLeqProof @n @l + ) of + (KnownProof, LeqProof, LeqProof) -> SomeBV $ sizedBVExt p a + {-# INLINE bvExt #-} + bvSelect ix w (SomeBV (a :: bv n)) + | ix + w > n = + error $ + "bvSelect: trying to select a bitvector outside the bounds of the " + <> "input" + | w == 0 = error "bvSelect: trying to select a bitvector of size 0" + | otherwise = res (Proxy @n) (Proxy @n) + where + n = fromIntegral $ natVal (Proxy @n) + res :: forall (w :: Nat) (ix :: Nat). Proxy w -> Proxy ix -> SomeBV bv + res _ _ = + case ( unsafeKnownProof @ix (fromIntegral ix), + unsafeKnownProof @w (fromIntegral w), + unsafeLeqProof @1 @w, + unsafeLeqProof @(ix + w) @n + ) of + (KnownProof, KnownProof, LeqProof, LeqProof) -> + SomeBV $ sizedBVSelect (Proxy @ix) (Proxy @w) a + bv n i = unsafeSomeBV n $ \_ -> sizedBVFromIntegral i + {-# INLINE bv #-} + +instance + (forall n. (KnownNat n, 1 <= n) => EvaluateSym (bv n)) => + EvaluateSym (SomeBV bv) + where + evaluateSym fillDefault model = unarySomeBVR1 (evaluateSym fillDefault model) + {-# INLINE evaluateSym #-} + +instance + (forall n. (KnownNat n, 1 <= n) => ExtractSymbolics (bv n)) => + ExtractSymbolics (SomeBV bv) + where + extractSymbolics = unarySomeBV extractSymbolics + {-# INLINE extractSymbolics #-} + +instance + (forall n. (KnownNat n, 1 <= n) => GPretty (bv n)) => + GPretty (SomeBV bv) + where + gpretty (SomeBV bv) = gpretty bv + {-# INLINE gpretty #-} + +data CompileTimeNat where + CompileTimeNat :: (KnownNat n, 1 <= n) => Proxy n -> CompileTimeNat + +instance Show CompileTimeNat where + show (CompileTimeNat (Proxy :: Proxy n)) = show (natVal (Proxy @n)) + {-# INLINE show #-} + +instance Eq CompileTimeNat where + CompileTimeNat (Proxy :: Proxy n) == CompileTimeNat (Proxy :: Proxy m) = + case sameNat (Proxy @n) (Proxy @m) of + Just Refl -> True + Nothing -> False + {-# INLINE (==) #-} + +instance Ord CompileTimeNat where + compare + (CompileTimeNat (Proxy :: Proxy n)) + (CompileTimeNat (Proxy :: Proxy m)) = + compare (natVal (Proxy @n)) (natVal (Proxy @m)) + {-# INLINE compare #-} + +instance + (forall n. (KnownNat n, 1 <= n) => Mergeable (bv n)) => + Mergeable (SomeBV bv) + where + rootStrategy = + SortedStrategy @CompileTimeNat + (\(SomeBV (_ :: bv n)) -> CompileTimeNat (Proxy @n)) + ( \(CompileTimeNat (_ :: proxy n)) -> + wrapStrategy + (rootStrategy @(bv n)) + SomeBV + (\(SomeBV x) -> unsafeCoerce x) + ) + +instance (forall n. (KnownNat n, 1 <= n) => SEq (bv n)) => SEq (SomeBV bv) where + (.==) = binSomeBV (.==) + {-# INLINE (.==) #-} + (./=) = binSomeBV (./=) + {-# INLINE (./=) #-} + +instance + (forall n. (KnownNat n, 1 <= n) => SOrd (bv n)) => + SOrd (SomeBV bv) + where + (.<) = binSomeBV (.<) + {-# INLINE (.<) #-} + (.<=) = binSomeBV (.<=) + {-# INLINE (.<=) #-} + (.>) = binSomeBV (.>) + {-# INLINE (.>) #-} + (.>=) = binSomeBV (.>=) + {-# INLINE (.>=) #-} + symCompare = binSomeBV symCompare + {-# INLINE symCompare #-} + +instance + (forall n. (KnownNat n, 1 <= n) => SubstituteSym (bv n)) => + SubstituteSym (SomeBV bv) + where + substituteSym c s = unarySomeBVR1 (substituteSym c s) + {-# INLINE substituteSym #-} + +instance + ( KnownNat n, + 1 <= n, + forall m. (KnownNat m, 1 <= m) => GenSym () (bv m), + Mergeable (SomeBV bv) + ) => + GenSym (Proxy n) (SomeBV bv) + where + fresh _ = + (\(i :: UnionM (bv n)) -> mrgFmap SomeBV i) <$> fresh () + {-# INLINE fresh #-} + +instance + ( KnownNat n, + 1 <= n, + forall m. (KnownNat m, 1 <= m) => GenSymSimple () (bv m), + Mergeable (SomeBV bv) + ) => + GenSymSimple (Proxy n) (SomeBV bv) + where + simpleFresh _ = (\(i :: bv n) -> SomeBV i) <$> simpleFresh () + {-# INLINE simpleFresh #-} + +instance + ( forall m. (KnownNat m, 1 <= m) => GenSym () (bv m), + Mergeable (SomeBV bv) + ) => + GenSym (SomeBV bv) (SomeBV bv) + where + fresh (SomeBV (_ :: bv x)) = fresh (Proxy @x) + {-# INLINE fresh #-} + +instance + ( forall m. (KnownNat m, 1 <= m) => GenSymSimple () (bv m), + Mergeable (SomeBV bv) + ) => + GenSymSimple (SomeBV bv) (SomeBV bv) + where + simpleFresh (SomeBV (_ :: bv x)) = simpleFresh (Proxy @x) + {-# INLINE simpleFresh #-} + +instance + ( forall n. (KnownNat n, 1 <= n) => GenSym () (bv n), + Mergeable (SomeBV bv) + ) => + GenSym Int (SomeBV bv) + where + fresh n + | n <= 0 = error "fresh: cannot generate a bitvector of non-positive size" + | otherwise = case mkPositiveNatRepr (fromIntegral n) of + SomePositiveNatRepr (_ :: NatRepr x) -> fresh (Proxy @x) + {-# INLINE fresh #-} + +instance + ( forall n. (KnownNat n, 1 <= n) => GenSymSimple () (bv n), + Mergeable (SomeBV bv) + ) => + GenSymSimple Int (SomeBV bv) + where + simpleFresh n + | n <= 0 = error "fresh: cannot generate a bitvector of non-positive size" + | otherwise = case mkPositiveNatRepr (fromIntegral n) of + SomePositiveNatRepr (_ :: NatRepr x) -> simpleFresh (Proxy @x) + {-# INLINE simpleFresh #-} + +instance + ( forall n. (KnownNat n, 1 <= n) => SignConversion (ubv n) (sbv n), + -- Add this to help the type checker resolve the functional dependency + SignConversion (ubv 1) (sbv 1) + ) => + SignConversion (SomeBV ubv) (SomeBV sbv) + where + toSigned (SomeBV (n :: ubv n)) = SomeBV (toSigned n :: sbv n) + {-# INLINE toSigned #-} + toUnsigned (SomeBV (n :: sbv n)) = SomeBV (toUnsigned n :: ubv n) + {-# INLINE toUnsigned #-} + +instance + (forall n. (KnownNat n, 1 <= n) => ToCon (sbv n) (cbv n)) => + ToCon (SomeBV sbv) (SomeBV cbv) + where + toCon (SomeBV (n :: sbv n)) = SomeBV <$> (toCon n :: Maybe (cbv n)) + {-# INLINE toCon #-} + +instance + (forall n. (KnownNat n, 1 <= n) => ToSym (cbv n) (sbv n)) => + ToSym (SomeBV cbv) (SomeBV sbv) + where + toSym (SomeBV (n :: cbv n)) = SomeBV (toSym n :: sbv n) + {-# INLINE toSym #-} + +instance + ( forall n. + (KnownNat n, 1 <= n) => + SafeDivision e (bv n) (ExceptT e m), + MonadError (Either BitwidthMismatch e) m, + TryMerge m, + Mergeable e + ) => + SafeDivision (Either BitwidthMismatch e) (SomeBV bv) m + where + safeDiv = binSomeBVSafeR1 (safeDiv @e) + {-# INLINE safeDiv #-} + safeMod = binSomeBVSafeR1 (safeMod @e) + {-# INLINE safeMod #-} + safeQuot = binSomeBVSafeR1 (safeQuot @e) + {-# INLINE safeQuot #-} + safeRem = binSomeBVSafeR1 (safeRem @e) + {-# INLINE safeRem #-} + safeDivMod = binSomeBVSafeR2 (safeDivMod @e) + {-# INLINE safeDivMod #-} + safeQuotRem = binSomeBVSafeR2 (safeQuotRem @e) + {-# INLINE safeQuotRem #-} + +instance + ( forall n. + (KnownNat n, 1 <= n) => + SafeLinearArith e (bv n) (ExceptT e m), + MonadError (Either BitwidthMismatch e) m, + TryMerge m, + Mergeable e + ) => + SafeLinearArith (Either BitwidthMismatch e) (SomeBV bv) m + where + safeAdd = binSomeBVSafeR1 (safeAdd @e) + {-# INLINE safeAdd #-} + safeSub = binSomeBVSafeR1 (safeSub @e) + {-# INLINE safeSub #-} + safeNeg = unarySomeBV (mrgFmap SomeBV . mrgModifyError Right . safeNeg @e) + {-# INLINE safeNeg #-} + +instance + (forall n. (KnownNat n, 1 <= n) => SymShift (bv n)) => + SymShift (SomeBV bv) + where + symShift = binSomeBVR1 symShift + {-# INLINE symShift #-} + symShiftNegated = binSomeBVR1 symShiftNegated + {-# INLINE symShiftNegated #-} + +instance + (forall n. (KnownNat n, 1 <= n) => SymRotate (bv n)) => + SymRotate (SomeBV bv) + where + symRotate = binSomeBVR1 symRotate + {-# INLINE symRotate #-} + symRotateNegated = binSomeBVR1 symRotateNegated + {-# INLINE symRotateNegated #-} + +instance + ( forall n. + (KnownNat n, 1 <= n) => + SafeSymShift e (bv n) (ExceptT e m), + MonadError (Either BitwidthMismatch e) m, + TryMerge m, + Mergeable e + ) => + SafeSymShift (Either BitwidthMismatch e) (SomeBV bv) m + where + safeSymShiftL = binSomeBVSafeR1 (safeSymShiftL @e) + {-# INLINE safeSymShiftL #-} + safeSymShiftR = binSomeBVSafeR1 (safeSymShiftR @e) + {-# INLINE safeSymShiftR #-} + safeSymStrictShiftL = binSomeBVSafeR1 (safeSymStrictShiftL @e) + {-# INLINE safeSymStrictShiftL #-} + safeSymStrictShiftR = binSomeBVSafeR1 (safeSymStrictShiftR @e) + {-# INLINE safeSymStrictShiftR #-} + +instance + ( forall n. + (KnownNat n, 1 <= n) => + SafeSymRotate e (bv n) (ExceptT e m), + MonadError (Either BitwidthMismatch e) m, + TryMerge m, + Mergeable e + ) => + SafeSymRotate (Either BitwidthMismatch e) (SomeBV bv) m + where + safeSymRotateL = binSomeBVSafeR1 (safeSymRotateL @e) + {-# INLINE safeSymRotateL #-} + safeSymRotateR = binSomeBVSafeR1 (safeSymRotateR @e) + {-# INLINE safeSymRotateR #-} + +instance + (forall n. (KnownNat n, 1 <= n) => ITEOp (bv n)) => + ITEOp (SomeBV bv) + where + symIte cond = binSomeBVR1 (symIte cond) + +instance + (forall n. (KnownNat n, 1 <= n) => AllSyms (bv n)) => + AllSyms (SomeBV bv) + where + allSyms = unarySomeBV allSyms + {-# INLINE allSyms #-} + allSymsS = unarySomeBV allSymsS + {-# INLINE allSymsS #-} + +-- Synonyms + +-- | Type synonym for 'SomeBV' with concrete signed bitvectors. +type SomeIntN = SomeBV IntN + +-- | Pattern synonym for 'SomeBV' with concrete signed bitvectors. +pattern SomeIntN :: () => (KnownNat n, 1 <= n) => IntN n -> SomeIntN +pattern SomeIntN a = SomeBV a + +-- | Type synonym for 'SomeBV' with concrete unsigned bitvectors. +type SomeWordN = SomeBV WordN + +-- | Pattern synonym for 'SomeBV' with concrete unsigned bitvectors. +pattern SomeWordN :: () => (KnownNat n, 1 <= n) => WordN n -> SomeWordN +pattern SomeWordN a = SomeBV a + +-- | Type synonym for 'SomeBV' with symbolic signed bitvectors. +type SomeSymIntN = SomeBV SymIntN + +-- | Pattern synonym for 'SomeBV' with symbolic signed bitvectors. +pattern SomeSymIntN :: () => (KnownNat n, 1 <= n) => SymIntN n -> SomeSymIntN +pattern SomeSymIntN a = SomeBV a + +-- | Type synonym for 'SomeBV' with symbolic unsigned bitvectors. +type SomeSymWordN = SomeBV SymWordN + +-- | Pattern synonym for 'SomeBV' with symbolic unsigned bitvectors. +pattern SomeSymWordN :: () => (KnownNat n, 1 <= n) => SymWordN n -> SomeSymWordN +pattern SomeSymWordN a = SomeBV a + +-- Construction + +-- | Construct a 'SomeBV' with a given run-time bitwidth and a polymorphic +-- value for the underlying bitvector. +unsafeSomeBV :: + forall bv. + Int -> + (forall proxy n. (KnownNat n, 1 <= n) => proxy n -> bv n) -> + SomeBV bv +unsafeSomeBV n i + | n <= 0 = error "unsafeBV: trying to create a bitvector of non-positive size" + | otherwise = case mkPositiveNatRepr (fromIntegral n) of + SomePositiveNatRepr (_ :: NatRepr x) -> SomeBV (i (Proxy @x)) + +-- | Construct a symbolic 'SomeBV' with a given concrete 'SomeBV'. Similar to +-- 'con' but for 'SomeBV'. +-- +-- >>> a = bv 8 0x12 :: SomeIntN +-- >>> conBV a :: SomeSymIntN +-- 0x12 +conBV :: + forall cbv bv. + ( forall n. (KnownNat n, 1 <= n) => Solvable (cbv n) (bv n), + Solvable (cbv 1) (bv 1) + ) => + SomeBV cbv -> + SomeBV bv +conBV (SomeBV (v :: cbv n)) = SomeBV $ con @(cbv n) @(bv n) v + +-- | View pattern for symbolic 'SomeBV' to see if it contains a concrete value +-- and extract it. Similar to 'conView' but for 'SomeBV'. +-- +-- >>> conBVView (bv 8 0x12 :: SomeSymIntN) +-- Just 0x12 +-- >>> conBVView (ssymBV 4 "a" :: SomeSymIntN) +-- Nothing +conBVView :: + forall cbv bv. + ( forall n. (KnownNat n, 1 <= n) => Solvable (cbv n) (bv n), + Solvable (cbv 1) (bv 1) + ) => + SomeBV bv -> + Maybe (SomeBV cbv) +conBVView (SomeBV (bv :: bv n)) = case conView @(cbv n) bv of + Just c -> Just $ SomeBV c + Nothing -> Nothing + +-- | Pattern synonym for symbolic 'SomeBV' to see if it contains a concrete +-- value and extract it. Similar to 'Con' but for 'SomeBV'. +-- +-- >>> case (bv 8 0x12 :: SomeSymIntN) of { ConBV c -> c; _ -> error "impossible" } +-- 0x12 +pattern ConBV :: + forall cbv bv. + ( forall n. (KnownNat n, 1 <= n) => Solvable (cbv n) (bv n), + Solvable (cbv 1) (bv 1) + ) => + SomeBV cbv -> + SomeBV bv +pattern ConBV c <- (conBVView -> Just c) + where + ConBV c = conBV c + +-- | Construct a symbolic 'SomeBV' with a given run-time bitwidth and a symbol. +-- Similar to 'sym' but for 'SomeBV'. +-- +-- >>> symBV 8 "a" :: SomeSymIntN +-- a +symBV :: + forall cbv bv. + ( forall n. (KnownNat n, 1 <= n) => Solvable (cbv n) (bv n), + Solvable (cbv 1) (bv 1) + ) => + Int -> + Symbol -> + SomeBV bv +symBV n s = unsafeSomeBV n $ \(_ :: proxy n) -> sym @(cbv n) s + +-- | Construct a symbolic 'SomeBV' with a given run-time bitwidth and an +-- identifier. Similar to 'ssym' but for 'SomeBV'. +-- +-- >>> ssymBV 8 "a" :: SomeSymIntN +-- a +ssymBV :: + forall cbv bv. + ( forall n. (KnownNat n, 1 <= n) => Solvable (cbv n) (bv n), + Solvable (cbv 1) (bv 1) + ) => + Int -> + Identifier -> + SomeBV bv +ssymBV n s = unsafeSomeBV n $ \(_ :: proxy n) -> ssym @(cbv n) s + +-- | Construct a symbolic 'SomeBV' with a given run-time bitwidth, an identifier +-- and an index. Similar to 'isym' but for 'SomeBV'. +-- +-- >>> isymBV 8 "a" 1 :: SomeSymIntN +-- a@1 +isymBV :: + forall cbv bv. + ( forall n. (KnownNat n, 1 <= n) => Solvable (cbv n) (bv n), + Solvable (cbv 1) (bv 1) + ) => + Int -> + Identifier -> + Int -> + SomeBV bv +isymBV n s i = unsafeSomeBV n $ \(_ :: proxy n) -> isym @(cbv n) s i + +-- | Generate an arbitrary 'SomeBV' with a given run-time bitwidth. +arbitraryBV :: + forall bv. + (forall n. (KnownNat n, 1 <= n) => Arbitrary (bv n)) => + Int -> + Gen (SomeBV bv) +arbitraryBV n + | n <= 0 = + error "arbitraryBV: trying to create a bitvector of non-positive size" + | otherwise = case mkPositiveNatRepr (fromIntegral n) of + SomePositiveNatRepr (_ :: NatRepr x) -> do + v <- arbitrary :: Gen (bv x) + return $ SomeBV v + +-- Helpers + +-- | Lift a unary operation on sized bitvectors that returns anything to +-- 'SomeBV'. +unarySomeBV :: forall bv r. (forall n. (KnownNat n, 1 <= n) => bv n -> r) -> SomeBV bv -> r +unarySomeBV f (SomeBV bv) = f bv +{-# INLINE unarySomeBV #-} + +-- | Lift a unary operation on sized bitvectors that returns a bitvector to +-- 'SomeBV'. The result will also be wrapped with 'SomeBV'. +unarySomeBVR1 :: + (forall n. (KnownNat n, 1 <= n) => bv n -> bv n) -> SomeBV bv -> SomeBV bv +unarySomeBVR1 f = unarySomeBV (SomeBV . f) +{-# INLINE unarySomeBVR1 #-} + +-- | Lift a binary operation on sized bitvectors that returns anything to +-- 'SomeBV'. Crash if the bitwidths do not match. +binSomeBV :: + (forall n. (KnownNat n, 1 <= n) => bv n -> bv n -> r) -> + SomeBV bv -> + SomeBV bv -> + r +binSomeBV f (SomeBV (l :: bv l)) (SomeBV (r :: bv r)) = + case sameNat (Proxy @l) (Proxy @r) of + Just Refl -> f l r + Nothing -> throw BitwidthMismatch +{-# INLINE binSomeBV #-} + +-- | Lift a binary operation on sized bitvectors that returns a bitvector to +-- 'SomeBV'. The result will also be wrapped with 'SomeBV'. Crash if the +-- bitwidths do not match. +binSomeBVR1 :: + (forall n. (KnownNat n, 1 <= n) => bv n -> bv n -> bv n) -> + SomeBV bv -> + SomeBV bv -> + SomeBV bv +binSomeBVR1 f = binSomeBV (\a b -> SomeBV $ f a b) +{-# INLINE binSomeBVR1 #-} + +-- | Lift a binary operation on sized bitvectors that returns two bitvectors to +-- 'SomeBV'. The results will also be wrapped with 'SomeBV'. Crash if the +-- bitwidths do not match. +binSomeBVR2 :: + (forall n. (KnownNat n, 1 <= n) => bv n -> bv n -> (bv n, bv n)) -> + SomeBV bv -> + SomeBV bv -> + (SomeBV bv, SomeBV bv) +binSomeBVR2 f = binSomeBV (\a b -> let (x, y) = f a b in (SomeBV x, SomeBV y)) +{-# INLINE binSomeBVR2 #-} + +-- | Lift a binary operation on sized bitvectors that returns anything wrapped +-- with 'ExceptT' to 'SomeBV'. If the bitwidths do not match, throw an +-- `BitwidthMismatch` error to the monadic context. +binSomeBVSafe :: + ( MonadError (Either BitwidthMismatch e) m, + TryMerge m, + Mergeable e, + Mergeable r + ) => + (forall n. (KnownNat n, 1 <= n) => bv n -> bv n -> ExceptT e m r) -> + SomeBV bv -> + SomeBV bv -> + m r +binSomeBVSafe f (SomeBV (l :: bv l)) (SomeBV (r :: bv r)) = + case sameNat (Proxy @l) (Proxy @r) of + Just Refl -> mrgModifyError Right $ f l r + Nothing -> mrgThrowError $ Left BitwidthMismatch +{-# INLINE binSomeBVSafe #-} + +-- | Lift a binary operation on sized bitvectors that returns a bitvector +-- wrapped with 'ExceptT' to 'SomeBV'. The result will also be wrapped with +-- 'SomeBV'. +-- +-- If the bitwidths do not match, throw an `BitwidthMismatch` error to the +-- monadic context. +binSomeBVSafeR1 :: + ( MonadError (Either BitwidthMismatch e) m, + TryMerge m, + Mergeable e, + forall n. (KnownNat n, 1 <= n) => Mergeable (bv n) + ) => + (forall n. (KnownNat n, 1 <= n) => bv n -> bv n -> ExceptT e m (bv n)) -> + SomeBV bv -> + SomeBV bv -> + m (SomeBV bv) +binSomeBVSafeR1 f = binSomeBVSafe (\l r -> mrgFmap SomeBV $ f l r) +{-# INLINE binSomeBVSafeR1 #-} + +-- | Lift a binary operation on sized bitvectors that returns two bitvectors +-- wrapped with 'ExceptT' to 'SomeBV'. The results will also be wrapped with +-- 'SomeBV'. +-- +-- If the bitwidths do not match, throw an `BitwidthMismatch` error to the +-- monadic context. +binSomeBVSafeR2 :: + ( MonadError (Either BitwidthMismatch e) m, + TryMerge m, + Mergeable e, + forall n. (KnownNat n, 1 <= n) => Mergeable (bv n) + ) => + ( forall n. + (KnownNat n, 1 <= n) => + bv n -> + bv n -> + ExceptT e m (bv n, bv n) + ) -> + SomeBV bv -> + SomeBV bv -> + m (SomeBV bv, SomeBV bv) +binSomeBVSafeR2 f = + binSomeBVSafe (\l r -> mrgFmap (bimap SomeBV SomeBV) $ f l r) +{-# INLINE binSomeBVSafeR2 #-} diff --git a/src/Grisette/Internal/SymPrim/SymBV.hs b/src/Grisette/Internal/SymPrim/SymBV.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/SymPrim/SymBV.hs @@ -0,0 +1,541 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.SymPrim.SymBV +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.SymPrim.SymBV + ( SymWordN (..), + SymIntN (..), + ) +where + +import Control.DeepSeq (NFData) +import Data.Bits + ( Bits + ( bit, + bitSize, + bitSizeMaybe, + complement, + isSigned, + popCount, + rotate, + shift, + testBit, + xor, + (.&.), + (.|.) + ), + FiniteBits (finiteBitSize), + ) +import Data.Hashable (Hashable (hashWithSalt)) +import Data.Proxy (Proxy (Proxy)) +import Data.String (IsString (fromString)) +import GHC.Generics (Generic) +import GHC.TypeNats + ( KnownNat, + Nat, + natVal, + type (+), + type (<=), + ) +import Grisette.Internal.Core.Data.Class.BitVector + ( SizedBV + ( sizedBVConcat, + sizedBVExt, + sizedBVSelect, + sizedBVSext, + sizedBVZext + ), + ) +import Grisette.Internal.Core.Data.Class.Function + ( Apply (FunType, apply), + ) +import Grisette.Internal.Core.Data.Class.SignConversion + ( SignConversion (toSigned, toUnsigned), + ) +import Grisette.Internal.Core.Data.Class.Solvable + ( Solvable (con, conView, ssym, sym), + pattern Con, + ) +import Grisette.Internal.Core.Data.Class.SymRotate + ( SymRotate (symRotate, symRotateNegated), + ) +import Grisette.Internal.Core.Data.Class.SymShift (SymShift (symShift, symShiftNegated)) +import Grisette.Internal.SymPrim.AllSyms (AllSyms (allSymsS), SomeSym (SomeSym)) +import Grisette.Internal.SymPrim.BV + ( IntN, + WordN, + ) +import Grisette.Internal.SymPrim.Prim.Term + ( ConRep (ConType), + LinkedRep (underlyingTerm, wrapTerm), + PEvalBVSignConversionTerm (pevalBVToSignedTerm, pevalBVToUnsignedTerm), + PEvalBVTerm (pevalBVConcatTerm, pevalBVExtendTerm, pevalBVSelectTerm), + PEvalBitwiseTerm + ( pevalAndBitsTerm, + pevalComplementBitsTerm, + pevalOrBitsTerm, + pevalXorBitsTerm + ), + PEvalNumTerm + ( pevalAbsNumTerm, + pevalAddNumTerm, + pevalMulNumTerm, + pevalNegNumTerm, + pevalSignumNumTerm + ), + PEvalOrdTerm (pevalLeOrdTerm), + PEvalRotateTerm + ( pevalRotateLeftTerm, + pevalRotateRightTerm + ), + PEvalShiftTerm (pevalShiftLeftTerm, pevalShiftRightTerm), + SupportedPrim (pevalITETerm), + SymRep (SymType), + Term (ConTerm), + conTerm, + pevalEqTerm, + pevalGeOrdTerm, + pevalModIntegralTerm, + pevalOrTerm, + pevalSubNumTerm, + pformat, + symTerm, + ) +import Grisette.Internal.Utils.Parameterized + ( KnownProof (KnownProof), + LeqProof (LeqProof), + knownAdd, + leqAddPos, + leqTrans, + ) +import Language.Haskell.TH.Syntax (Lift) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim +-- >>> import Grisette.Backend +-- >>> import Data.Proxy + +-- | Symbolic signed bit vector type. Indexed with the bit width. +-- Signedness affects the semantics of the operations, including +-- comparison/extension, etc. +-- +-- >>> :set -XOverloadedStrings -XDataKinds -XBinaryLiterals +-- >>> "a" + 5 :: SymIntN 5 +-- (+ 0b00101 a) +-- >>> sizedBVConcat (con 0b101 :: SymIntN 3) (con 0b110 :: SymIntN 3) +-- 0b101110 +-- >>> sizedBVExt (Proxy @6) (con 0b101 :: SymIntN 3) +-- 0b111101 +-- >>> (8 :: SymIntN 4) .< (7 :: SymIntN 4) +-- true +-- +-- More symbolic operations are available. Please refer to the documentation +-- for the type class instances. +newtype SymIntN (n :: Nat) = SymIntN {underlyingIntNTerm :: Term (IntN n)} + deriving (Lift, NFData, Generic) + +-- | Symbolic unsigned bit vector type. Indexed with the bit width. +-- Signedness affects the semantics of the operations, including +-- comparison/extension, etc. +-- +-- >>> :set -XOverloadedStrings -XDataKinds -XBinaryLiterals +-- >>> "a" + 5 :: SymWordN 5 +-- (+ 0b00101 a) +-- >>> sizedBVConcat (con 0b101 :: SymWordN 3) (con 0b110 :: SymWordN 3) +-- 0b101110 +-- >>> sizedBVExt (Proxy @6) (con 0b101 :: SymWordN 3) +-- 0b000101 +-- >>> (8 :: SymWordN 4) .< (7 :: SymWordN 4) +-- false +-- +-- More symbolic operations are available. Please refer to the documentation +-- for the type class instances. +newtype SymWordN (n :: Nat) = SymWordN {underlyingWordNTerm :: Term (WordN n)} + deriving (Lift, NFData, Generic) + +instance (KnownNat n, 1 <= n) => ConRep (SymIntN n) where + type ConType (SymIntN n) = IntN n + +instance (KnownNat n, 1 <= n) => SymRep (IntN n) where + type SymType (IntN n) = SymIntN n + +instance (KnownNat n, 1 <= n) => LinkedRep (IntN n) (SymIntN n) where + underlyingTerm (SymIntN a) = a + wrapTerm = SymIntN + +instance (KnownNat n, 1 <= n) => ConRep (SymWordN n) where + type ConType (SymWordN n) = WordN n + +instance (KnownNat n, 1 <= n) => SymRep (WordN n) where + type SymType (WordN n) = SymWordN n + +instance (KnownNat n, 1 <= n) => LinkedRep (WordN n) (SymWordN n) where + underlyingTerm (SymWordN a) = a + wrapTerm = SymWordN + +-- Aggregate instances + +instance (KnownNat n, 1 <= n) => Apply (SymIntN n) where + type FunType (SymIntN n) = SymIntN n + apply = id + +instance (KnownNat n, 1 <= n) => Apply (SymWordN n) where + type FunType (SymWordN n) = SymWordN n + apply = id + +#define SOLVABLE_BV(contype, symtype) \ +instance (KnownNat n, 1 <= n) => Solvable (contype n) (symtype n) where \ + con = symtype . conTerm; \ + sym = symtype . symTerm; \ + conView (symtype (ConTerm _ t)) = Just t; \ + conView _ = Nothing + +#if 1 +SOLVABLE_BV(IntN, SymIntN) +SOLVABLE_BV(WordN, SymWordN) +#endif + +-- Num + +#define NUM_BV(symtype) \ +instance (KnownNat n, 1 <= n) => Num (symtype n) where \ + (symtype l) + (symtype r) = symtype $ pevalAddNumTerm l r; \ + (symtype l) - (symtype r) = symtype $ pevalSubNumTerm l r; \ + (symtype l) * (symtype r) = symtype $ pevalMulNumTerm l r; \ + negate (symtype v) = symtype $ pevalNegNumTerm v; \ + abs (symtype v) = symtype $ pevalAbsNumTerm v; \ + signum (symtype v) = symtype $ pevalSignumNumTerm v; \ + fromInteger i = con $ fromInteger i + +#if 1 +NUM_BV(SymIntN) +NUM_BV(SymWordN) +#endif + +-- Bits + +#define BITS_BV(symtype, signed) \ +instance (KnownNat n, 1 <= n) => Bits (symtype n) where \ + symtype l .&. symtype r = symtype $ pevalAndBitsTerm l r; \ + {-# INLINE (.&.) #-}; \ + symtype l .|. symtype r = symtype $ pevalOrBitsTerm l r; \ + {-# INLINE (.|.) #-}; \ + symtype l `xor` symtype r = symtype $ pevalXorBitsTerm l r; \ + {-# INLINE xor #-}; \ + complement (symtype n) = symtype $ pevalComplementBitsTerm n; \ + {-# INLINE complement #-}; \ + shift (symtype n) i | i > 0 = symtype $ pevalShiftLeftTerm n (conTerm $ fromIntegral i); \ + shift (symtype n) i | i < 0 = symtype $ pevalShiftRightTerm n (conTerm $ fromIntegral (-i)); \ + shift (symtype n) _ = symtype n; \ + {-# INLINE shift #-}; \ + rotate (symtype n) i | i > 0 = symtype $ pevalRotateLeftTerm n (conTerm $ fromIntegral i); \ + rotate (symtype n) i | i < 0 = symtype $ pevalRotateRightTerm n (conTerm $ fromIntegral (-i)); \ + rotate (symtype n) _ = symtype n; \ + {-# INLINE rotate #-}; \ + bitSize = finiteBitSize; \ + {-# INLINE bitSize #-}; \ + bitSizeMaybe = Just . finiteBitSize; \ + {-# INLINE bitSizeMaybe #-}; \ + isSigned _ = signed; \ + {-# INLINE isSigned #-}; \ + testBit (Con n) = testBit n; \ + testBit _ = error "You cannot call testBit on symbolic variables"; \ + {-# INLINE testBit #-}; \ + bit = con . bit; \ + {-# INLINE bit #-}; \ + popCount (Con n) = popCount n; \ + popCount _ = error "You cannot call popCount on symbolic variables"; \ + {-# INLINE popCount #-} + +#if 1 +BITS_BV(SymIntN, True) +BITS_BV(SymWordN, False) +#endif + +-- FiniteBits + +#define FINITE_BITS_BV(symtype) \ +instance (KnownNat n, 1 <= n) => FiniteBits (symtype n) where \ + finiteBitSize _ = fromIntegral $ natVal (Proxy @n); \ + {-# INLINE finiteBitSize #-}; \ + +#if 1 +FINITE_BITS_BV(SymIntN) +FINITE_BITS_BV(SymWordN) +#endif + +-- Show + +#define SHOW_BV(symtype) \ +instance (KnownNat n, 1 <= n) => Show (symtype n) where \ + show (symtype t) = pformat t + +#if 1 +SHOW_BV(SymIntN) +SHOW_BV(SymWordN) +#endif + +-- Hashable + +#define HASHABLE_BV(symtype) \ +instance (KnownNat n, 1 <= n) => Hashable (symtype n) where \ + hashWithSalt s (symtype v) = s `hashWithSalt` v + +#if 1 +HASHABLE_BV(SymIntN) +HASHABLE_BV(SymWordN) +#endif + +-- Eq + +#define EQ_BV(symtype) \ +instance (KnownNat n, 1 <= n) => Eq (symtype n) where \ + (symtype l) == (symtype r) = l == r + +#if 1 +EQ_BV(SymIntN) +EQ_BV(SymWordN) +#endif + +-- IsString + +#define IS_STRING_BV(symtype) \ +instance (KnownNat n, 1 <= n) => IsString (symtype n) where \ + fromString = ssym . fromString + +#if 1 +IS_STRING_BV(SymIntN) +IS_STRING_BV(SymWordN) +#endif + +-- SizedBV + +#define BVCONCAT_SIZED(symtype) \ +sizedBVConcat :: forall l r. (KnownNat l, KnownNat r, 1 <= l, 1 <= r) => symtype l -> symtype r -> symtype (l + r); \ +sizedBVConcat (symtype l) (symtype r) = \ + case (leqAddPos pl pr, knownAdd (KnownProof @l) (KnownProof @r)) of \ + (LeqProof, KnownProof) -> \ + symtype (pevalBVConcatTerm l r); \ + where; \ + pl = Proxy :: Proxy l; \ + pr = Proxy :: Proxy r + +#define BVZEXT_SIZED(symtype) \ +sizedBVZext :: forall l r proxy. (KnownNat l, KnownNat r, 1 <= l, KnownNat r, l <= r) => proxy r -> symtype l -> symtype r; \ +sizedBVZext _ (symtype v) = \ + case leqTrans (LeqProof @1 @l) (LeqProof @l @r) of \ + LeqProof -> symtype $ pevalBVExtendTerm False (Proxy @r) v + +#define BVSEXT_SIZED(symtype) \ +sizedBVSext :: forall l r proxy. (KnownNat l, KnownNat r, 1 <= l, KnownNat r, l <= r) => proxy r -> symtype l -> symtype r; \ +sizedBVSext _ (symtype v) = \ + case leqTrans (LeqProof @1 @l) (LeqProof @l @r) of \ + LeqProof -> symtype $ pevalBVExtendTerm True (Proxy @r) v + +#define BVSELECT_SIZED(symtype) \ +sizedBVSelect :: forall n ix w p q. (KnownNat n, KnownNat ix, KnownNat w, 1 <= n, 1 <= w, ix + w <= n) => \ + p ix -> q w -> symtype n -> symtype w; \ +sizedBVSelect pix pw (symtype v) = symtype $ pevalBVSelectTerm pix pw v + +#if 1 +instance SizedBV SymIntN where + BVCONCAT_SIZED(SymIntN) + BVZEXT_SIZED(SymIntN) + BVSEXT_SIZED(SymIntN) + sizedBVExt = sizedBVSext + BVSELECT_SIZED(SymIntN) + +instance SizedBV SymWordN where + BVCONCAT_SIZED(SymWordN) + BVZEXT_SIZED(SymWordN) + BVSEXT_SIZED(SymWordN) + sizedBVExt = sizedBVZext + BVSELECT_SIZED(SymWordN) +#endif + +-- BV + +#define BVCONCAT(somety, origty) \ +bvConcat (somety (a :: origty l)) (somety (b :: origty r)) = \ + case (leqAddPos (Proxy @l) (Proxy @r), knownAdd @l @r KnownProof KnownProof) of \ + (LeqProof, KnownProof) -> \ + somety $ sizedBVConcat a b + +#define BVZEXT(somety, origty) \ +bvZext l (somety (a :: origty n)) \ + | l < n = error "bvZext: trying to zero extend a value to a smaller size" \ + | otherwise = res (Proxy @n) \ + where \ + n = fromIntegral $ natVal (Proxy @n); \ + res :: forall (l :: Nat). Proxy l -> somety; \ + res p = \ + case (unsafeKnownProof @l (fromIntegral l), unsafeLeqProof @1 @l, unsafeLeqProof @n @l) of \ + (KnownProof, LeqProof, LeqProof) -> somety $ sizedBVZext p a + +#define BVSEXT(somety, origty) \ +bvSext l (somety (a :: origty n)) \ + | l < n = error "bvZext: trying to zero extend a value to a smaller size" \ + | otherwise = res (Proxy @n) \ + where \ + n = fromIntegral $ natVal (Proxy @n); \ + res :: forall (l :: Nat). Proxy l -> somety; \ + res p = \ + case (unsafeKnownProof @l (fromIntegral l), unsafeLeqProof @1 @l, unsafeLeqProof @n @l) of \ + (KnownProof, LeqProof, LeqProof) -> somety $ sizedBVSext p a + +#define BVSELECT(somety, origty) \ +bvSelect ix w (somety (a :: origty n)) \ + | ix + w > n = error "bvSelect: trying to select a bitvector outside the bounds of the input" \ + | w == 0 = error "bvSelect: trying to select a bitvector of size 0" \ + | otherwise = res (Proxy @n) (Proxy @n) \ + where \ + n = fromIntegral $ natVal (Proxy @n); \ + res :: forall (w :: Nat) (ix :: Nat). Proxy w -> Proxy ix -> somety; \ + res _ _ = \ + case ( unsafeKnownProof @ix (fromIntegral ix), \ + unsafeKnownProof @w (fromIntegral w), \ + unsafeLeqProof @1 @w, \ + unsafeLeqProof @(ix + w) @n \ + ) of \ + (KnownProof, KnownProof, LeqProof, LeqProof) -> \ + somety $ sizedBVSelect (Proxy @ix) (Proxy @w) a + +#define BVBV(somety, origty) \ + bv n i = case mkNatRepr n of \ + Some (natRepr :: NatRepr x) -> \ + case unsafeLeqProof @1 @x of \ + LeqProof -> withKnownNat natRepr $ \ + somety (fromIntegral i :: origty x) + +-- BVSignConversion + +instance (KnownNat n, 1 <= n) => SignConversion (SymWordN n) (SymIntN n) where + toSigned (SymWordN n) = SymIntN $ pevalBVToSignedTerm n + toUnsigned (SymIntN n) = SymWordN $ pevalBVToUnsignedTerm n + +-- SymShift +instance (KnownNat n, 1 <= n) => SymShift (SymWordN n) where + symShift (SymWordN a) (SymWordN s) = SymWordN $ pevalShiftLeftTerm a s + symShiftNegated (SymWordN a) (SymWordN s) = SymWordN $ pevalShiftRightTerm a s + +instance (KnownNat n, 1 <= n) => SymShift (SymIntN n) where + symShift a _ | finiteBitSize a == 1 = a + symShift as@(SymIntN a) (SymIntN s) + | finiteBitSize as == 2 = + SymIntN $ + pevalITETerm + (pevalGeOrdTerm s (conTerm 0)) + (pevalShiftLeftTerm a s) + ( pevalITETerm + (pevalEqTerm s (conTerm (-2))) + ( pevalITETerm + (pevalGeOrdTerm a (conTerm 0)) + (conTerm 0) + (conTerm (-1)) + ) + (pevalShiftRightTerm a (pevalNegNumTerm s)) + ) + symShift (SymIntN a) (SymIntN s) = + SymIntN $ + pevalITETerm + (pevalGeOrdTerm s (conTerm 0)) + (pevalShiftLeftTerm a s) + ( pevalITETerm + (pevalLeOrdTerm s (conTerm (-bs))) + (pevalShiftRightTerm a (conTerm bs)) + (pevalShiftRightTerm a (pevalNegNumTerm s)) + ) + where + bs = fromIntegral (finiteBitSize (0 :: IntN n)) :: IntN n + symShiftNegated (SymIntN a) (SymIntN s) = + SymIntN $ + pevalITETerm + (pevalGeOrdTerm s (conTerm 0)) + (pevalShiftRightTerm a s) + ( pevalITETerm + (pevalLeOrdTerm s (conTerm (-bs))) + (conTerm 0) + (pevalShiftLeftTerm a (pevalNegNumTerm s)) + ) + where + bs = fromIntegral (finiteBitSize (0 :: IntN n)) :: IntN n + +-- SymRotate +instance (KnownNat n, 1 <= n) => SymRotate (SymWordN n) where + symRotate (SymWordN a) (SymWordN s) = SymWordN (pevalRotateLeftTerm a s) + symRotateNegated (SymWordN a) (SymWordN s) = + SymWordN (pevalRotateRightTerm a s) + +instance (KnownNat n, 1 <= n) => SymRotate (SymIntN n) where + symRotate as@(SymIntN a) (SymIntN s) + | finiteBitSize as == 1 = as + | finiteBitSize as == 2 = + SymIntN $ + pevalITETerm + ( pevalOrTerm + (pevalEqTerm s (conTerm 0)) + (pevalEqTerm s (conTerm (-2))) + ) + a + (pevalRotateLeftTerm a (conTerm 1)) + | otherwise = + SymIntN $ + pevalRotateLeftTerm + a + ( pevalModIntegralTerm + s + (conTerm (fromIntegral $ finiteBitSize as)) + ) + symRotateNegated as@(SymIntN a) (SymIntN s) + | finiteBitSize as == 1 = as + | finiteBitSize as == 2 = + SymIntN $ + pevalITETerm + ( pevalOrTerm + (pevalEqTerm s (conTerm 0)) + (pevalEqTerm s (conTerm (-2))) + ) + a + (pevalRotateLeftTerm a (conTerm 1)) + | otherwise = + SymIntN $ + pevalRotateRightTerm + a + ( pevalModIntegralTerm + s + (conTerm (fromIntegral $ finiteBitSize as)) + ) + +#define ALLSYMS_BV(t) \ +instance (KnownNat n, 1 <= n) => AllSyms (t n) where \ + allSymsS v = (SomeSym v :) + +#if 1 +ALLSYMS_BV(SymIntN) +ALLSYMS_BV(SymWordN) +#endif diff --git a/src/Grisette/Internal/SymPrim/SymBool.hs b/src/Grisette/Internal/SymPrim/SymBool.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/SymPrim/SymBool.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Grisette.Internal.SymPrim.SymBool +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.SymPrim.SymBool (SymBool (SymBool)) where + +import Control.DeepSeq (NFData) +import Data.Hashable (Hashable (hashWithSalt)) +import Data.String (IsString (fromString)) +import GHC.Generics (Generic) +import Grisette.Internal.Core.Data.Class.Function (Apply (FunType, apply)) +import Grisette.Internal.Core.Data.Class.Solvable (Solvable (con, conView, ssym, sym)) +import Grisette.Internal.SymPrim.AllSyms (AllSyms (allSymsS), SomeSym (SomeSym)) +import Grisette.Internal.SymPrim.Prim.Term + ( ConRep (ConType), + LinkedRep (underlyingTerm, wrapTerm), + SymRep (SymType), + Term (ConTerm), + conTerm, + pformat, + symTerm, + ) +import Language.Haskell.TH.Syntax (Lift) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim +-- >>> import Grisette.Backend +-- >>> import Data.Proxy + +-- | Symbolic Boolean type. +-- +-- >>> :set -XOverloadedStrings +-- >>> "a" :: SymBool +-- a +-- >>> "a" .&& "b" :: SymBool +-- (&& a b) +-- +-- More symbolic operations are available. Please refer to the documentation +-- for the type class instances. +newtype SymBool = SymBool {underlyingBoolTerm :: Term Bool} + deriving (Lift, NFData, Generic) + +instance ConRep SymBool where + type ConType SymBool = Bool + +instance SymRep Bool where + type SymType Bool = SymBool + +instance LinkedRep Bool SymBool where + underlyingTerm (SymBool a) = a + wrapTerm = SymBool + +instance Apply SymBool where + type FunType SymBool = SymBool + apply = id + +instance Eq SymBool where + SymBool l == SymBool r = l == r + +instance Hashable SymBool where + hashWithSalt s (SymBool v) = s `hashWithSalt` v + +instance Solvable Bool SymBool where + con = SymBool . conTerm + sym = SymBool . symTerm + conView (SymBool (ConTerm _ t)) = Just t + conView _ = Nothing + +instance IsString SymBool where + fromString = ssym . fromString + +instance Show SymBool where + show (SymBool t) = pformat t + +instance AllSyms SymBool where + allSymsS v = (SomeSym v :) diff --git a/src/Grisette/Internal/SymPrim/SymGeneralFun.hs b/src/Grisette/Internal/SymPrim/SymGeneralFun.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/SymPrim/SymGeneralFun.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Unused LANGUAGE pragma" #-} + +-- | +-- Module : Grisette.Internal.SymPrim.SymGeneralFun +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.SymPrim.SymGeneralFun + ( type (-~>) (..), + (-->), + ) +where + +import Control.DeepSeq (NFData (rnf)) +import Data.Hashable (Hashable (hashWithSalt)) +import Data.String (IsString (fromString)) +import GHC.Generics (Generic) +import Grisette.Internal.Core.Data.Class.Function + ( Apply (FunType, apply), + Function ((#)), + ) +import Grisette.Internal.Core.Data.Class.Solvable + ( Solvable (con, conView, ssym, sym), + ) +import Grisette.Internal.SymPrim.AllSyms (AllSyms (allSymsS), SomeSym (SomeSym)) +import Grisette.Internal.SymPrim.GeneralFun (buildGeneralFun, type (-->)) +import Grisette.Internal.SymPrim.Prim.Term + ( ConRep (ConType), + LinkedRep (underlyingTerm, wrapTerm), + PEvalApplyTerm (pevalApplyTerm), + SupportedNonFuncPrim, + SupportedPrim, + SymRep (SymType), + Term (ConTerm), + TypedSymbol, + conTerm, + pformat, + symTerm, + ) +import Language.Haskell.TH.Syntax (Lift (liftTyped)) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim +-- >>> import Grisette.Backend +-- >>> import Data.Proxy + +-- | +-- Symbolic general function type. +-- +-- >>> :set -XTypeOperators -XOverloadedStrings +-- >>> f' = "f" :: SymInteger -~> SymInteger +-- >>> f = (f' #) +-- >>> f 1 +-- (apply f 1) +-- +-- >>> f' = con ("a" --> "a" + 1) :: SymInteger -~> SymInteger +-- >>> f' +-- \(a:ARG :: Integer) -> (+ 1 a:ARG) +-- >>> f = (f' #) +-- >>> f 1 +-- 2 +-- >>> f 2 +-- 3 +-- >>> f 3 +-- 4 +-- >>> f "b" +-- (+ 1 b) +data sa -~> sb where + SymGeneralFun :: (LinkedRep ca sa, LinkedRep cb sb) => Term (ca --> cb) -> sa -~> sb + +infixr 0 -~> + +-- | Construction of general symbolic functions. +-- +-- >>> f = "a" --> "a" + 1 :: Integer --> Integer +-- >>> f +-- \(a:ARG :: Integer) -> (+ 1 a:ARG) +-- +-- This general symbolic function needs to be applied to symbolic values: +-- >>> f # ("a" :: SymInteger) +-- (+ 1 a) +(-->) :: + (SupportedPrim ca, SupportedPrim cb, LinkedRep cb sb) => + TypedSymbol ca -> + sb -> + ca --> cb +(-->) arg = buildGeneralFun arg . underlyingTerm + +infixr 0 --> + +data ARG = ARG + deriving (Eq, Ord, Lift, Show, Generic) + +instance NFData ARG where + rnf ARG = () + +instance Hashable ARG where + hashWithSalt s ARG = s `hashWithSalt` (0 :: Int) + +instance Lift (sa -~> sb) where + liftTyped (SymGeneralFun t) = [||SymGeneralFun t||] + +instance NFData (sa -~> sb) where + rnf (SymGeneralFun t) = rnf t + +instance (ConRep a, ConRep b) => ConRep (a -~> b) where + type ConType (a -~> b) = ConType a --> ConType b + +instance + ( SymRep ca, + SymRep cb, + SupportedPrim (ca --> cb) + ) => + SymRep (ca --> cb) + where + type SymType (ca --> cb) = SymType ca -~> SymType cb + +instance + ( LinkedRep ca sa, + LinkedRep cb sb, + SupportedPrim ca, + SupportedPrim cb, + SupportedPrim (ca --> cb) + ) => + LinkedRep (ca --> cb) (sa -~> sb) + where + underlyingTerm (SymGeneralFun a) = a + wrapTerm = SymGeneralFun + +instance + ( SupportedNonFuncPrim ca, + SupportedPrim cb, + LinkedRep ca sa, + LinkedRep cb sb, + SupportedPrim (ca --> cb) + ) => + Function (sa -~> sb) sa sb + where + (SymGeneralFun f) # t = wrapTerm $ pevalApplyTerm f (underlyingTerm t) + +instance + ( LinkedRep ca sa, + LinkedRep ct st, + Apply st, + SupportedNonFuncPrim ca, + SupportedPrim ct, + SupportedPrim (ca --> ct) + ) => + Apply (sa -~> st) + where + type FunType (sa -~> st) = sa -> FunType st + apply uf a = apply (uf # a) + +instance + ( SupportedPrim ca, + SupportedPrim cb, + LinkedRep ca sa, + LinkedRep cb sb, + SupportedPrim (ca --> cb) + ) => + Solvable (ca --> cb) (sa -~> sb) + where + con = SymGeneralFun . conTerm + sym = SymGeneralFun . symTerm + conView (SymGeneralFun (ConTerm _ t)) = Just t + conView _ = Nothing + +instance + ( SupportedPrim (ca --> cb), + LinkedRep ca sa, + LinkedRep cb sb + ) => + IsString (sa -~> sb) + where + fromString = ssym . fromString + +instance + (SupportedPrim (ca --> cb), LinkedRep ca sa, LinkedRep cb sb) => + Show (sa -~> sb) + where + show (SymGeneralFun t) = pformat t + +instance + (SupportedPrim (ca --> cb), LinkedRep ca sa, LinkedRep cb sb) => + Eq (sa -~> sb) + where + SymGeneralFun l == SymGeneralFun r = l == r + +instance + (SupportedPrim (ca --> cb), LinkedRep ca sa, LinkedRep cb sb) => + Hashable (sa -~> sb) + where + hashWithSalt s (SymGeneralFun v) = s `hashWithSalt` v + +instance + (SupportedPrim (ca --> cb), LinkedRep ca sa, LinkedRep cb sb) => + AllSyms (sa -~> sb) + where + allSymsS v = (SomeSym v :) diff --git a/src/Grisette/Internal/SymPrim/SymInteger.hs b/src/Grisette/Internal/SymPrim/SymInteger.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/SymPrim/SymInteger.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Grisette.Internal.SymPrim.SymInteger +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.SymPrim.SymInteger (SymInteger (SymInteger)) where + +import Control.DeepSeq (NFData) +import Data.Hashable (Hashable (hashWithSalt)) +import Data.String (IsString (fromString)) +import GHC.Generics (Generic) +import Grisette.Internal.Core.Data.Class.Function (Apply (FunType, apply)) +import Grisette.Internal.Core.Data.Class.Solvable (Solvable (con, conView, ssym, sym)) +import Grisette.Internal.SymPrim.AllSyms (AllSyms (allSymsS), SomeSym (SomeSym)) +import Grisette.Internal.SymPrim.Prim.Term + ( ConRep (ConType), + LinkedRep (underlyingTerm, wrapTerm), + PEvalNumTerm + ( pevalAbsNumTerm, + pevalAddNumTerm, + pevalMulNumTerm, + pevalNegNumTerm, + pevalSignumNumTerm + ), + SymRep (SymType), + Term (ConTerm), + conTerm, + pevalSubNumTerm, + pformat, + symTerm, + ) +import Language.Haskell.TH.Syntax (Lift) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim +-- >>> import Grisette.Backend +-- >>> import Data.Proxy + +-- | Symbolic (unbounded, mathematical) integer type. +-- +-- >>> "a" + 1 :: SymInteger +-- (+ 1 a) +-- +-- More symbolic operations are available. Please refer to the documentation +-- for the type class instances. +newtype SymInteger = SymInteger {underlyingIntegerTerm :: Term Integer} + deriving (Lift, NFData, Generic) + +instance ConRep SymInteger where + type ConType SymInteger = Integer + +instance SymRep Integer where + type SymType Integer = SymInteger + +instance LinkedRep Integer SymInteger where + underlyingTerm (SymInteger a) = a + wrapTerm = SymInteger + +instance Apply SymInteger where + type FunType SymInteger = SymInteger + apply = id + +instance Num SymInteger where + (SymInteger l) + (SymInteger r) = SymInteger $ pevalAddNumTerm l r + (SymInteger l) - (SymInteger r) = SymInteger $ pevalSubNumTerm l r + (SymInteger l) * (SymInteger r) = SymInteger $ pevalMulNumTerm l r + negate (SymInteger v) = SymInteger $ pevalNegNumTerm v + abs (SymInteger v) = SymInteger $ pevalAbsNumTerm v + signum (SymInteger v) = SymInteger $ pevalSignumNumTerm v + fromInteger = con + +instance Eq SymInteger where + SymInteger l == SymInteger r = l == r + +instance Hashable SymInteger where + hashWithSalt s (SymInteger v) = s `hashWithSalt` v + +instance Solvable Integer SymInteger where + con = SymInteger . conTerm + sym = SymInteger . symTerm + conView (SymInteger (ConTerm _ t)) = Just t + conView _ = Nothing + +instance IsString SymInteger where + fromString = ssym . fromString + +instance Show SymInteger where + show (SymInteger t) = pformat t + +instance AllSyms SymInteger where + allSymsS v = (SomeSym v :) diff --git a/src/Grisette/Internal/SymPrim/SymTabularFun.hs b/src/Grisette/Internal/SymPrim/SymTabularFun.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/SymPrim/SymTabularFun.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Unused LANGUAGE pragma" #-} + +-- | +-- Module : Grisette.Internal.SymPrim.SymTabularFun +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.SymPrim.SymTabularFun (type (=~>) (..)) where + +import Control.DeepSeq (NFData (rnf)) +import Data.Hashable (Hashable (hashWithSalt)) +import Data.String (IsString (fromString)) +import Grisette.Internal.Core.Data.Class.Function + ( Apply (FunType, apply), + Function ((#)), + ) +import Grisette.Internal.Core.Data.Class.Solvable + ( Solvable (con, conView, ssym, sym), + ) +import Grisette.Internal.SymPrim.AllSyms (AllSyms (allSymsS), SomeSym (SomeSym)) +import Grisette.Internal.SymPrim.Prim.Term + ( ConRep (ConType), + LinkedRep (underlyingTerm, wrapTerm), + PEvalApplyTerm (pevalApplyTerm), + SupportedPrim, + SymRep (SymType), + Term (ConTerm), + conTerm, + pformat, + symTerm, + ) +import Grisette.Internal.SymPrim.TabularFun (type (=->)) +import Language.Haskell.TH.Syntax (Lift (liftTyped)) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim +-- >>> import Grisette.Backend +-- >>> import Data.Proxy + +-- | Symbolic tabular function type. +-- +-- >>> :set -XTypeOperators -XOverloadedStrings +-- >>> f' = "f" :: SymInteger =~> SymInteger +-- >>> f = (f' #) +-- >>> f 1 +-- (apply f 1) +-- +-- >>> f' = con (TabularFun [(1, 2), (2, 3)] 4) :: SymInteger =~> SymInteger +-- >>> f = (f' #) +-- >>> f 1 +-- 2 +-- >>> f 2 +-- 3 +-- >>> f 3 +-- 4 +-- >>> f "b" +-- (ite (= b 1) 2 (ite (= b 2) 3 4)) +data sa =~> sb where + SymTabularFun :: + (LinkedRep ca sa, LinkedRep cb sb) => + Term (ca =-> cb) -> + sa =~> sb + +infixr 0 =~> + +instance Lift (sa =~> sb) where + liftTyped (SymTabularFun t) = [||SymTabularFun t||] + +instance NFData (sa =~> sb) where + rnf (SymTabularFun t) = rnf t + +instance (ConRep a, ConRep b) => ConRep (a =~> b) where + type ConType (a =~> b) = ConType a =-> ConType b + +instance (SymRep a, SymRep b, SupportedPrim (a =-> b)) => SymRep (a =-> b) where + type SymType (a =-> b) = SymType a =~> SymType b + +instance + (LinkedRep ca sa, LinkedRep cb sb, SupportedPrim (ca =-> cb)) => + LinkedRep (ca =-> cb) (sa =~> sb) + where + underlyingTerm (SymTabularFun a) = a + wrapTerm = SymTabularFun + +instance + ( SupportedPrim ca, + SupportedPrim cb, + LinkedRep ca sa, + LinkedRep cb sb, + SupportedPrim (ca =-> cb) + ) => + Function (sa =~> sb) sa sb + where + (SymTabularFun f) # t = wrapTerm $ pevalApplyTerm f (underlyingTerm t) + +instance + ( LinkedRep ca sa, + LinkedRep ct st, + Apply st, + SupportedPrim ca, + SupportedPrim ct, + SupportedPrim (ca =-> ct) + ) => + Apply (sa =~> st) + where + type FunType (sa =~> st) = sa -> FunType st + apply uf a = apply (uf # a) + +instance + ( SupportedPrim ca, + SupportedPrim cb, + LinkedRep ca sa, + LinkedRep cb sb, + SupportedPrim (ca =-> cb) + ) => + Solvable (ca =-> cb) (sa =~> sb) + where + con = SymTabularFun . conTerm + sym = SymTabularFun . symTerm + conView (SymTabularFun (ConTerm _ t)) = Just t + conView _ = Nothing + +instance + ( SupportedPrim (ca =-> cb), + LinkedRep ca sa, + LinkedRep cb sb + ) => + IsString (sa =~> sb) + where + fromString = ssym . fromString + +instance + (SupportedPrim (ca =-> cb), LinkedRep ca sa, LinkedRep cb sb) => + Show (sa =~> sb) + where + show (SymTabularFun t) = pformat t + +instance + (SupportedPrim (ca =-> cb), LinkedRep ca sa, LinkedRep cb sb) => + Eq (sa =~> sb) + where + SymTabularFun l == SymTabularFun r = l == r + +instance + (SupportedPrim (ca =-> cb), LinkedRep ca sa, LinkedRep cb sb) => + Hashable (sa =~> sb) + where + hashWithSalt s (SymTabularFun v) = s `hashWithSalt` v + +instance + (SupportedPrim (ca =-> cb), LinkedRep ca sa, LinkedRep cb sb) => + AllSyms (sa =~> sb) + where + allSymsS v = (SomeSym v :) diff --git a/src/Grisette/Internal/SymPrim/TabularFun.hs b/src/Grisette/Internal/SymPrim/TabularFun.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/SymPrim/TabularFun.hs @@ -0,0 +1,483 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Eta reduce" #-} + +-- | +-- Module : Grisette.Internal.SymPrim.TabularFun +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.SymPrim.TabularFun + ( type (=->) (..), + ) +where + +import Control.DeepSeq (NFData, NFData1) +import Data.Bifunctor (Bifunctor (second)) +import Data.Hashable (Hashable) +import qualified Data.SBV as SBV +import qualified Data.SBV.Dynamic as SBVD +import GHC.Generics (Generic, Generic1) +import Grisette.Internal.Core.Data.Class.Function (Function ((#))) +import Grisette.Internal.SymPrim.Prim.Internal.IsZero (KnownIsZero) +import Grisette.Internal.SymPrim.Prim.Internal.PartialEval (totalize2) +import Grisette.Internal.SymPrim.Prim.Internal.Term + ( NonFuncSBVRep (NonFuncSBVBaseType), + PEvalApplyTerm (pevalApplyTerm, sbvApplyTerm), + SBVRep (SBVType), + SupportedNonFuncPrim (conNonFuncSBVTerm, withNonFuncPrim), + SupportedPrim + ( conSBVTerm, + defaultValue, + parseSMTModelResult, + pevalITETerm, + sbvEq, + sbvIte, + symSBVName, + symSBVTerm, + withPrim + ), + SupportedPrimConstraint (PrimConstraint), + Term (ConTerm), + applyTerm, + conTerm, + partitionCVArg, + pevalDefaultEqTerm, + pevalEqTerm, + pevalITEBasicTerm, + translateTypeError, + ) +import Language.Haskell.TH.Syntax (Lift) +import Type.Reflection (typeRep) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim + +-- | +-- Functions as a table. Use the `#` operator to apply the function. +-- +-- >>> :set -XTypeOperators +-- >>> let f = TabularFun [(1, 2), (3, 4)] 0 :: Int =-> Int +-- >>> f # 1 +-- 2 +-- >>> f # 2 +-- 0 +-- >>> f # 3 +-- 4 +data (=->) a b = TabularFun {funcTable :: [(a, b)], defaultFuncValue :: b} + deriving (Show, Eq, Generic, Generic1, Lift, NFData, NFData1) + +infixr 0 =-> + +instance (Eq a) => Function (a =-> b) a b where + (TabularFun table d) # a = go table + where + go [] = d + go ((av, bv) : s) + | a == av = bv + | otherwise = go s + +instance (Hashable a, Hashable b) => Hashable (a =-> b) + +instance + (SupportedNonFuncPrim a, SupportedPrim b) => + SupportedPrimConstraint (a =-> b) + where + type + PrimConstraint n (a =-> b) = + ( SupportedNonFuncPrim a, + SupportedPrim b, + PrimConstraint n b + ) + +instance (SupportedNonFuncPrim a, SupportedPrim b) => SBVRep (a =-> b) where + type SBVType n (a =-> b) = SBV.SBV (NonFuncSBVBaseType n a) -> SBVType n b + +parseTabularFunSMTModelResult :: + forall a b. + (SupportedNonFuncPrim a, SupportedPrim b) => + Int -> + ([([SBVD.CV], SBVD.CV)], SBVD.CV) -> + a =-> b +parseTabularFunSMTModelResult level (l, s) = + TabularFun + ( second + (\r -> parseSMTModelResult (level + 1) (r, s)) + <$> partitionCVArg @a l + ) + (parseSMTModelResult (level + 1) ([], s)) + +instance + (SupportedNonFuncPrim a, SupportedNonFuncPrim b) => + SupportedPrim (a =-> b) + where + defaultValue = TabularFun [] defaultValue + pevalITETerm = pevalITEBasicTerm + pevalEqTerm = pevalDefaultEqTerm + conSBVTerm p f = + withNonFuncPrim @b p $ + lowerTFunCon p f + symSBVName _ num = "tfunc2" <> show num + symSBVTerm (p :: proxy n) name = + withNonFuncPrim @a p $ + withNonFuncPrim @b p $ + return $ + SBV.uninterpret name + withPrim p r = withNonFuncPrim @a p $ withNonFuncPrim @b p r + sbvIte p = withNonFuncPrim @b p SBV.ite + sbvEq _ _ = + translateTypeError + ( Just $ + "BUG. Please send a bug report. TabularFun is not supported for " + <> "equality comparison." + ) + (typeRep @(a =-> b)) + parseSMTModelResult = parseTabularFunSMTModelResult + +instance + {-# OVERLAPPING #-} + ( SupportedNonFuncPrim a, + SupportedNonFuncPrim b, + SupportedNonFuncPrim c, + SupportedPrim a, + SupportedPrim b, + SupportedPrim c + ) => + SupportedPrim (a =-> b =-> c) + where + defaultValue = TabularFun [] defaultValue + pevalITETerm = pevalITEBasicTerm + pevalEqTerm = pevalDefaultEqTerm + conSBVTerm p f = + withNonFuncPrim @c p $ + lowerTFunCon p f + symSBVName _ num = "tfunc3" <> show num + symSBVTerm (p :: proxy n) name = + withNonFuncPrim @a p $ + withNonFuncPrim @b p $ + withNonFuncPrim @c p $ + return $ + SBV.uninterpret name + withPrim p r = + withNonFuncPrim @a p $ + withNonFuncPrim @b p $ + withNonFuncPrim @c p r + sbvIte p = withNonFuncPrim @c p SBV.ite + sbvEq _ _ = + translateTypeError + ( Just $ + "BUG. Please send a bug report. TabularFun is not supported for " + <> "equality comparison." + ) + (typeRep @(a =-> b =-> c)) + parseSMTModelResult = parseTabularFunSMTModelResult + +instance + {-# OVERLAPPING #-} + ( SupportedNonFuncPrim a, + SupportedNonFuncPrim b, + SupportedNonFuncPrim c, + SupportedNonFuncPrim d, + SupportedPrim a, + SupportedPrim b, + SupportedPrim c, + SupportedPrim d + ) => + SupportedPrim (a =-> b =-> c =-> d) + where + defaultValue = TabularFun [] defaultValue + pevalITETerm = pevalITEBasicTerm + pevalEqTerm = pevalDefaultEqTerm + conSBVTerm p f = + withNonFuncPrim @d p $ + lowerTFunCon p f + symSBVName _ num = "tfunc4" <> show num + symSBVTerm (p :: proxy n) name = + withNonFuncPrim @a p $ + withNonFuncPrim @b p $ + withNonFuncPrim @c p $ + withNonFuncPrim @d p $ + return $ + SBV.uninterpret name + withPrim p r = + withNonFuncPrim @a p $ + withNonFuncPrim @b p $ + withNonFuncPrim @c p $ + withNonFuncPrim @d p r + sbvIte p = withNonFuncPrim @d p SBV.ite + sbvEq _ _ = + translateTypeError + ( Just $ + "BUG. Please send a bug report. TabularFun is not supported for " + <> "equality comparison." + ) + (typeRep @(a =-> b =-> c =-> d)) + parseSMTModelResult = parseTabularFunSMTModelResult + +instance + {-# OVERLAPPING #-} + ( SupportedNonFuncPrim a, + SupportedNonFuncPrim b, + SupportedNonFuncPrim c, + SupportedNonFuncPrim d, + SupportedNonFuncPrim e, + SupportedPrim a, + SupportedPrim b, + SupportedPrim c, + SupportedPrim d, + SupportedPrim e + ) => + SupportedPrim (a =-> b =-> c =-> d =-> e) + where + defaultValue = TabularFun [] defaultValue + pevalITETerm = pevalITEBasicTerm + pevalEqTerm = pevalDefaultEqTerm + conSBVTerm p f = + withNonFuncPrim @e p $ + lowerTFunCon p f + symSBVName _ num = "tfunc5" <> show num + symSBVTerm (p :: proxy n) name = + withNonFuncPrim @a p $ + withNonFuncPrim @b p $ + withNonFuncPrim @c p $ + withNonFuncPrim @d p $ + withNonFuncPrim @e p $ + return $ + SBV.uninterpret name + withPrim p r = + withNonFuncPrim @a p $ + withNonFuncPrim @b p $ + withNonFuncPrim @c p $ + withNonFuncPrim @d p $ + withNonFuncPrim @e p r + sbvIte p = withNonFuncPrim @e p SBV.ite + sbvEq _ _ = + translateTypeError + ( Just $ + "BUG. Please send a bug report. TabularFun is not supported for " + <> "equality comparison." + ) + (typeRep @(a =-> b =-> c =-> d =-> e)) + parseSMTModelResult = parseTabularFunSMTModelResult + +instance + {-# OVERLAPPING #-} + ( SupportedNonFuncPrim a, + SupportedNonFuncPrim b, + SupportedNonFuncPrim c, + SupportedNonFuncPrim d, + SupportedNonFuncPrim e, + SupportedNonFuncPrim f, + SupportedPrim a, + SupportedPrim b, + SupportedPrim c, + SupportedPrim d, + SupportedPrim e, + SupportedPrim f + ) => + SupportedPrim (a =-> b =-> c =-> d =-> e =-> f) + where + defaultValue = TabularFun [] defaultValue + pevalITETerm = pevalITEBasicTerm + pevalEqTerm = pevalDefaultEqTerm + conSBVTerm p f = + withNonFuncPrim @f p $ + lowerTFunCon p f + symSBVName _ num = "tfunc6" <> show num + symSBVTerm (p :: proxy n) name = + withNonFuncPrim @a p $ + withNonFuncPrim @b p $ + withNonFuncPrim @c p $ + withNonFuncPrim @d p $ + withNonFuncPrim @e p $ + withNonFuncPrim @f p $ + return $ + SBV.uninterpret name + withPrim p r = + withNonFuncPrim @a p $ + withNonFuncPrim @b p $ + withNonFuncPrim @c p $ + withNonFuncPrim @d p $ + withNonFuncPrim @e p $ + withNonFuncPrim @f p r + sbvIte p = withNonFuncPrim @f p SBV.ite + sbvEq _ _ = + translateTypeError + ( Just $ + "BUG. Please send a bug report. TabularFun is not supported for " + <> "equality comparison." + ) + (typeRep @(a =-> b =-> c =-> d =-> e =-> f)) + parseSMTModelResult = parseTabularFunSMTModelResult + +-- 7 arguments +instance + {-# OVERLAPPING #-} + ( SupportedNonFuncPrim a, + SupportedNonFuncPrim b, + SupportedNonFuncPrim c, + SupportedNonFuncPrim d, + SupportedNonFuncPrim e, + SupportedNonFuncPrim f, + SupportedNonFuncPrim g, + SupportedPrim a, + SupportedPrim b, + SupportedPrim c, + SupportedPrim d, + SupportedPrim e, + SupportedPrim f, + SupportedPrim g + ) => + SupportedPrim (a =-> b =-> c =-> d =-> e =-> f =-> g) + where + defaultValue = TabularFun [] defaultValue + pevalITETerm = pevalITEBasicTerm + pevalEqTerm = pevalDefaultEqTerm + conSBVTerm p f = + withNonFuncPrim @g p $ + lowerTFunCon p f + symSBVName _ num = "tfunc7" <> show num + symSBVTerm (p :: proxy n) name = + withNonFuncPrim @a p $ + withNonFuncPrim @b p $ + withNonFuncPrim @c p $ + withNonFuncPrim @d p $ + withNonFuncPrim @e p $ + withNonFuncPrim @f p $ + withNonFuncPrim @g p $ + return $ + SBV.uninterpret name + withPrim p r = + withNonFuncPrim @a p $ + withNonFuncPrim @b p $ + withNonFuncPrim @c p $ + withNonFuncPrim @d p $ + withNonFuncPrim @e p $ + withNonFuncPrim @f p $ + withNonFuncPrim @g p r + sbvIte p = withNonFuncPrim @g p SBV.ite + sbvEq _ _ = + translateTypeError + ( Just $ + "BUG. Please send a bug report. TabularFun is not supported for " + <> "equality comparison." + ) + (typeRep @(a =-> b =-> c =-> d =-> e =-> f =-> g)) + parseSMTModelResult = parseTabularFunSMTModelResult + +-- 8 arguments +instance + {-# OVERLAPPING #-} + ( SupportedNonFuncPrim a, + SupportedNonFuncPrim b, + SupportedNonFuncPrim c, + SupportedNonFuncPrim d, + SupportedNonFuncPrim e, + SupportedNonFuncPrim f, + SupportedNonFuncPrim g, + SupportedNonFuncPrim h, + SupportedPrim a, + SupportedPrim b, + SupportedPrim c, + SupportedPrim d, + SupportedPrim e, + SupportedPrim f, + SupportedPrim g, + SupportedPrim h + ) => + SupportedPrim (a =-> b =-> c =-> d =-> e =-> f =-> g =-> h) + where + defaultValue = TabularFun [] defaultValue + pevalITETerm = pevalITEBasicTerm + pevalEqTerm = pevalDefaultEqTerm + conSBVTerm p f = + withNonFuncPrim @h p $ + lowerTFunCon p f + symSBVName _ num = "tfunc8" <> show num + symSBVTerm (p :: proxy n) name = + withNonFuncPrim @a p $ + withNonFuncPrim @b p $ + withNonFuncPrim @c p $ + withNonFuncPrim @d p $ + withNonFuncPrim @e p $ + withNonFuncPrim @f p $ + withNonFuncPrim @g p $ + withNonFuncPrim @h p $ + return $ + SBV.uninterpret name + withPrim p r = + withNonFuncPrim @a p $ + withNonFuncPrim @b p $ + withNonFuncPrim @c p $ + withNonFuncPrim @d p $ + withNonFuncPrim @e p $ + withNonFuncPrim @f p $ + withNonFuncPrim @g p $ + withNonFuncPrim @h p r + sbvIte p = withNonFuncPrim @h p SBV.ite + sbvEq _ _ = + translateTypeError + ( Just $ + "BUG. Please send a bug report. TabularFun is not supported for " + <> "equality comparison." + ) + (typeRep @(a =-> b =-> c =-> d =-> e =-> f =-> g =-> h)) + parseSMTModelResult = parseTabularFunSMTModelResult + +instance + (SupportedPrim a, SupportedPrim b, SupportedPrim (a =-> b)) => + PEvalApplyTerm (a =-> b) a b + where + pevalApplyTerm = totalize2 doPevalApplyTerm applyTerm + where + doPevalApplyTerm :: + (SupportedPrim a, SupportedPrim b) => + Term (a =-> b) -> + Term a -> + Maybe (Term b) + doPevalApplyTerm (ConTerm _ f) (ConTerm _ a) = Just $ conTerm $ f # a + doPevalApplyTerm (ConTerm _ (TabularFun f d)) a = Just $ go f + where + go [] = conTerm d + go ((x, y) : xs) = + pevalITETerm (pevalEqTerm a (conTerm x)) (conTerm y) (go xs) + doPevalApplyTerm _ _ = Nothing + sbvApplyTerm p f a = + withPrim @(a =-> b) p $ withNonFuncPrim @a p $ f a + +lowerTFunCon :: + forall proxy integerBitWidth a b. + ( SupportedNonFuncPrim a, + SupportedPrim b, + SBV.Mergeable (SBVType integerBitWidth b), + KnownIsZero integerBitWidth + ) => + proxy integerBitWidth -> + (a =-> b) -> + ( SBV.SBV (NonFuncSBVBaseType integerBitWidth a) -> + SBVType integerBitWidth b + ) +lowerTFunCon proxy (TabularFun l d) = go l d + where + go [] d _ = conSBVTerm proxy d + go ((x, r) : xs) d v = + SBV.ite + (conNonFuncSBVTerm proxy x SBV..== v) + (conSBVTerm proxy r) + (go xs d v) diff --git a/src/Grisette/Internal/Utils/Parameterized.hs b/src/Grisette/Internal/Utils/Parameterized.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Utils/Parameterized.hs @@ -0,0 +1,272 @@ +{- +Part of the code in this file comes from the parameterized-utils package: + +Copyright (c) 2013-2022 Galois Inc. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + + * Neither the name of Galois, Inc. nor the names of its contributors + may be used to endorse or promote products derived from this + software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +-- | +-- Module : Grisette.Internal.Utils.Parameterized +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Utils.Parameterized + ( -- * Unsafe axiom + unsafeAxiom, + + -- * Unparameterized type + SomeNatRepr (..), + SomePositiveNatRepr (..), + + -- * Runtime representation of type-level natural numbers + NatRepr, + withKnownNat, + natValue, + mkNatRepr, + mkPositiveNatRepr, + natRepr, + decNat, + predNat, + incNat, + addNat, + subNat, + divNat, + halfNat, + + -- * Proof of KnownNat + KnownProof (..), + hasRepr, + withKnownProof, + unsafeKnownProof, + knownAdd, + + -- * Proof of (<=) for type-level natural numbers + LeqProof (..), + withLeqProof, + unsafeLeqProof, + testLeq, + leqRefl, + leqSucc, + leqTrans, + leqZero, + leqAdd2, + leqAdd, + leqAddPos, + ) +where + +import Data.Typeable (Proxy (Proxy), type (:~:) (Refl)) +import GHC.TypeNats + ( Div, + KnownNat, + Nat, + SomeNat (SomeNat), + natVal, + someNatVal, + type (+), + type (-), + type (<=), + ) +import Numeric.Natural (Natural) +import Unsafe.Coerce (unsafeCoerce) + +-- | Assert a proof of equality between two types. +-- This is unsafe if used improperly, so use this with caution! +unsafeAxiom :: forall a b. a :~: b +unsafeAxiom = unsafeCoerce (Refl @a) + +withKnownNat :: forall n r. NatRepr n -> ((KnownNat n) => r) -> r +withKnownNat (NatRepr nVal) v = + case someNatVal nVal of + SomeNat (Proxy :: Proxy n') -> + case unsafeAxiom :: n :~: n' of + Refl -> v + +-- | A runtime representation of type-level natural numbers. +-- This can be used for performing dynamic checks on type-level natural numbers. +newtype NatRepr (n :: Nat) = NatRepr Natural + +-- | The underlying runtime natural number value of a type-level natural number. +natValue :: NatRepr n -> Natural +natValue (NatRepr n) = n + +data SomeNatReprHelper where + SomeNatReprHelper :: NatRepr n -> SomeNatReprHelper + +data SomeNatRepr where + SomeNatRepr :: (KnownNat n) => NatRepr n -> SomeNatRepr + +-- | Turn a @Natural@ into the corresponding @NatRepr@ with the KnownNat +-- constraint. +mkNatRepr :: Natural -> SomeNatRepr +mkNatRepr n = case SomeNatReprHelper (NatRepr n) of + SomeNatReprHelper natRepr -> withKnownNat natRepr $ SomeNatRepr natRepr + +data SomePositiveNatRepr where + SomePositiveNatRepr :: + (KnownNat n, 1 <= n) => NatRepr n -> SomePositiveNatRepr + +-- | Turn a @NatRepr@ into the corresponding @NatRepr@ with the KnownNat +-- constraint and asserts that its greater than 0. +mkPositiveNatRepr :: Natural -> SomePositiveNatRepr +mkPositiveNatRepr 0 = error "mkPositiveNatRepr: 0 is not a positive number" +mkPositiveNatRepr n = case mkNatRepr n of + SomeNatRepr (natRepr :: NatRepr n) -> case unsafeLeqProof @1 @n of + LeqProof -> SomePositiveNatRepr natRepr + +-- | Construct a runtime representation of a type-level natural number when its +-- runtime value is known. +natRepr :: forall n. (KnownNat n) => NatRepr n +natRepr = NatRepr (natVal (Proxy @n)) + +-- | Decrement a 'NatRepr' by 1. +decNat :: (1 <= n) => NatRepr n -> NatRepr (n - 1) +decNat (NatRepr n) = NatRepr (n - 1) + +-- | Predecessor of a 'NatRepr' +predNat :: NatRepr (n + 1) -> NatRepr n +predNat (NatRepr n) = NatRepr (n - 1) + +-- | Increment a 'NatRepr' by 1. +incNat :: NatRepr n -> NatRepr (n + 1) +incNat (NatRepr n) = NatRepr (n + 1) + +-- | Addition of two 'NatRepr's. +addNat :: NatRepr m -> NatRepr n -> NatRepr (m + n) +addNat (NatRepr m) (NatRepr n) = NatRepr (m + n) + +-- | Subtraction of two 'NatRepr's. +subNat :: (n <= m) => NatRepr m -> NatRepr n -> NatRepr (m - n) +subNat (NatRepr m) (NatRepr n) = NatRepr (m - n) + +-- | Division of two 'NatRepr's. +divNat :: (1 <= n) => NatRepr m -> NatRepr n -> NatRepr (Div m n) +divNat (NatRepr m) (NatRepr n) = NatRepr (m `div` n) + +-- | Half of a 'NatRepr'. +halfNat :: NatRepr (n + n) -> NatRepr n +halfNat (NatRepr n) = NatRepr (n `div` 2) + +-- | @'KnownProof n'@ is a type whose values are only inhabited when @n@ has +-- a known runtime value. +data KnownProof (n :: Nat) where + KnownProof :: (KnownNat n) => KnownProof n + +-- | Introduces the 'KnownNat' constraint when it's proven. +withKnownProof :: KnownProof n -> ((KnownNat n) => r) -> r +withKnownProof p r = case p of KnownProof -> r + +-- | Construct a 'KnownProof' given the runtime value. +-- +-- __Note:__ This function is unsafe, as it does not check that the runtime +-- representation is consistent with the type-level representation. +-- You should ensure the consistency yourself or the program can crash or +-- generate incorrect results. +unsafeKnownProof :: Natural -> KnownProof n +unsafeKnownProof nVal = hasRepr (NatRepr nVal) + +-- | Construct a 'KnownProof' given the runtime representation. +hasRepr :: forall n. NatRepr n -> KnownProof n +hasRepr (NatRepr nVal) = + case someNatVal nVal of + SomeNat (Proxy :: Proxy n') -> + case unsafeAxiom :: n :~: n' of + Refl -> KnownProof + +-- | Adding two type-level natural numbers with known runtime values gives a +-- type-level natural number with a known runtime value. +knownAdd :: forall m n. KnownProof m -> KnownProof n -> KnownProof (m + n) +knownAdd KnownProof KnownProof = hasRepr @(m + n) (NatRepr (natVal (Proxy @m) + natVal (Proxy @n))) + +-- | @'LeqProof m n'@ is a type whose values are only inhabited when @m <= n@. +data LeqProof (m :: Nat) (n :: Nat) where + LeqProof :: (m <= n) => LeqProof m n + +-- | Introduces the @m <= n@ constraint when it's proven. +withLeqProof :: LeqProof m n -> ((m <= n) => r) -> r +withLeqProof p r = case p of LeqProof -> r + +-- | Construct a 'LeqProof'. +-- +-- __Note:__ This function is unsafe, as it does not check that the left-hand +-- side is less than or equal to the right-hand side. +-- You should ensure the consistency yourself or the program can crash or +-- generate incorrect results. +unsafeLeqProof :: forall m n. LeqProof m n +unsafeLeqProof = unsafeCoerce (LeqProof @0 @0) + +-- | Checks if a 'NatRepr' is less than or equal to another 'NatRepr'. +testLeq :: NatRepr m -> NatRepr n -> Maybe (LeqProof m n) +testLeq (NatRepr m) (NatRepr n) = + case compare m n of + LT -> Nothing + EQ -> Just unsafeLeqProof + GT -> Just unsafeLeqProof + +-- | Apply reflexivity to 'LeqProof'. +leqRefl :: f n -> LeqProof n n +leqRefl _ = LeqProof + +-- | A natural number is less than or equal to its successor. +leqSucc :: f n -> LeqProof n (n + 1) +leqSucc _ = unsafeLeqProof + +-- | Apply transitivity to 'LeqProof'. +leqTrans :: LeqProof a b -> LeqProof b c -> LeqProof a c +leqTrans _ _ = unsafeLeqProof + +-- | Zero is less than or equal to any natural number. +leqZero :: LeqProof 0 n +leqZero = unsafeLeqProof + +-- | Add both sides of two inequalities. +leqAdd2 :: LeqProof xl xh -> LeqProof yl yh -> LeqProof (xl + yl) (xh + yh) +leqAdd2 _ _ = unsafeLeqProof + +-- | Produce proof that adding a value to the larger element in an 'LeqProof' +-- is larger. +leqAdd :: LeqProof m n -> f o -> LeqProof m (n + o) +leqAdd _ _ = unsafeLeqProof + +-- | Adding two positive natural numbers is positive. +leqAddPos :: (1 <= m, 1 <= n) => p m -> q n -> LeqProof 1 (m + n) +leqAddPos _ _ = unsafeLeqProof diff --git a/src/Grisette/Lib/Base.hs b/src/Grisette/Lib/Base.hs --- a/src/Grisette/Lib/Base.hs +++ b/src/Grisette/Lib/Base.hs @@ -1,8 +1,9 @@ {-# LANGUAGE Trustworthy #-} +{-# OPTIONS_GHC -Wno-missing-import-lists #-} -- | -- Module : Grisette.Lib.Base --- Copyright : (c) Sirui Lu 2021-2023 +-- Copyright : (c) Sirui Lu 2021-2024 -- License : BSD-3-Clause (see the LICENSE file) -- -- Maintainer : siruilu@cs.washington.edu @@ -10,76 +11,26 @@ -- Portability : GHC only module Grisette.Lib.Base ( -- * Symbolic or mrg* variants for the operations in the base package - - -- ** mrg* variants for operations in "Control.Monad" - mrgReturnWithStrategy, - mrgBindWithStrategy, - mrgReturn, - (.>>=), - (.>>), - mrgFoldM, - mrgMzero, - mrgMplus, - mrgFmap, - - -- ** mrg* variants for operations in "Data.Foldable" - mrgFoldlM, - mrgFoldrM, - mrgTraverse_, - mrgFor_, - mrgMapM_, - mrgForM_, - mrgSequence_, - mrgMsum, - - -- ** mrg* variants for operations in "Data.Traversable" - mrgTraverse, - mrgSequenceA, - mrgFor, - mrgMapM, - mrgForM, - mrgSequence, - - -- ** Symbolic versions for operations in "Data.List" - (.!!), - symFilter, - symTake, - symDrop, + module Grisette.Lib.Control.Applicative, + module Grisette.Lib.Control.Monad, + module Grisette.Lib.Data.Either, + module Grisette.Lib.Data.Foldable, + module Grisette.Lib.Data.Functor, + module Grisette.Lib.Data.Functor.Sum, + module Grisette.Lib.Data.List, + module Grisette.Lib.Data.Maybe, + module Grisette.Lib.Data.Traversable, + module Grisette.Lib.Data.Tuple, ) where +import Grisette.Lib.Control.Applicative import Grisette.Lib.Control.Monad - ( mrgBindWithStrategy, - mrgFmap, - mrgFoldM, - mrgMplus, - mrgMzero, - mrgReturn, - mrgReturnWithStrategy, - (.>>), - (.>>=), - ) +import Grisette.Lib.Data.Either import Grisette.Lib.Data.Foldable - ( mrgFoldlM, - mrgFoldrM, - mrgForM_, - mrgFor_, - mrgMapM_, - mrgMsum, - mrgSequence_, - mrgTraverse_, - ) +import Grisette.Lib.Data.Functor +import Grisette.Lib.Data.Functor.Sum import Grisette.Lib.Data.List - ( symDrop, - symFilter, - symTake, - (.!!), - ) +import Grisette.Lib.Data.Maybe import Grisette.Lib.Data.Traversable - ( mrgFor, - mrgForM, - mrgMapM, - mrgSequence, - mrgSequenceA, - mrgTraverse, - ) +import Grisette.Lib.Data.Tuple diff --git a/src/Grisette/Lib/Control/Applicative.hs b/src/Grisette/Lib/Control/Applicative.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Lib/Control/Applicative.hs @@ -0,0 +1,173 @@ +-- | +-- Module : Grisette.Lib.Control.Applicative +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Lib.Control.Applicative + ( -- * Applicative Functors + mrgPureWithStrategy, + mrgPure, + (.<*>), + mrgLiftA2, + (.*>), + (.<*), + + -- * Alternatives + mrgEmpty, + (.<|>), + mrgSome, + mrgMany, + + -- * Utility functions + (.<$>), + (.<$), + (.<**>), + mrgLiftA, + mrgLiftA3, + mrgOptional, + mrgAsum, + ) +where + +import Control.Applicative (Alternative (empty, (<|>)), (<**>)) +import Data.Functor (void) +import Grisette.Internal.Core.Data.Class.Mergeable + ( Mergeable (rootStrategy), + MergingStrategy, + ) +import Grisette.Internal.Core.Data.Class.TryMerge + ( TryMerge, + mrgSingleWithStrategy, + tryMerge, + ) +import Grisette.Lib.Data.Functor ((.<$), (.<$>)) + +-- | Alias for 'mrgSingleWithStrategy'. +mrgPureWithStrategy :: + (TryMerge m, Applicative m) => MergingStrategy a -> a -> m a +mrgPureWithStrategy = mrgSingleWithStrategy +{-# INLINE mrgPureWithStrategy #-} + +-- | Alias for 'mrgSingle'. +mrgPure :: (TryMerge m, Applicative m, Mergeable a) => a -> m a +mrgPure = mrgPureWithStrategy rootStrategy +{-# INLINE mrgPure #-} + +infixl 4 .<*> + +-- | '<*>' with 'MergingStrategy' knowledge propagation. +(.<*>) :: + (Applicative f, TryMerge f, Mergeable a, Mergeable b) => + f (a -> b) -> + f a -> + f b +f .<*> a = tryMerge $ tryMerge f <*> tryMerge a +{-# INLINE (.<*>) #-} + +-- | 'liftA2' with 'MergingStrategy' knowledge propagation. +mrgLiftA2 :: + (Applicative f, TryMerge f, Mergeable a, Mergeable b, Mergeable c) => + (a -> b -> c) -> + f a -> + f b -> + f c +mrgLiftA2 f a b = f .<$> a .<*> tryMerge b +{-# INLINE mrgLiftA2 #-} + +infixl 4 .*> + +-- | '*>' with 'MergingStrategy' knowledge propagation. +(.*>) :: + (Applicative f, TryMerge f, Mergeable a, Mergeable b) => f a -> f b -> f b +a .*> b = tryMerge $ tryMerge (void a) *> tryMerge b +{-# INLINE (.*>) #-} + +infixl 4 .<* + +-- | '<*' with 'MergingStrategy' knowledge propagation. +(.<*) :: + (Applicative f, TryMerge f, Mergeable a, Mergeable b) => f a -> f b -> f a +a .<* b = tryMerge $ tryMerge a <* tryMerge (void b) +{-# INLINE (.<*) #-} + +-- | 'empty' with 'MergingStrategy' knowledge propagation. +mrgEmpty :: (Alternative f, TryMerge f, Mergeable a) => f a +mrgEmpty = tryMerge empty +{-# INLINE mrgEmpty #-} + +infixl 3 .<|> + +-- | '<|>' with 'MergingStrategy' knowledge propagation. +(.<|>) :: (Alternative f, TryMerge f, Mergeable a) => f a -> f a -> f a +a .<|> b = tryMerge $ tryMerge a <|> tryMerge b +{-# INLINE (.<|>) #-} + +-- | 'some' with 'MergingStrategy' knowledge propagation. +mrgSome :: (Alternative f, TryMerge f, Mergeable a) => f a -> f [a] +mrgSome v = some_v + where + many_v = some_v .<|> pure [] + some_v = mrgLiftA2 (:) v many_v +{-# INLINE mrgSome #-} + +-- | 'many' with 'MergingStrategy' knowledge propagation. +mrgMany :: (Alternative f, TryMerge f, Mergeable a) => f a -> f [a] +mrgMany v = many_v + where + many_v = some_v .<|> pure [] + some_v = mrgLiftA2 (:) v many_v +{-# INLINE mrgMany #-} + +infixl 4 .<**> + +-- | '<**>' with 'MergingStrategy' knowledge propagation. +(.<**>) :: + (Applicative f, TryMerge f, Mergeable a, Mergeable b) => + f a -> + f (a -> b) -> + f b +a .<**> f = tryMerge $ tryMerge a <**> tryMerge f +{-# INLINE (.<**>) #-} + +-- | 'liftA' with 'MergingStrategy' knowledge propagation. +mrgLiftA :: + (Applicative f, TryMerge f, Mergeable a, Mergeable b) => + (a -> b) -> + f a -> + f b +mrgLiftA f a = mrgPure f .<*> a +{-# INLINE mrgLiftA #-} + +-- | 'liftA3' with 'MergingStrategy' knowledge propagation. +mrgLiftA3 :: + ( Applicative f, + TryMerge f, + Mergeable a, + Mergeable b, + Mergeable c, + Mergeable d + ) => + (a -> b -> c -> d) -> + f a -> + f b -> + f c -> + f d +mrgLiftA3 f a b c = mrgPure f .<*> a .<*> b .<*> c +{-# INLINE mrgLiftA3 #-} + +-- | 'optional' with 'MergingStrategy' knowledge propagation. +mrgOptional :: + (Alternative f, TryMerge f, Mergeable a) => + f a -> + f (Maybe a) +mrgOptional v = Just .<$> v .<|> pure Nothing +{-# INLINE mrgOptional #-} + +-- | 'asum' with 'MergingStrategy' knowledge propagation. +mrgAsum :: + (Alternative f, TryMerge f, Mergeable a, Foldable t) => t (f a) -> f a +mrgAsum = foldr (.<|>) mrgEmpty +{-# INLINE mrgAsum #-} diff --git a/src/Grisette/Lib/Control/Monad.hs b/src/Grisette/Lib/Control/Monad.hs --- a/src/Grisette/Lib/Control/Monad.hs +++ b/src/Grisette/Lib/Control/Monad.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -5,81 +6,492 @@ -- | -- Module : Grisette.Lib.Control.Monad --- Copyright : (c) Sirui Lu 2021-2023 +-- Copyright : (c) Sirui Lu 2021-2024 -- License : BSD-3-Clause (see the LICENSE file) -- -- Maintainer : siruilu@cs.washington.edu -- Stability : Experimental -- Portability : GHC only module Grisette.Lib.Control.Monad - ( -- * mrg* variants for operations in "Control.Monad" + ( -- * Functor and Monad classes + mrgFmap, + (.<$), mrgReturnWithStrategy, mrgBindWithStrategy, mrgReturn, (.>>=), (.>>), - mrgFoldM, + mrgFail, mrgMzero, mrgMplus, - mrgFmap, + + -- * Functions + + -- ** Basic 'Monad' functions + mrgMapM, + mrgMapM_, + mrgForM, + mrgForM_, + mrgSequence, + mrgSequence_, + (.=<<), + (.>=>), + (.<=<), + mrgForever, + mrgVoid, + + -- ** Generalisations of list functions + mrgJoin, + mrgMsum, + mrgMfilter, + symMfilter, + mrgFilterM, + symFilterM, + mrgMapAndUnzipM, + mrgZipWithM, + mrgZipWithM_, + mrgFoldM, + mrgFoldM_, + mrgReplicateM, + symReplicateM, + mrgReplicateM_, + symReplicateM_, + + -- ** Conditional execution of monadic expressions + mrgGuard, + symGuard, + mrgWhen, + symWhen, + mrgUnless, + symUnless, + + -- ** Monadic lifting operators + mrgLiftM, + mrgLiftM2, + mrgLiftM3, + mrgLiftM4, + mrgLiftM5, + mrgAp, + + -- ** Strict monadic functions + (.<$!>), ) where -import Control.Monad (MonadPlus (mplus, mzero)) -import Grisette.Core.Control.Monad.Union (MonadUnion) -import Grisette.Core.Data.Class.Mergeable - ( Mergeable, +import Control.Applicative (Alternative) +import Control.Monad (MonadPlus (mplus, mzero), join) +import Grisette.Internal.Core.Control.Monad.Union (MonadUnion) +import Grisette.Internal.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.||))) +import Grisette.Internal.Core.Data.Class.Mergeable + ( Mergeable (rootStrategy), MergingStrategy, ) -import Grisette.Core.Data.Class.SimpleMergeable - ( UnionLike (mergeWithStrategy), - merge, +import Grisette.Internal.Core.Data.Class.SOrd (SOrd ((.<=))) +import Grisette.Internal.Core.Data.Class.SimpleMergeable (UnionMergeable1, mrgIf) +import Grisette.Internal.Core.Data.Class.TryMerge + ( MonadTryMerge, + TryMerge (tryMergeWithStrategy), + tryMerge, ) -import Grisette.Lib.Data.Foldable (mrgFoldlM) +import Grisette.Internal.SymPrim.SymBool (SymBool) +import Grisette.Lib.Control.Applicative + ( mrgEmpty, + mrgLiftA2, + mrgPure, + (.*>), + (.<$>), + (.<*>), + ) +import Grisette.Lib.Data.Foldable + ( mrgFoldlM, + mrgForM_, + mrgMapM_, + mrgMsum, + mrgSequenceA_, + mrgSequence_, + ) +import Grisette.Lib.Data.Functor (mrgFmap, mrgUnzip, mrgVoid, (.<$)) +import Grisette.Lib.Data.Traversable + ( mrgForM, + mrgMapM, + mrgSequence, + mrgSequenceA, + mrgTraverse, + ) -- | 'return' with 'MergingStrategy' knowledge propagation. -mrgReturnWithStrategy :: (MonadUnion u) => MergingStrategy a -> a -> u a -mrgReturnWithStrategy s = mergeWithStrategy s . return +mrgReturnWithStrategy :: (MonadTryMerge u) => MergingStrategy a -> a -> u a +mrgReturnWithStrategy s = tryMergeWithStrategy s . return {-# INLINE mrgReturnWithStrategy #-} -- | '>>=' with 'MergingStrategy' knowledge propagation. -mrgBindWithStrategy :: (MonadUnion u) => MergingStrategy b -> u a -> (a -> u b) -> u b -mrgBindWithStrategy s a f = mergeWithStrategy s $ a >>= f +mrgBindWithStrategy :: + (MonadTryMerge u) => + MergingStrategy a -> + MergingStrategy b -> + u a -> + (a -> u b) -> + u b +mrgBindWithStrategy sa sb a f = + tryMergeWithStrategy sb $ tryMergeWithStrategy sa a >>= f {-# INLINE mrgBindWithStrategy #-} -- | 'return' with 'MergingStrategy' knowledge propagation. -mrgReturn :: (MonadUnion u, Mergeable a) => a -> u a -mrgReturn = merge . return +mrgReturn :: (MonadTryMerge u, Mergeable a) => a -> u a +mrgReturn = mrgReturnWithStrategy rootStrategy {-# INLINE mrgReturn #-} +infixl 1 .>>= + -- | '>>=' with 'MergingStrategy' knowledge propagation. -(.>>=) :: (MonadUnion u, Mergeable b) => u a -> (a -> u b) -> u b -a .>>= f = merge $ a >>= f +(.>>=) :: + (MonadTryMerge u, Mergeable a, Mergeable b) => + u a -> + (a -> u b) -> + u b +(.>>=) = mrgBindWithStrategy rootStrategy rootStrategy {-# INLINE (.>>=) #-} --- | 'foldM' with 'MergingStrategy' knowledge propagation. -mrgFoldM :: (MonadUnion m, Mergeable b, Foldable t) => (b -> a -> m b) -> b -> t a -> m b -mrgFoldM = mrgFoldlM -{-# INLINE mrgFoldM #-} +infixl 1 .>> -- | '>>' with 'MergingStrategy' knowledge propagation. -- --- This is usually more efficient than calling the original '>>' and merge the results. -(.>>) :: forall m a b. (MonadUnion m, Mergeable b) => m a -> m b -> m b -a .>> f = merge $ mrgFmap (const ()) a >> f +-- This is usually more efficient than calling the original '>>' and merge the +-- results. +(.>>) :: (MonadTryMerge m, Mergeable a, Mergeable b) => m a -> m b -> m b +a .>> f = tryMerge $ mrgVoid a >> f {-# INLINE (.>>) #-} +-- | 'fail' with 'MergingStrategy' knowledge propagation. +mrgFail :: (MonadTryMerge m, Mergeable a, MonadFail m) => String -> m a +mrgFail = tryMerge . fail +{-# INLINE mrgFail #-} + -- | 'mzero' with 'MergingStrategy' knowledge propagation. -mrgMzero :: forall m a. (MonadUnion m, Mergeable a, MonadPlus m) => m a -mrgMzero = merge mzero +mrgMzero :: forall m a. (MonadTryMerge m, Mergeable a, MonadPlus m) => m a +mrgMzero = tryMerge mzero {-# INLINE mrgMzero #-} -- | 'mplus' with 'MergingStrategy' knowledge propagation. -mrgMplus :: forall m a. (MonadUnion m, Mergeable a, MonadPlus m) => m a -> m a -> m a -mrgMplus a b = merge $ mplus a b +mrgMplus :: + forall m a. (MonadTryMerge m, Mergeable a, MonadPlus m) => m a -> m a -> m a +mrgMplus a b = tryMerge $ mplus (tryMerge a) (tryMerge b) {-# INLINE mrgMplus #-} --- | 'fmap' with 'MergingStrategy' knowledge propagation. -mrgFmap :: (MonadUnion f, Mergeable b, Functor f) => (a -> b) -> f a -> f b -mrgFmap f a = merge $ fmap f a -{-# INLINE mrgFmap #-} +infixr 1 .=<< + +-- | '=<<' with 'MergingStrategy' knowledge propagation. +(.=<<) :: + (MonadTryMerge m, Mergeable a, Mergeable b) => (a -> m b) -> m a -> m b +f .=<< a = tryMerge $ f =<< tryMerge a +{-# INLINE (.=<<) #-} + +infixr 1 .>=> + +-- | '>=>' with 'MergingStrategy' knowledge propagation. +(.>=>) :: + (MonadTryMerge m, Mergeable a, Mergeable b, Mergeable c) => + (a -> m b) -> + (b -> m c) -> + a -> + m c +f .>=> g = \a -> tryMerge $ tryMerge (f a) >>= g +{-# INLINE (.>=>) #-} + +infixr 1 .<=< + +-- | '<=<' with 'MergingStrategy' knowledge propagation. +(.<=<) :: + (MonadTryMerge m, Mergeable a, Mergeable b, Mergeable c) => + (b -> m c) -> + (a -> m b) -> + a -> + m c +(.<=<) = flip (.>=>) +{-# INLINE (.<=<) #-} + +-- | 'forever' with 'MergingStrategy' knowledge propagation. +mrgForever :: + (Applicative m, TryMerge m, Mergeable b, Mergeable a) => m a -> m b +mrgForever a = let a' = a .*> a' in a' +{-# INLINE mrgForever #-} + +-- | 'join' with 'MergingStrategy' knowledge propagation. +mrgJoin :: (MonadTryMerge m, Mergeable a) => m (m a) -> m a +mrgJoin a = tryMerge $ join a +{-# INLINE mrgJoin #-} + +-- | 'mfilter' with 'MergingStrategy' knowledge propagation. +mrgMfilter :: + (MonadTryMerge m, MonadPlus m, Mergeable a) => + (a -> Bool) -> + m a -> + m a +mrgMfilter p ma = do + a <- tryMerge ma + if p a then mrgReturn a else mrgMzero +{-# INLINE mrgMfilter #-} + +-- | 'mfilter' with 'MergingStrategy' knowledge propagation and symbolic +-- conditions. +symMfilter :: + (MonadTryMerge m, MonadPlus m, MonadUnion m, Mergeable a) => + (a -> SymBool) -> + m a -> + m a +symMfilter p ma = do + a <- tryMerge ma + mrgIf (p a) (mrgReturn a) mrgMzero +{-# INLINE symMfilter #-} + +-- | 'filterM' with 'MergingStrategy' knowledge propagation. +mrgFilterM :: + (TryMerge m, Applicative m, Mergeable a, Foldable t) => + (a -> m Bool) -> + t a -> + m [a] +mrgFilterM p = + foldr + (\x lst -> (\flg -> if flg then (x :) else id) .<$> p x .<*> lst) + (mrgPure []) +{-# INLINE mrgFilterM #-} + +-- | 'filterM' with 'MergingStrategy' knowledge propagation and symbolic +-- conditions. +symFilterM :: + (TryMerge m, MonadUnion m, Mergeable a, Foldable t) => + (a -> m SymBool) -> + t a -> + m [a] +symFilterM p = + foldr + ( \x lst -> do + flag <- tryMerge $ p x + mrgIf flag ((x :) <$> lst) lst + ) + (mrgPure []) +{-# INLINE symFilterM #-} + +-- | 'mapAndUnzipM' with 'MergingStrategy' knowledge propagation. +mrgMapAndUnzipM :: + ( Applicative m, + TryMerge m, + Mergeable b, + Mergeable c + ) => + (a -> m (b, c)) -> + [a] -> + m ([b], [c]) +mrgMapAndUnzipM f xs = mrgUnzip .<$> mrgTraverse f xs +{-# INLINE mrgMapAndUnzipM #-} + +-- | 'zipWithM' with 'MergingStrategy' knowledge propagation. +mrgZipWithM :: + (Applicative m, TryMerge m, Mergeable c) => + (a -> b -> m c) -> + [a] -> + [b] -> + m [c] +mrgZipWithM f xs ys = mrgSequenceA (zipWith f xs ys) +{-# INLINE mrgZipWithM #-} + +-- | 'zipWithM_' with 'MergingStrategy' knowledge propagation. +mrgZipWithM_ :: + (Applicative m, TryMerge m, Mergeable c) => + (a -> b -> m c) -> + [a] -> + [b] -> + m () +mrgZipWithM_ f xs ys = mrgSequenceA_ (zipWith f xs ys) +{-# INLINE mrgZipWithM_ #-} + +-- | 'foldM' with 'MergingStrategy' knowledge propagation. +mrgFoldM :: + (MonadTryMerge m, Mergeable b, Foldable t) => + (b -> a -> m b) -> + b -> + t a -> + m b +mrgFoldM = mrgFoldlM +{-# INLINE mrgFoldM #-} + +-- | 'foldM_' with 'MergingStrategy' knowledge propagation. +mrgFoldM_ :: + (MonadTryMerge m, Foldable t, Mergeable b) => + (b -> a -> m b) -> + b -> + t a -> + m () +mrgFoldM_ f a xs = mrgFoldlM f a xs .>> mrgPure () +{-# INLINE mrgFoldM_ #-} + +-- | 'replicateM' with 'MergingStrategy' knowledge propagation. +mrgReplicateM :: + (Applicative m, TryMerge m, Mergeable a) => + Int -> + m a -> + m [a] +mrgReplicateM n = mrgSequenceA . replicate n +{-# INLINE mrgReplicateM #-} + +-- | 'replicateM' with 'MergingStrategy' knowledge propagation and symbolic +-- number of elements. +symReplicateM :: + (MonadUnion m, TryMerge m, Mergeable a, Num int, SOrd int) => + Int -> + int -> + m a -> + m [a] +symReplicateM maxCnt cnt0 f = + loop maxCnt cnt0 + where + loop concreteCnt cnt = + mrgIf + (cnt .<= 0 .|| concreteCnt .<= 0) + (mrgPure []) + (mrgLiftA2 (:) f (loop (concreteCnt - 1) (cnt - 1))) +{-# INLINE symReplicateM #-} + +-- | 'replicateM_' with 'MergingStrategy' knowledge propagation. +mrgReplicateM_ :: + (Applicative m, TryMerge m, Mergeable a) => + Int -> + m a -> + m () +mrgReplicateM_ n = mrgSequenceA_ . replicate n +{-# INLINE mrgReplicateM_ #-} + +-- | 'replicateM_' with 'MergingStrategy' knowledge propagation and symbolic +-- number of elements. +symReplicateM_ :: + (MonadUnion m, TryMerge m, Mergeable a, Num int, SOrd int) => + Int -> + int -> + m a -> + m () +symReplicateM_ maxCnt cnt0 f = + loop maxCnt cnt0 + where + loop concreteCnt cnt = + mrgIf + (cnt .<= 0 .|| concreteCnt .<= 0) + (mrgPure ()) + (f .*> (loop (concreteCnt - 1) (cnt - 1))) +{-# INLINE symReplicateM_ #-} + +-- | 'guard' with 'MergingStrategy' knowledge propagation. +mrgGuard :: (Alternative m, TryMerge m) => Bool -> m () +mrgGuard True = mrgPure () +mrgGuard False = mrgEmpty +{-# INLINE mrgGuard #-} + +-- | 'guard' with 'MergingStrategy' knowledge propagation and symbolic +-- conditions. +symGuard :: (UnionMergeable1 m, TryMerge m, Alternative m) => SymBool -> m () +symGuard b = mrgIf b (mrgPure ()) mrgEmpty +{-# INLINE symGuard #-} + +-- | 'when' with 'MergingStrategy' knowledge propagation. +mrgWhen :: (Applicative m, TryMerge m) => Bool -> m () -> m () +mrgWhen True a = tryMerge a +mrgWhen False _ = mrgPure () +{-# INLINE mrgWhen #-} + +-- | 'when' with 'MergingStrategy' knowledge propagation and symbolic +-- conditions. +symWhen :: + (Applicative m, TryMerge m, UnionMergeable1 m) => SymBool -> m () -> m () +symWhen b a = mrgIf b a (mrgPure ()) +{-# INLINE symWhen #-} + +-- | 'unless' with 'MergingStrategy' knowledge propagation. +mrgUnless :: (Applicative m, TryMerge m) => Bool -> m () -> m () +mrgUnless b = mrgWhen (not b) +{-# INLINE mrgUnless #-} + +-- | 'unless' with 'MergingStrategy' knowledge propagation and symbolic +-- conditions. +symUnless :: + (Applicative m, TryMerge m, UnionMergeable1 m) => SymBool -> m () -> m () +symUnless b = symWhen (symNot b) +{-# INLINE symUnless #-} + +-- | 'liftM' with 'MergingStrategy' knowledge propagation. +mrgLiftM :: + (MonadTryMerge m, Mergeable a, Mergeable b) => (a -> b) -> m a -> m b +mrgLiftM f a = f .<$> a +{-# INLINE mrgLiftM #-} + +-- | 'liftM2' with 'MergingStrategy' knowledge propagation. +mrgLiftM2 :: + (MonadTryMerge m, Mergeable a, Mergeable b, Mergeable c) => + (a -> b -> c) -> + m a -> + m b -> + m c +mrgLiftM2 f a b = f .<$> a .<*> b +{-# INLINE mrgLiftM2 #-} + +-- | 'liftM3' with 'MergingStrategy' knowledge propagation. +mrgLiftM3 :: + (MonadTryMerge m, Mergeable a, Mergeable b, Mergeable c, Mergeable d) => + (a -> b -> c -> d) -> + m a -> + m b -> + m c -> + m d +mrgLiftM3 f a b c = f .<$> a .<*> b .<*> c +{-# INLINE mrgLiftM3 #-} + +-- | 'liftM4' with 'MergingStrategy' knowledge propagation. +mrgLiftM4 :: + ( MonadTryMerge m, + Mergeable a, + Mergeable b, + Mergeable c, + Mergeable d, + Mergeable e + ) => + (a -> b -> c -> d -> e) -> + m a -> + m b -> + m c -> + m d -> + m e +mrgLiftM4 f a b c d = f .<$> a .<*> b .<*> c .<*> d +{-# INLINE mrgLiftM4 #-} + +-- | 'liftM5' with 'MergingStrategy' knowledge propagation. +mrgLiftM5 :: + ( MonadTryMerge m, + Mergeable a, + Mergeable b, + Mergeable c, + Mergeable d, + Mergeable e, + Mergeable f + ) => + (a -> b -> c -> d -> e -> f) -> + m a -> + m b -> + m c -> + m d -> + m e -> + m f +mrgLiftM5 f a b c d e = f .<$> a .<*> b .<*> c .<*> d .<*> e +{-# INLINE mrgLiftM5 #-} + +-- | '<*>' with 'MergingStrategy' knowledge propagation. +mrgAp :: + (MonadTryMerge m, Mergeable a, Mergeable b) => m (a -> b) -> m a -> m b +mrgAp = (.<*>) +{-# INLINE mrgAp #-} + +infixl 4 .<$!> + +-- | '<$!>' with 'MergingStrategy' knowledge propagation. Merging is always +-- strict so we can directly use '.<$>'. +(.<$!>) :: + (MonadTryMerge m, Mergeable a, Mergeable b) => (a -> b) -> m a -> m b +f .<$!> a = f .<$> a +{-# INLINE (.<$!>) #-} diff --git a/src/Grisette/Lib/Control/Monad.hs-boot b/src/Grisette/Lib/Control/Monad.hs-boot --- a/src/Grisette/Lib/Control/Monad.hs-boot +++ b/src/Grisette/Lib/Control/Monad.hs-boot @@ -10,23 +10,21 @@ (.>>), mrgMzero, mrgMplus, - mrgFmap, ) where import Control.Monad (MonadPlus) -import Grisette.Core.Control.Monad.Union (MonadUnion) -import Grisette.Core.Data.Class.Mergeable +import Grisette.Internal.Core.Data.Class.Mergeable ( Mergeable, MergingStrategy, ) +import Grisette.Internal.Core.Data.Class.TryMerge (MonadTryMerge) -mrgReturnWithStrategy :: (MonadUnion u) => MergingStrategy a -> a -> u a -mrgBindWithStrategy :: (MonadUnion u) => MergingStrategy b -> u a -> (a -> u b) -> u b -mrgReturn :: (MonadUnion u, Mergeable a) => a -> u a -(.>>=) :: (MonadUnion u, Mergeable b) => u a -> (a -> u b) -> u b -mrgFoldM :: (MonadUnion m, Mergeable b, Foldable t) => (b -> a -> m b) -> b -> t a -> m b -(.>>) :: forall m a b. (MonadUnion m, Mergeable b) => m a -> m b -> m b -mrgMzero :: forall m a. (MonadUnion m, Mergeable a, MonadPlus m) => m a -mrgMplus :: forall m a. (MonadUnion m, Mergeable a, MonadPlus m) => m a -> m a -> m a -mrgFmap :: (MonadUnion f, Mergeable b, Functor f) => (a -> b) -> f a -> f b +mrgReturnWithStrategy :: (MonadTryMerge u) => MergingStrategy a -> a -> u a +mrgBindWithStrategy :: (MonadTryMerge u) => MergingStrategy a -> MergingStrategy b -> u a -> (a -> u b) -> u b +mrgReturn :: (MonadTryMerge u, Mergeable a) => a -> u a +(.>>=) :: (MonadTryMerge u, Mergeable a, Mergeable b) => u a -> (a -> u b) -> u b +mrgFoldM :: (MonadTryMerge m, Mergeable b, Foldable t) => (b -> a -> m b) -> b -> t a -> m b +(.>>) :: (MonadTryMerge m, Mergeable a, Mergeable b) => m a -> m b -> m b +mrgMzero :: forall m a. (MonadTryMerge m, Mergeable a, MonadPlus m) => m a +mrgMplus :: forall m a. (MonadTryMerge m, Mergeable a, MonadPlus m) => m a -> m a -> m a diff --git a/src/Grisette/Lib/Control/Monad/Except.hs b/src/Grisette/Lib/Control/Monad/Except.hs --- a/src/Grisette/Lib/Control/Monad/Except.hs +++ b/src/Grisette/Lib/Control/Monad/Except.hs @@ -2,7 +2,7 @@ -- | -- Module : Grisette.Lib.Control.Monad.Except --- Copyright : (c) Sirui Lu 2021-2023 +-- Copyright : (c) Sirui Lu 2021-2024 -- License : BSD-3-Clause (see the LICENSE file) -- -- Maintainer : siruilu@cs.washington.edu @@ -12,24 +12,105 @@ ( -- * mrg* variants for operations in "Control.Monad.Except" mrgThrowError, mrgCatchError, + mrgLiftEither, + mrgTryError, + mrgWithError, + mrgHandleError, + mrgMapError, + mrgModifyError, ) where -import Control.Monad.Except (MonadError (catchError, throwError)) -import Grisette.Core.Control.Monad.Union (MonadUnion) -import Grisette.Core.Data.Class.Mergeable (Mergeable) -import Grisette.Core.Data.Class.SimpleMergeable (merge) +import Control.Monad.Except (ExceptT, MonadError (catchError, throwError)) +import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) +import Grisette.Internal.Core.Data.Class.TryMerge (TryMerge, tryMerge) +import Grisette.Lib.Control.Monad (mrgReturn) +import Grisette.Lib.Control.Monad.Trans.Except (mrgRunExceptT) +import Grisette.Lib.Data.Functor (mrgFmap) --- | 'throwError' with 'MergingStrategy' knowledge propagation. -mrgThrowError :: (MonadError e m, MonadUnion m, Mergeable a) => e -> m a -mrgThrowError = merge . throwError +-- | 'Control.Monad.Except.throwError' with 'MergingStrategy' knowledge +-- propagation. +mrgThrowError :: (MonadError e m, TryMerge m, Mergeable a) => e -> m a +mrgThrowError = tryMerge . throwError {-# INLINE mrgThrowError #-} --- | 'catchError' with 'MergingStrategy' knowledge propagation. +-- | 'Control.Monad.Except.catchError' with 'MergingStrategy' knowledge +-- propagation. mrgCatchError :: - (MonadError e m, MonadUnion m, Mergeable a) => + (MonadError e m, TryMerge m, Mergeable a) => m a -> (e -> m a) -> m a -mrgCatchError v handler = merge $ v `catchError` (merge . handler) +mrgCatchError v handler = tryMerge $ v `catchError` (tryMerge . handler) {-# INLINE mrgCatchError #-} + +-- | 'Control.Monad.Except.liftEither' with 'MergingStrategy' knowledge +-- propagation. +mrgLiftEither :: + (MonadError e m, TryMerge m, Mergeable a, Mergeable e) => Either e a -> m a +mrgLiftEither = either mrgThrowError mrgReturn +{-# INLINE mrgLiftEither #-} + +-- | 'Control.Monad.Except.tryError' with 'MergingStrategy' knowledge +-- propagation. +mrgTryError :: + (MonadError e m, TryMerge m, Mergeable a, Mergeable e) => + m a -> + m (Either e a) +mrgTryError action = (mrgFmap Right action) `mrgCatchError` (mrgReturn . Left) +{-# INLINE mrgTryError #-} + +-- | 'Control.Monad.Except.withError' with 'MergingStrategy' knowledge +-- propagation. +mrgWithError :: + (MonadError e m, TryMerge m, Mergeable a, Mergeable e) => + (e -> e) -> + m a -> + m a +mrgWithError f action = + tryMerge $ mrgTryError action >>= either (mrgThrowError . f) mrgReturn +{-# INLINE mrgWithError #-} + +-- | 'Control.Monad.Except.handleError' with 'MergingStrategy' knowledge +-- propagation. +mrgHandleError :: + (MonadError e m, TryMerge m, Mergeable a, Mergeable e) => + (e -> m a) -> + m a -> + m a +mrgHandleError = flip mrgCatchError +{-# INLINE mrgHandleError #-} + +-- | 'Control.Monad.Except.mapError' with 'MergingStrategy' knowledge +-- propagation. +mrgMapError :: + ( MonadError e m, + TryMerge m, + MonadError e' n, + TryMerge n, + Mergeable a, + Mergeable b, + Mergeable e, + Mergeable e' + ) => + (m (Either e a) -> n (Either e' b)) -> + m a -> + n b +mrgMapError f action = tryMerge (f (mrgTryError action)) >>= mrgLiftEither +{-# INLINE mrgMapError #-} + +-- | 'Control.Monad.Except.modifyError' with 'MergingStrategy' knowledge +-- propagation. +mrgModifyError :: + ( MonadError e' m, + TryMerge m, + Mergeable a, + Mergeable e, + Mergeable e + ) => + (e -> e') -> + ExceptT e m a -> + m a +mrgModifyError f m = + tryMerge $ mrgRunExceptT m >>= either (mrgThrowError . f) mrgReturn +{-# INLINE mrgModifyError #-} diff --git a/src/Grisette/Lib/Control/Monad/State/Class.hs b/src/Grisette/Lib/Control/Monad/State/Class.hs --- a/src/Grisette/Lib/Control/Monad/State/Class.hs +++ b/src/Grisette/Lib/Control/Monad/State/Class.hs @@ -20,29 +20,29 @@ where import Control.Monad.State.Class (MonadState (get, put)) -import Grisette.Core.Data.Class.Mergeable (Mergeable) -import Grisette.Core.Data.Class.SimpleMergeable (UnionLike, merge) +import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) +import Grisette.Internal.Core.Data.Class.TryMerge (TryMerge, tryMerge) import Grisette.Lib.Control.Monad (mrgReturn) -- | 'Control.Monad.State.Class.get' with 'MergingStrategy' knowledge -- propagation. -mrgGet :: (MonadState s m, UnionLike m, Mergeable s) => m s -mrgGet = merge get +mrgGet :: (MonadState s m, TryMerge m, Mergeable s) => m s +mrgGet = tryMerge get {-# INLINE mrgGet #-} -- | 'Control.Monad.State.Class.put' with 'MergingStrategy' knowledge -- propagation. -mrgPut :: (MonadState s m, UnionLike m) => s -> m () -mrgPut = merge . put +mrgPut :: (MonadState s m, TryMerge m) => s -> m () +mrgPut = tryMerge . put {-# INLINE mrgPut #-} -- | 'Control.Monad.State.Class.state' with 'MergingStrategy' knowledge -- propagation. mrgState :: - (MonadState s m, UnionLike m, Mergeable s, Mergeable a) => + (MonadState s m, TryMerge m, Mergeable s, Mergeable a) => (s -> (a, s)) -> m a -mrgState f = do +mrgState f = tryMerge $ do s <- mrgGet let ~(a, s') = f s mrgPut s' @@ -50,13 +50,13 @@ -- | 'Control.Monad.State.Class.modify' with 'MergingStrategy' knowledge -- propagation. -mrgModify :: (MonadState s m, UnionLike m, Mergeable s) => (s -> s) -> m () +mrgModify :: (MonadState s m, TryMerge m, Mergeable s) => (s -> s) -> m () mrgModify f = mrgState (\s -> ((), f s)) {-# INLINE mrgModify #-} -- | 'Control.Monad.State.Class.modify'' with 'MergingStrategy' knowledge -- propagation. -mrgModify' :: (MonadState s m, UnionLike m, Mergeable s) => (s -> s) -> m () +mrgModify' :: (MonadState s m, TryMerge m, Mergeable s) => (s -> s) -> m () mrgModify' f = do s' <- mrgGet mrgPut $! f s' @@ -65,7 +65,7 @@ -- | 'Control.Monad.State.Class.gets' with 'MergingStrategy' knowledge -- propagation. mrgGets :: - (MonadState s m, UnionLike m, Mergeable s, Mergeable a) => + (MonadState s m, TryMerge m, Mergeable s, Mergeable a) => (s -> a) -> m a mrgGets f = do diff --git a/src/Grisette/Lib/Control/Monad/Trans/Class.hs b/src/Grisette/Lib/Control/Monad/Trans/Class.hs --- a/src/Grisette/Lib/Control/Monad/Trans/Class.hs +++ b/src/Grisette/Lib/Control/Monad/Trans/Class.hs @@ -17,15 +17,14 @@ where import Control.Monad.Trans (MonadTrans (lift)) -import Grisette.Core.Control.Monad.Union (MonadUnion) -import Grisette.Core.Data.Class.Mergeable (Mergeable) -import Grisette.Core.Data.Class.SimpleMergeable (merge) +import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) +import Grisette.Internal.Core.Data.Class.TryMerge (TryMerge, tryMerge) -- | 'lift' with 'MergingStrategy' knowledge propagation. mrgLift :: forall t m a. - (MonadUnion (t m), MonadTrans t, Monad m, Mergeable a) => + (TryMerge (t m), MonadTrans t, Monad m, Mergeable a) => m a -> t m a -mrgLift v = merge $ lift v +mrgLift v = tryMerge $ lift v {-# INLINE mrgLift #-} diff --git a/src/Grisette/Lib/Control/Monad/Trans/Cont.hs b/src/Grisette/Lib/Control/Monad/Trans/Cont.hs --- a/src/Grisette/Lib/Control/Monad/Trans/Cont.hs +++ b/src/Grisette/Lib/Control/Monad/Trans/Cont.hs @@ -18,24 +18,27 @@ import Control.Monad.Cont (ContT (runContT)) import Control.Monad.Trans.Class (lift) -import Grisette.Core.Data.Class.Mergeable (Mergeable) -import Grisette.Core.Data.Class.SimpleMergeable - ( UnionLike, - merge, +import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) +import Grisette.Internal.Core.Data.Class.TryMerge + ( TryMerge, + tryMerge, ) import Grisette.Lib.Control.Monad (mrgReturn) -- | 'Control.Monad.Cont.runContT' with 'MergingStrategy' knowledge propagation -mrgRunContT :: (UnionLike m, Mergeable r) => ContT r m a -> (a -> m r) -> m r -mrgRunContT c = merge . runContT c +mrgRunContT :: (TryMerge m, Mergeable r) => ContT r m a -> (a -> m r) -> m r +mrgRunContT c = tryMerge . runContT c {-# INLINE mrgRunContT #-} -- | 'Control.Monad.Cont.evalContT' with 'MergingStrategy' knowledge propagation -mrgEvalContT :: (UnionLike m, Mergeable r, Monad m) => ContT r m r -> m r +mrgEvalContT :: (TryMerge m, Mergeable r, Monad m) => ContT r m r -> m r mrgEvalContT c = runContT c mrgReturn {-# INLINE mrgEvalContT #-} -- | 'Control.Monad.Cont.resetT' with 'MergingStrategy' knowledge propagation -mrgResetT :: (UnionLike m, Mergeable r, Monad m) => (Monad m) => ContT r m r -> ContT r' m r +mrgResetT :: + (TryMerge m, Mergeable r, Monad m) => + ContT r m r -> + ContT r' m r mrgResetT = lift . mrgEvalContT {-# INLINE mrgResetT #-} diff --git a/src/Grisette/Lib/Control/Monad/Trans/Except.hs b/src/Grisette/Lib/Control/Monad/Trans/Except.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Lib/Control/Monad/Trans/Except.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE Trustworthy #-} + +-- | +-- Module : Grisette.Lib.Control.Monad.Trans.Except +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Lib.Control.Monad.Trans.Except + ( mrgExcept, + mrgRunExceptT, + mrgWithExceptT, + mrgThrowE, + mrgCatchE, + ) +where + +import Control.Monad.Trans.Except + ( ExceptT, + catchE, + except, + runExceptT, + throwE, + withExceptT, + ) +import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) +import Grisette.Internal.Core.Data.Class.TryMerge (MonadTryMerge, tryMerge) + +-- | 'Control.Monad.Trans.Except.except' with 'MergingStrategy' knowledge +-- propagation. +mrgExcept :: + (MonadTryMerge m, Mergeable e, Mergeable a) => Either e a -> ExceptT e m a +mrgExcept = tryMerge . except +{-# INLINE mrgExcept #-} + +-- | 'Control.Monad.Trans.Except.runExceptT' with 'MergingStrategy' knowledge +-- propagation. +mrgRunExceptT :: + (MonadTryMerge m, Mergeable e, Mergeable a) => ExceptT e m a -> m (Either e a) +mrgRunExceptT = tryMerge . runExceptT +{-# INLINE mrgRunExceptT #-} + +-- | 'Control.Monad.Trans.Except.withExceptT' with 'MergingStrategy' knowledge +-- propagation. +mrgWithExceptT :: + (MonadTryMerge m, Mergeable a, Mergeable e, Mergeable e') => + (e -> e') -> + ExceptT e m a -> + ExceptT e' m a +mrgWithExceptT f e = tryMerge $ withExceptT f (tryMerge e) +{-# INLINE mrgWithExceptT #-} + +-- | 'Control.Monad.Trans.Except.throwE' with 'MergingStrategy' knowledge +-- propagation. +mrgThrowE :: (MonadTryMerge m, Mergeable e, Mergeable a) => e -> ExceptT e m a +mrgThrowE = tryMerge . throwE +{-# INLINE mrgThrowE #-} + +-- | 'Control.Monad.Trans.Except.catchE' with 'MergingStrategy' knowledge +-- propagation. +mrgCatchE :: + (MonadTryMerge m, Mergeable e, Mergeable a) => + ExceptT e m a -> + (e -> ExceptT e m a) -> + ExceptT e m a +mrgCatchE value handler = + tryMerge $ catchE (tryMerge value) (tryMerge . handler) +{-# INLINE mrgCatchE #-} diff --git a/src/Grisette/Lib/Control/Monad/Trans/State/Lazy.hs b/src/Grisette/Lib/Control/Monad/Trans/State/Lazy.hs --- a/src/Grisette/Lib/Control/Monad/Trans/State/Lazy.hs +++ b/src/Grisette/Lib/Control/Monad/Trans/State/Lazy.hs @@ -28,14 +28,14 @@ ( StateT (StateT), runStateT, ) -import Grisette.Core.Data.Class.Mergeable (Mergeable) -import Grisette.Core.Data.Class.SimpleMergeable (UnionLike, merge) +import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) +import Grisette.Internal.Core.Data.Class.TryMerge (TryMerge, tryMerge) import Grisette.Lib.Control.Monad (mrgReturn) -- | 'Control.Monad.Trans.State.Lazy.state' with 'MergingStrategy' knowledge -- propagation. mrgState :: - (Monad m, UnionLike m, Mergeable s, Mergeable a) => + (Monad m, TryMerge m, Mergeable s, Mergeable a) => (s -> (a, s)) -> StateT s m a mrgState f = StateT (mrgReturn . f) @@ -44,78 +44,78 @@ -- | 'Control.Monad.Trans.State.Lazy.runStateT' with 'MergingStrategy' knowledge -- propagation. mrgRunStateT :: - (Monad m, UnionLike m, Mergeable s, Mergeable a) => + (Monad m, TryMerge m, Mergeable s, Mergeable a) => StateT s m a -> s -> m (a, s) -mrgRunStateT m s = runStateT m s >>= mrgReturn +mrgRunStateT m s = tryMerge $ runStateT m s {-# INLINE mrgRunStateT #-} -- | 'Control.Monad.Trans.State.Lazy.evalStateT' with 'MergingStrategy' -- knowledge propagation. mrgEvalStateT :: - (Monad m, UnionLike m, Mergeable a) => + (Monad m, TryMerge m, Mergeable a) => StateT s m a -> s -> m a -mrgEvalStateT m s = do +mrgEvalStateT m s = tryMerge $ do ~(a, _) <- runStateT m s - mrgReturn a + return a {-# INLINE mrgEvalStateT #-} -- | 'Control.Monad.Trans.State.Lazy.execStateT' with 'MergingStrategy' -- knowledge propagation. mrgExecStateT :: - (Monad m, UnionLike m, Mergeable s) => + (Monad m, TryMerge m, Mergeable s) => StateT s m a -> s -> m s -mrgExecStateT m s = do +mrgExecStateT m s = tryMerge $ do ~(_, s') <- runStateT m s - mrgReturn s' + return s' {-# INLINE mrgExecStateT #-} -- | 'Control.Monad.Trans.State.Lazy.mapStateT' with 'MergingStrategy' knowledge -- propagation. mrgMapStateT :: - (UnionLike n, Mergeable b, Mergeable s) => + (TryMerge n, Mergeable b, Mergeable s) => (m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b -mrgMapStateT f m = StateT $ merge . f . runStateT m +mrgMapStateT f m = StateT $ tryMerge . f . runStateT m {-# INLINE mrgMapStateT #-} -- | 'Control.Monad.Trans.State.Lazy.withStateT' with 'MergingStrategy' -- knowledge propagation. mrgWithStateT :: - (UnionLike m, Mergeable s, Mergeable a) => + (TryMerge m, Mergeable s, Mergeable a) => (s -> s) -> StateT s m a -> StateT s m a -mrgWithStateT f m = StateT $ merge . runStateT m . f +mrgWithStateT f m = StateT $ tryMerge . runStateT m . f {-# INLINE mrgWithStateT #-} -- | 'Control.Monad.Trans.State.Lazy.get' with 'MergingStrategy' knowledge -- propagation. -mrgGet :: (Monad m, UnionLike m, Mergeable s) => StateT s m s +mrgGet :: (Monad m, TryMerge m, Mergeable s) => StateT s m s mrgGet = mrgState (\s -> (s, s)) {-# INLINE mrgGet #-} -- | 'Control.Monad.Trans.State.Lazy.put' with 'MergingStrategy' knowledge -- propagation. -mrgPut :: (Monad m, UnionLike m, Mergeable s) => s -> StateT s m () +mrgPut :: (Monad m, TryMerge m, Mergeable s) => s -> StateT s m () mrgPut s = mrgState (const ((), s)) {-# INLINE mrgPut #-} -- | 'Control.Monad.Trans.State.Lazy.modify' with 'MergingStrategy' knowledge -- propagation. -mrgModify :: (Monad m, UnionLike m, Mergeable s) => (s -> s) -> StateT s m () +mrgModify :: (Monad m, TryMerge m, Mergeable s) => (s -> s) -> StateT s m () mrgModify f = mrgState (\s -> ((), f s)) {-# INLINE mrgModify #-} -- | 'Control.Monad.Trans.State.Lazy.modify'' with 'MergingStrategy' knowledge -- propagation. -mrgModify' :: (Monad m, UnionLike m, Mergeable s) => (s -> s) -> StateT s m () +mrgModify' :: (Monad m, TryMerge m, Mergeable s) => (s -> s) -> StateT s m () mrgModify' f = do s <- mrgGet mrgPut $! f s @@ -124,7 +124,7 @@ -- | 'Control.Monad.Trans.State.Lazy.gets' with 'MergingStrategy' knowledge -- propagation. mrgGets :: - (Monad m, UnionLike m, Mergeable s, Mergeable a) => + (Monad m, TryMerge m, Mergeable s, Mergeable a) => (s -> a) -> StateT s m a mrgGets f = mrgState $ \s -> (f s, s) diff --git a/src/Grisette/Lib/Control/Monad/Trans/State/Strict.hs b/src/Grisette/Lib/Control/Monad/Trans/State/Strict.hs --- a/src/Grisette/Lib/Control/Monad/Trans/State/Strict.hs +++ b/src/Grisette/Lib/Control/Monad/Trans/State/Strict.hs @@ -28,14 +28,14 @@ ( StateT (StateT), runStateT, ) -import Grisette.Core.Data.Class.Mergeable (Mergeable) -import Grisette.Core.Data.Class.SimpleMergeable (UnionLike, merge) +import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) +import Grisette.Internal.Core.Data.Class.TryMerge (TryMerge, tryMerge) import Grisette.Lib.Control.Monad (mrgReturn) -- | 'Control.Monad.Trans.State.Strict.state' with 'MergingStrategy' knowledge -- propagation. mrgState :: - (Monad m, UnionLike m, Mergeable s, Mergeable a) => + (Monad m, TryMerge m, Mergeable s, Mergeable a) => (s -> (a, s)) -> StateT s m a mrgState f = StateT (mrgReturn . f) @@ -44,78 +44,78 @@ -- | 'Control.Monad.Trans.State.Strict.runStateT' with 'MergingStrategy' -- knowledge propagation. mrgRunStateT :: - (Monad m, UnionLike m, Mergeable s, Mergeable a) => + (Monad m, TryMerge m, Mergeable s, Mergeable a) => StateT s m a -> s -> m (a, s) -mrgRunStateT m s = runStateT m s >>= mrgReturn +mrgRunStateT m s = tryMerge $ runStateT m s {-# INLINE mrgRunStateT #-} -- | 'Control.Monad.Trans.State.Strict.evalStateT' with 'MergingStrategy' -- knowledge propagation. mrgEvalStateT :: - (Monad m, UnionLike m, Mergeable a) => + (Monad m, TryMerge m, Mergeable a) => StateT s m a -> s -> m a -mrgEvalStateT m s = do +mrgEvalStateT m s = tryMerge $ do (a, _) <- runStateT m s - mrgReturn a + return a {-# INLINE mrgEvalStateT #-} -- | 'Control.Monad.Trans.State.Strict.execStateT' with 'MergingStrategy' -- knowledge propagation. mrgExecStateT :: - (Monad m, UnionLike m, Mergeable s) => + (Monad m, TryMerge m, Mergeable s) => StateT s m a -> s -> m s -mrgExecStateT m s = do +mrgExecStateT m s = tryMerge $ do (_, s') <- runStateT m s - mrgReturn s' + return s' {-# INLINE mrgExecStateT #-} -- | 'Control.Monad.Trans.State.Strict.mapStateT' with 'MergingStrategy' -- knowledge propagation. mrgMapStateT :: - (UnionLike n, Mergeable b, Mergeable s) => + (TryMerge n, Mergeable b, Mergeable s) => (m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b -mrgMapStateT f m = StateT $ merge . f . runStateT m +mrgMapStateT f m = StateT $ tryMerge . f . runStateT m {-# INLINE mrgMapStateT #-} -- | 'Control.Monad.Trans.State.Strict.withStateT' with 'MergingStrategy' -- knowledge propagation. mrgWithStateT :: - (UnionLike m, Mergeable s, Mergeable a) => + (TryMerge m, Mergeable s, Mergeable a) => (s -> s) -> StateT s m a -> StateT s m a -mrgWithStateT f m = StateT $ merge . runStateT m . f +mrgWithStateT f m = StateT $ tryMerge . runStateT m . f {-# INLINE mrgWithStateT #-} -- | 'Control.Monad.Trans.State.Strict.get' with 'MergingStrategy' knowledge -- propagation. -mrgGet :: (Monad m, UnionLike m, Mergeable s) => StateT s m s +mrgGet :: (Monad m, TryMerge m, Mergeable s) => StateT s m s mrgGet = mrgState (\s -> (s, s)) {-# INLINE mrgGet #-} -- | 'Control.Monad.Trans.State.Strict.put' with 'MergingStrategy' knowledge -- propagation. -mrgPut :: (Monad m, UnionLike m, Mergeable s) => s -> StateT s m () +mrgPut :: (Monad m, TryMerge m, Mergeable s) => s -> StateT s m () mrgPut s = mrgState (const ((), s)) {-# INLINE mrgPut #-} -- | 'Control.Monad.Trans.State.Strict.modify' with 'MergingStrategy' knowledge -- propagation. -mrgModify :: (Monad m, UnionLike m, Mergeable s) => (s -> s) -> StateT s m () +mrgModify :: (Monad m, TryMerge m, Mergeable s) => (s -> s) -> StateT s m () mrgModify f = mrgState (\s -> ((), f s)) {-# INLINE mrgModify #-} -- | 'Control.Monad.Trans.State.Strict.modify'' with 'MergingStrategy' knowledge -- propagation. -mrgModify' :: (Monad m, UnionLike m, Mergeable s) => (s -> s) -> StateT s m () +mrgModify' :: (Monad m, TryMerge m, Mergeable s) => (s -> s) -> StateT s m () mrgModify' f = do s <- mrgGet mrgPut $! f s @@ -124,7 +124,7 @@ -- | 'Control.Monad.Trans.State.Strict.gets' with 'MergingStrategy' knowledge -- propagation. mrgGets :: - (Monad m, UnionLike m, Mergeable s, Mergeable a) => + (Monad m, TryMerge m, Mergeable s, Mergeable a) => (s -> a) -> StateT s m a mrgGets f = mrgState $ \s -> (f s, s) diff --git a/src/Grisette/Lib/Data/Bool.hs b/src/Grisette/Lib/Data/Bool.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Lib/Data/Bool.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE TemplateHaskell #-} + +module Grisette.Lib.Data.Bool (mrgTrue, mrgFalse) where + +import Grisette.Internal.Core.Data.Class.TryMerge (mrgSingle) +import Grisette.Internal.Core.TH.MergeConstructor + ( mkMergeConstructor, + ) + +mkMergeConstructor "mrg" ''Bool diff --git a/src/Grisette/Lib/Data/Either.hs b/src/Grisette/Lib/Data/Either.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Lib/Data/Either.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE TemplateHaskell #-} + +module Grisette.Lib.Data.Either (mrgLeft, mrgRight) where + +import Grisette.Internal.Core.Data.Class.TryMerge (mrgSingle) +import Grisette.Internal.Core.TH.MergeConstructor + ( mkMergeConstructor, + ) + +mkMergeConstructor "mrg" ''Either diff --git a/src/Grisette/Lib/Data/Foldable.hs b/src/Grisette/Lib/Data/Foldable.hs --- a/src/Grisette/Lib/Data/Foldable.hs +++ b/src/Grisette/Lib/Data/Foldable.hs @@ -1,81 +1,309 @@ {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Trustworthy #-} -- | -- Module : Grisette.Lib.Control.Foldable --- Copyright : (c) Sirui Lu 2021-2023 +-- Copyright : (c) Sirui Lu 2021-2024 -- License : BSD-3-Clause (see the LICENSE file) -- -- Maintainer : siruilu@cs.washington.edu -- Stability : Experimental -- Portability : GHC only module Grisette.Lib.Data.Foldable - ( -- * mrg* variants for operations in "Data.Foldable" - mrgFoldlM, + ( symElem, + symMaximum, + mrgMaximum, + symMinimum, + mrgMinimum, + + -- * Special biased folds mrgFoldrM, + mrgFoldlM, + + -- * Folding actions + + -- ** Applicative actions mrgTraverse_, mrgFor_, + mrgSequenceA_, + mrgAsum, + + -- ** Monadic actions mrgMapM_, mrgForM_, mrgSequence_, mrgMsum, + + -- ** Specialized folds + symAnd, + symOr, + symAny, + symAll, + symMaximumBy, + mrgMaximumBy, + symMinimumBy, + mrgMinimumBy, + + -- ** Searches + symNotElem, + mrgFind, ) where import Control.Monad (MonadPlus) -import Grisette.Core.Control.Monad.Union (MonadUnion) -import Grisette.Core.Data.Class.Mergeable (Mergeable) -import Grisette.Core.Data.Class.SimpleMergeable (merge) +import Data.Foldable (Foldable (foldl')) +import Grisette.Internal.Core.Control.Monad.Union (MonadUnion) +import Grisette.Internal.Core.Control.Monad.UnionM (UnionM, liftUnionM) +import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp) +import Grisette.Internal.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.&&), (.||))) +import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) +import Grisette.Internal.Core.Data.Class.PlainUnion (symIteMerge) +import Grisette.Internal.Core.Data.Class.SEq (SEq ((.==))) +import Grisette.Internal.Core.Data.Class.SOrd (SOrd, mrgMax, mrgMin) +import Grisette.Internal.Core.Data.Class.SimpleMergeable (mrgIf) +import Grisette.Internal.Core.Data.Class.Solvable (Solvable (con)) +import Grisette.Internal.Core.Data.Class.TryMerge + ( MonadTryMerge, + TryMerge, + tryMerge, + ) +import Grisette.Internal.SymPrim.SymBool (SymBool) +import Grisette.Lib.Control.Applicative (mrgAsum, mrgPure, (.*>)) import {-# SOURCE #-} Grisette.Lib.Control.Monad ( mrgMplus, mrgMzero, mrgReturn, + (.>>), ) +import Grisette.Lib.Data.Functor (mrgFmap, mrgVoid) --- | 'Data.Foldable.foldlM' with 'MergingStrategy' knowledge propagation. -mrgFoldlM :: (MonadUnion m, Mergeable b, Foldable t) => (b -> a -> m b) -> b -> t a -> m b -mrgFoldlM f z0 xs = foldr c mrgReturn xs z0 +-- | 'Data.Foldable.elem' with symbolic equality. +symElem :: (Foldable t, SEq a) => a -> t a -> SymBool +symElem x = symAny ((.== x)) +{-# INLINE symElem #-} + +-- | 'Data.Foldable.maximum' with 'MergingStrategy' knowledge propagation. +mrgMaximum :: + forall a t m. + (Foldable t, MonadUnion m, Mergeable a, SOrd a) => + t a -> + m a +mrgMaximum l = do + r <- mrgFoldlM symMax' (Nothing :: Maybe a) l + case r of + Nothing -> errorWithoutStackTrace "mrgMaximum: empty structure" + Just x -> mrgReturn x where - c x k z = merge (f z x) >>= k -{-# INLINE mrgFoldlM #-} + symMax' :: Maybe a -> a -> m (Maybe a) + symMax' mx y = + case mx of + Nothing -> mrgReturn $ Just y + Just x -> mrgFmap Just $ mrgMax x y +-- | 'Data.Foldable.maximum' with result merged with 'ITEOp'. +symMaximum :: + forall a t. + (Foldable t, Mergeable a, SOrd a, ITEOp a) => + t a -> + a +symMaximum l = symIteMerge (mrgMaximum l :: UnionM a) +{-# INLINE symMaximum #-} + +-- | 'Data.Foldable.minimum' with 'MergingStrategy' knowledge propagation. +mrgMinimum :: + forall a t m. + (Foldable t, MonadUnion m, Mergeable a, SOrd a) => + t a -> + m a +mrgMinimum l = do + r <- mrgFoldlM symMin' (Nothing :: Maybe a) l + case r of + Nothing -> errorWithoutStackTrace "mrgMinimum: empty structure" + Just x -> mrgReturn x + where + symMin' :: Maybe a -> a -> m (Maybe a) + symMin' mx y = + case mx of + Nothing -> mrgReturn $ Just y + Just x -> mrgFmap Just $ mrgMin x y + +-- | 'Data.Foldable.minimum' with result merged with 'ITEOp'. +symMinimum :: + forall a t. + (Foldable t, Mergeable a, SOrd a, ITEOp a) => + t a -> + a +symMinimum l = symIteMerge (mrgMinimum l :: UnionM a) +{-# INLINE symMinimum #-} + -- | 'Data.Foldable.foldrM' with 'MergingStrategy' knowledge propagation. -mrgFoldrM :: (MonadUnion m, Mergeable b, Foldable t) => (a -> b -> m b) -> b -> t a -> m b -mrgFoldrM f z0 xs = foldl c mrgReturn xs z0 +mrgFoldrM :: + (MonadTryMerge m, Mergeable b, Foldable t) => + (a -> b -> m b) -> + b -> + t a -> + m b +mrgFoldrM f z0 xs = foldl c mrgPure xs z0 where - c k x z = merge (f x z) >>= k + c k x z = tryMerge (f x z) >>= k {-# INLINE mrgFoldrM #-} +-- | 'Data.Foldable.foldlM' with 'MergingStrategy' knowledge propagation. +mrgFoldlM :: + (MonadTryMerge m, Mergeable b, Foldable t) => + (b -> a -> m b) -> + b -> + t a -> + m b +mrgFoldlM f z0 xs = foldr c mrgPure xs z0 + where + c x k z = tryMerge (f z x) >>= k +{-# INLINE mrgFoldlM #-} + -- | 'Data.Foldable.traverse_' with 'MergingStrategy' knowledge propagation. -mrgTraverse_ :: (MonadUnion m, Foldable t) => (a -> m b) -> t a -> m () -mrgTraverse_ f = foldr c (mrgReturn ()) +mrgTraverse_ :: + (Applicative m, TryMerge m, Foldable t) => (a -> m b) -> t a -> m () +mrgTraverse_ f = foldr c (mrgPure ()) where - c x k = f x >> k + c x k = mrgVoid (f x) .*> k {-# INLINE mrgTraverse_ #-} -- | 'Data.Foldable.for_' with 'MergingStrategy' knowledge propagation. -mrgFor_ :: (MonadUnion m, Foldable t) => t a -> (a -> m b) -> m () +mrgFor_ :: + (Applicative m, TryMerge m, Foldable t) => t a -> (a -> m b) -> m () mrgFor_ = flip mrgTraverse_ {-# INLINE mrgFor_ #-} +-- | 'Data.Foldable.sequence_' with 'MergingStrategy' knowledge propagation. +mrgSequenceA_ :: + (Foldable t, TryMerge m, Applicative m) => t (m a) -> m () +mrgSequenceA_ = foldr c (mrgPure ()) + where + c m k = mrgVoid m .*> k +{-# INLINE mrgSequenceA_ #-} + -- | 'Data.Foldable.mapM_' with 'MergingStrategy' knowledge propagation. -mrgMapM_ :: (MonadUnion m, Foldable t) => (a -> m b) -> t a -> m () +mrgMapM_ :: (MonadTryMerge m, Foldable t) => (a -> m b) -> t a -> m () mrgMapM_ = mrgTraverse_ {-# INLINE mrgMapM_ #-} -- | 'Data.Foldable.forM_' with 'MergingStrategy' knowledge propagation. -mrgForM_ :: (MonadUnion m, Foldable t) => t a -> (a -> m b) -> m () +mrgForM_ :: (MonadTryMerge m, Foldable t) => t a -> (a -> m b) -> m () mrgForM_ = flip mrgMapM_ {-# INLINE mrgForM_ #-} -- | 'Data.Foldable.sequence_' with 'MergingStrategy' knowledge propagation. -mrgSequence_ :: (Foldable t, MonadUnion m) => t (m a) -> m () -mrgSequence_ = foldr c (mrgReturn ()) +mrgSequence_ :: (Foldable t, MonadTryMerge m) => t (m a) -> m () +mrgSequence_ = foldr c (mrgPure ()) where - c m k = m >> k + c m k = mrgVoid m .>> k {-# INLINE mrgSequence_ #-} -- | 'Data.Foldable.msum' with 'MergingStrategy' knowledge propagation. -mrgMsum :: forall m a t. (MonadUnion m, Mergeable a, MonadPlus m, Foldable t) => t (m a) -> m a +mrgMsum :: + (MonadTryMerge m, Mergeable a, MonadPlus m, Foldable t) => t (m a) -> m a mrgMsum = foldr mrgMplus mrgMzero {-# INLINE mrgMsum #-} + +-- | 'Data.Foldable.and' on symbolic boolean. +symAnd :: (Foldable t) => t SymBool -> SymBool +symAnd = foldl' (.&&) (con True) + +-- | 'Data.Foldable.or' on symbolic boolean. +symOr :: (Foldable t) => t SymBool -> SymBool +symOr = foldl' (.||) (con False) + +-- | 'Data.Foldable.any' on symbolic boolean. +symAny :: (Foldable t) => (a -> SymBool) -> t a -> SymBool +symAny f = foldl' (\acc v -> acc .|| f v) (con False) + +-- | 'Data.Foldable.all' on symbolic boolean. +symAll :: (Foldable t) => (a -> SymBool) -> t a -> SymBool +symAll f = foldl' (\acc v -> acc .&& f v) (con True) + +-- | 'Data.Foldable.maximumBy' with 'MergingStrategy' knowledge propagation. +mrgMaximumBy :: + forall t a m. + (Foldable t, Mergeable a, MonadUnion m) => + (a -> a -> UnionM Ordering) -> + t a -> + m a +mrgMaximumBy cmp l = do + r <- mrgFoldlM symMax' (Nothing :: Maybe a) l + case r of + Nothing -> errorWithoutStackTrace "mrgMaximumBy: empty structure" + Just x -> mrgReturn x + where + symMax' :: Maybe a -> a -> m (Maybe a) + symMax' mx y = + case mx of + Nothing -> mrgReturn $ Just y + Just x -> do + cmpRes <- liftUnionM $ cmp x y + case cmpRes of + GT -> mrgReturn $ Just x + _ -> mrgReturn $ Just y + +-- | 'Data.Foldable.maximumBy' with result merged with 'ITEOp'. +symMaximumBy :: + forall t a. + (Foldable t, Mergeable a, ITEOp a) => + (a -> a -> UnionM Ordering) -> + t a -> + a +symMaximumBy cmp l = symIteMerge (mrgMaximumBy cmp l :: UnionM a) +{-# INLINE symMaximumBy #-} + +-- | 'Data.Foldable.minimumBy' with 'MergingStrategy' knowledge propagation. +mrgMinimumBy :: + forall t a m. + (Foldable t, Mergeable a, MonadUnion m) => + (a -> a -> UnionM Ordering) -> + t a -> + m a +mrgMinimumBy cmp l = do + r <- mrgFoldlM symMin' (Nothing :: Maybe a) l + case r of + Nothing -> errorWithoutStackTrace "mrgMinimumBy: empty structure" + Just x -> mrgReturn x + where + symMin' :: Maybe a -> a -> m (Maybe a) + symMin' mx y = + case mx of + Nothing -> mrgReturn $ Just y + Just x -> do + cmpRes <- liftUnionM $ cmp x y + case cmpRes of + GT -> mrgReturn $ Just y + _ -> mrgReturn $ Just x + +-- | 'Data.Foldable.minimumBy' with result merged with 'ITEOp'. +symMinimumBy :: + forall t a. + (Foldable t, Mergeable a, ITEOp a) => + (a -> a -> UnionM Ordering) -> + t a -> + a +symMinimumBy cmp l = symIteMerge (mrgMinimumBy cmp l :: UnionM a) +{-# INLINE symMinimumBy #-} + +-- | 'Data.Foldable.elem' with symbolic equality. +symNotElem :: (Foldable t, SEq a) => a -> t a -> SymBool +symNotElem x = symNot . symElem x +{-# INLINE symNotElem #-} + +-- | 'Data.Foldable.elem' with symbolic equality and 'MergingStrategy' knowledge +-- propagation. +mrgFind :: + (Foldable t, MonadUnion m, Mergeable a) => + (a -> SymBool) -> + t a -> + m (Maybe a) +mrgFind f = mrgFoldlM fst (Nothing :: Maybe a) + where + fst acc v = do + case acc of + Just _ -> mrgPure acc + Nothing -> do + mrgIf (f v) (mrgPure $ Just v) (mrgPure Nothing) diff --git a/src/Grisette/Lib/Data/Functor.hs b/src/Grisette/Lib/Data/Functor.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Lib/Data/Functor.hs @@ -0,0 +1,79 @@ +-- | +-- Module : Grisette.Lib.Control.Functor +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Lib.Data.Functor + ( mrgFmap, + (.<$), + (.$>), + (.<$>), + (.<&>), + mrgUnzip, + mrgVoid, + ) +where + +import Control.Monad (void) +import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) +import Grisette.Internal.Core.Data.Class.TryMerge (TryMerge, tryMerge) + +-- | 'fmap' with 'MergingStrategy' knowledge propagation. +mrgFmap :: + (TryMerge f, Mergeable a, Mergeable b, Functor f) => + (a -> b) -> + f a -> + f b +mrgFmap f a = tryMerge $ fmap f (tryMerge a) +{-# INLINE mrgFmap #-} + +infixl 4 .<$> + +-- | '<$>' with 'MergingStrategy' knowledge propagation. +(.<$>) :: + (TryMerge f, Mergeable a, Mergeable b, Functor f) => (a -> b) -> f a -> f b +(.<$>) = mrgFmap +{-# INLINE (.<$>) #-} + +infixl 4 .<$ + +-- | '<$' with 'MergingStrategy' knowledge propagation. +(.<$) :: (TryMerge f, Mergeable a, Mergeable b, Functor f) => b -> f a -> f b +(.<$) v f = tryMerge $ v <$ tryMerge f +{-# INLINE (.<$) #-} + +infixl 4 .$> + +-- | '$>' with 'MergingStrategy' knowledge propagation. +(.$>) :: (TryMerge f, Mergeable a, Mergeable b, Functor f) => f a -> b -> f b +(.$>) = flip (.<$) +{-# INLINE (.$>) #-} + +infixl 1 .<&> + +-- | '<&>' with 'MergingStrategy' knowledge propagation. +(.<&>) :: + (TryMerge f, Mergeable a, Mergeable b, Functor f) => + f a -> + (a -> b) -> + f b +(.<&>) = flip mrgFmap +{-# INLINE (.<&>) #-} + +-- | 'unzip' with 'MergingStrategy' knowledge propagation. +mrgUnzip :: + (TryMerge f, Mergeable a, Mergeable b, Functor f) => + f (a, b) -> + (f a, f b) +mrgUnzip ab = + let mergedAb = tryMerge ab + in (fst .<$> mergedAb, snd .<$> mergedAb) +{-# INLINE mrgUnzip #-} + +-- | 'void' with 'MergingStrategy' knowledge propagation. +mrgVoid :: (TryMerge f, Functor f) => f a -> f () +mrgVoid x = tryMerge $ void x +{-# INLINE mrgVoid #-} diff --git a/src/Grisette/Lib/Data/Functor/Sum.hs b/src/Grisette/Lib/Data/Functor/Sum.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Lib/Data/Functor/Sum.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TemplateHaskell #-} + +module Grisette.Lib.Data.Functor.Sum (mrgInR, mrgInL) where + +import Data.Functor.Sum (Sum) +import Grisette.Internal.Core.Data.Class.TryMerge (mrgSingle) +import Grisette.Internal.Core.TH.MergeConstructor + ( mkMergeConstructor, + ) + +mkMergeConstructor "mrg" ''Sum diff --git a/src/Grisette/Lib/Data/List.hs b/src/Grisette/Lib/Data/List.hs --- a/src/Grisette/Lib/Data/List.hs +++ b/src/Grisette/Lib/Data/List.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | -- Module : Grisette.Lib.Data.List @@ -9,59 +10,602 @@ -- Stability : Experimental -- Portability : GHC only module Grisette.Lib.Data.List - ( -- * Symbolic versions of 'Data.List' operations - (.!!), - symFilter, - symTake, - symDrop, + ( -- * Special folds + symAnd, + symOr, + symAny, + symAll, + mrgMaximum, + symMaximum, + mrgMinimum, + symMinimum, + + -- * Sublists + + -- ** Extracting sublists + mrgTake, + mrgDrop, + mrgSplitAt, + mrgTakeWhile, + mrgDropWhile, + mrgDropWhileEnd, + mrgSpan, + mrgBreak, + mrgStripPrefix, + mrgGroup, + + -- ** Predicates + symIsPrefixOf, + symIsSuffixOf, + symIsInfixOf, + symIsSubsequenceOf, + + -- * Searching lists + + -- ** Searching by equality + symElem, + symNotElem, + mrgLookup, + + -- ** Searching with a predicate + mrgFind, + mrgFilter, + mrgPartition, + + -- * Indexing lists + (.!?), + mrgElemIndex, + mrgElemIndices, + mrgFindIndex, + mrgFindIndices, + + -- * Special lists + + -- ** "Set" operations + mrgNub, + mrgDelete, + (.\\), + mrgUnion, + mrgIntersect, + + -- ** Ordered lists (sorting not supported yet) + mrgInsert, + + -- * Generalized functions + + -- ** The "By" operations + + -- *** User-supplied equality (replacing an 'SEq' context) + mrgNubBy, + mrgDeleteBy, + mrgDeleteFirstsBy, + mrgUnionBy, + mrgIntersectBy, + mrgGroupBy, + + -- *** User-supplied comparison (replacing an 'SOrd' context) + mrgInsertBy, + mrgMaximumBy, + symMaximumBy, + mrgMinimumBy, + symMinimumBy, ) where -import Control.Exception (ArrayException (IndexOutOfBounds)) -import Control.Monad.Except (MonadError (throwError)) -import Grisette.Core.Control.Monad.Union (MonadUnion) -import Grisette.Core.Data.Class.Error (TransformError (transformError)) -import Grisette.Core.Data.Class.Mergeable (Mergeable) -import Grisette.Core.Data.Class.SEq (SEq ((.==))) -import Grisette.Core.Data.Class.SOrd (SOrd ((.<=))) -import Grisette.Core.Data.Class.SimpleMergeable (mrgIf) -import Grisette.IR.SymPrim.Data.SymPrim (SymBool, SymInteger) -import Grisette.Lib.Control.Monad (mrgFmap, mrgReturn) +import Data.Bifunctor (Bifunctor (first, second)) +import Data.List (tails) +import Data.Maybe (listToMaybe) +import Grisette.Internal.Core.Control.Monad.Union (MonadUnion) +import Grisette.Internal.Core.Control.Monad.UnionM (UnionM, liftUnionM) +import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp (symIte)) +import Grisette.Internal.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.&&), (.||))) +import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) +import Grisette.Internal.Core.Data.Class.SEq (SEq ((./=), (.==))) +import Grisette.Internal.Core.Data.Class.SOrd (SOrd ((.<=), (.>=))) +import Grisette.Internal.Core.Data.Class.SimpleMergeable (UnionMergeable1, mrgIf) +import Grisette.Internal.Core.Data.Class.Solvable (Solvable (con)) +import Grisette.Internal.SymPrim.SymBool (SymBool) +import Grisette.Lib.Control.Applicative (mrgPure) +import Grisette.Lib.Control.Monad (mrgReturn) +import Grisette.Lib.Data.Foldable + ( mrgFind, + mrgFoldlM, + mrgMaximum, + mrgMaximumBy, + mrgMinimum, + mrgMinimumBy, + symAll, + symAnd, + symAny, + symElem, + symMaximum, + symMaximumBy, + symMinimum, + symMinimumBy, + symNotElem, + symOr, + ) +import Grisette.Lib.Data.Functor (mrgFmap) --- | Symbolic version of 'Data.List.!!', the result would be merged and +symListOpOnSymInt :: + (Applicative u, UnionMergeable1 u, Mergeable b, Num int, SOrd int) => + Bool -> + (Int -> [a] -> b) -> + int -> + [a] -> + u b +symListOpOnSymInt reversed f x vs = do + let zipped = + (\n -> (fromIntegral n, mrgPure $ f n vs)) + <$> (if reversed then reverse else id) [1 .. length vs - 1] + let outerMostX = if reversed then length vs else 0 + let innerMostX = if reversed then 0 else length vs + let guardCond = + if reversed then (x .>= fromIntegral (length vs)) else (x .<= 0) + mrgIf guardCond (mrgPure $ f outerMostX vs) $ + foldr + (\(n, l) acc -> mrgIf (x .== n) l acc) + (mrgPure $ f innerMostX vs) + zipped + +-- | Symbolic version of 'Data.List.take', the result would be merged and -- propagate the mergeable knowledge. -(.!!) :: +-- +-- Can generate O(n) cases and O(n) sized branch constraints. +mrgTake :: + (Applicative u, UnionMergeable1 u, Mergeable a, Num int, SOrd int) => + int -> + [a] -> + u [a] +mrgTake = symListOpOnSymInt False take + +-- | Symbolic version of 'Data.List.drop', the result would be merged and +-- propagate the mergeable knowledge. +-- +-- Can generate O(n) cases and O(n) sized branch constraints. +mrgDrop :: + (Applicative u, UnionMergeable1 u, Mergeable a, Num int, SOrd int) => + int -> + [a] -> + u [a] +mrgDrop = symListOpOnSymInt True drop + +-- | Symbolic version of 'Data.List.splitAt', the result would be merged and +-- propagate the mergeable knowledge. +-- +-- Can generate O(n) cases and O(n) sized branch constraints. +mrgSplitAt :: + forall a int u. + (MonadUnion u, Mergeable a, Num int, SOrd int) => + int -> + [a] -> + u ([a], [a]) +mrgSplitAt = symListOpOnSymInt False splitAt + +-- | Symbolic version of 'Data.List.takeWhile', the result would be merged and +-- propagate the mergeable knowledge. +-- +-- Can generate O(n) cases and O(n) sized branch constraints. +mrgTakeWhile :: + (Applicative u, UnionMergeable1 u, Mergeable a) => + (a -> SymBool) -> + [a] -> + u [a] +mrgTakeWhile _ [] = mrgPure [] +mrgTakeWhile p (x : xs) = + mrgIf (p x) (mrgFmap (x :) $ mrgTakeWhile p xs) (mrgPure []) + +-- | Symbolic version of 'Data.List.dropWhile', the result would be merged and +-- propagate the mergeable knowledge. +-- +-- Can generate O(n) cases and O(n) sized branch constraints. +mrgDropWhile :: + (Applicative u, UnionMergeable1 u, Mergeable a) => + (a -> SymBool) -> + [a] -> + u [a] +mrgDropWhile _ [] = mrgPure [] +mrgDropWhile p r = do + let allConds = reverse $ scanl1 (.&&) $ p <$> r + foldr (\(cond, l) acc -> mrgIf cond (pure l) acc) (pure r) $ + zip allConds $ + reverse $ + tails r + +-- | Symbolic version of 'Data.List.dropWhileEnd', the result would be merged +-- and propagate the mergeable knowledge. +-- +-- Can generate O(n) cases and O(n) sized branch constraints. +mrgDropWhileEnd :: + (MonadUnion u, Mergeable a) => + (a -> SymBool) -> + [a] -> + u [a] +mrgDropWhileEnd p = + foldr + ( \x xs -> do + xsv <- xs + mrgIf (p x .&& con (null xsv)) (mrgPure []) (mrgPure $ x : xsv) + ) + (mrgPure []) + +-- | Symbolic version of 'Data.List.span', the result would be merged and +-- propagate the mergeable knowledge. +-- +-- Can generate O(n) cases and O(n) sized branch constraints. +mrgSpan :: + (Applicative u, UnionMergeable1 u, Mergeable a) => + (a -> SymBool) -> + [a] -> + u ([a], [a]) +mrgSpan _ [] = mrgPure ([], []) +mrgSpan p xs@(x : xs') = + mrgIf (p x) (mrgFmap (first (x :)) $ mrgSpan p xs') (mrgPure ([], xs)) + +-- | Symbolic version of 'Data.List.break', the result would be merged and +-- propagate the mergeable knowledge. +-- +-- Can generate O(n) cases and O(n) sized branch constraints. +mrgBreak :: + (Applicative u, UnionMergeable1 u, Mergeable a) => + (a -> SymBool) -> + [a] -> + u ([a], [a]) +mrgBreak p = mrgSpan (symNot . p) + +-- | Symbolic version of 'Data.List.stripPrefix', the result would be merged and +-- propagate the mergeable knowledge. +-- +-- Generate O(1) cases and O(len(prefix)) sized branch constraints. +mrgStripPrefix :: + (Applicative u, UnionMergeable1 u, Mergeable a, SEq a) => + [a] -> + [a] -> + u (Maybe [a]) +mrgStripPrefix [] ys = mrgPure $ Just ys +mrgStripPrefix (x : xs) (y : ys) = + mrgIf (x .== y) (mrgStripPrefix xs ys) (mrgPure Nothing) +mrgStripPrefix _ _ = mrgPure Nothing + +-- | Symbolic version of 'Data.List.group', the result would be merged and +-- propagate the mergeable knowledge. +-- +-- This function can be very inefficient on large symbolic lists and generate +-- O(2^n) cases. Use with caution. +mrgGroup :: + (MonadUnion u, Mergeable a, SEq a) => + [a] -> + u [[a]] +mrgGroup = mrgGroupBy (.==) + +-- | Symbolic version of 'Data.List.isPrefixOf'. +-- +-- Generate O(len(prefix)) sized constraints. +symIsPrefixOf :: (SEq a) => [a] -> [a] -> SymBool +symIsPrefixOf [] _ = con True +symIsPrefixOf _ [] = con False +symIsPrefixOf (x : xs) (y : ys) = + x .== y .&& symIsPrefixOf xs ys + +-- | Symbolic version of 'Data.List.isSuffixOf'. +-- +-- Generate O(len(suffix)) sized constraints. +symIsSuffixOf :: (SEq a) => [a] -> [a] -> SymBool +symIsSuffixOf ns hs = symIsPrefixOf (reverse ns) (reverse hs) + +-- | Symbolic version of 'Data.List.isInfixOf'. +-- +-- Generate O(len(haystack) * len(needle)) sized constraints. +symIsInfixOf :: (SEq a) => [a] -> [a] -> SymBool +symIsInfixOf needle haystack = symAny (symIsPrefixOf needle) (tails haystack) + +-- | Symbolic version of 'Data.List.isSubsequenceOf'. +-- +-- Generate O(len(haystack) * len(needle)) sized constraints. +symIsSubsequenceOf :: (SEq a) => [a] -> [a] -> SymBool +symIsSubsequenceOf [] _ = con True +symIsSubsequenceOf _ [] = con False +symIsSubsequenceOf a@(x : a') (y : b) = + symIte (x .== y) (symIsSubsequenceOf a' b) (symIsSubsequenceOf a b) + +-- | Symbolic version of 'Data.List.lookup', the result would be merged and +-- propagate the mergeable knowledge. +-- +-- Can generate O(n) cases and O(n) sized branch constraints. +mrgLookup :: + (Applicative u, UnionMergeable1 u, Mergeable b, SEq a) => + a -> + [(a, b)] -> + u (Maybe b) +mrgLookup _ [] = mrgPure Nothing +mrgLookup key l = + mrgIf (symAll (key ./=) (fst <$> l)) (mrgPure Nothing) $ + mrgLookup' l + where + mrgLookup' [] = error "mrgLookup: impossible" + mrgLookup' [(_, y)] = mrgPure $ Just y + mrgLookup' ((x, y) : xys) = + mrgIf (key .== x) (mrgPure $ Just y) (mrgLookup' xys) + +-- | Symbolic version of 'Data.List.filter', the result would be merged and +-- propagate the mergeable knowledge. +-- +-- This function can be very inefficient on large symbolic lists and generate +-- O(2^n) cases. Use with caution. +mrgFilter :: + (Applicative u, UnionMergeable1 u, Mergeable a) => + (a -> SymBool) -> + [a] -> + u [a] +mrgFilter _ [] = mrgPure [] +mrgFilter p (x : xs) = + mrgIf (p x) (mrgFmap (x :) $ mrgFilter p xs) (mrgFilter p xs) + +-- | Symbolic version of 'Data.List.partition', the result would be merged and +-- propagate the mergeable knowledge. +-- +-- This function can be very inefficient on large symbolic lists and generate +-- O(2^n) cases. Use with caution. +mrgPartition :: + (Applicative u, UnionMergeable1 u, Mergeable a) => + (a -> SymBool) -> + [a] -> + u ([a], [a]) +mrgPartition _ [] = mrgPure ([], []) +mrgPartition p (x : xs) = + mrgIf + (p x) + (mrgFmap (first (x :)) partitioned) + (mrgFmap (second (x :)) partitioned) + where + partitioned = mrgPartition p xs + +-- | Symbolic version of 'Data.List.!?', the result would be merged and +-- propagate the mergeable knowledge. +-- +-- Can generate O(1) cases and O(n) sized branch constraints. +(.!?) :: ( MonadUnion uf, - MonadError e uf, - TransformError ArrayException e, - Mergeable a + Mergeable a, + Num int, + SEq int ) => [a] -> - SymInteger -> - uf a -l .!! p = go l p 0 + int -> + uf (Maybe a) +l .!? p = go l p 0 where - go [] _ _ = throwError $ transformError (IndexOutOfBounds "!!~") - go (x : xs) p1 i = mrgIf (p1 .== i) (mrgReturn x) (go xs p1 $ i + 1) + go [] _ _ = mrgReturn Nothing + go (x : xs) p1 i = mrgIf (p1 .== i) (mrgReturn $ Just x) (go xs p1 $ i + 1) --- | Symbolic version of 'Data.List.filter', the result would be merged and +-- | Symbolic version of 'Data.List.elemIndex', the result would be merged and -- propagate the mergeable knowledge. -symFilter :: (MonadUnion u, Mergeable a) => (a -> SymBool) -> [a] -> u [a] -symFilter f = go +-- +-- Can generate O(n) cases (or O(1) if int is merged), and O(n^2) sized +-- constraints. +mrgElemIndex :: + (MonadUnion u, Mergeable int, SEq a, Num int) => + a -> + [a] -> + u (Maybe int) +mrgElemIndex x = mrgFindIndex (x .==) + +-- | Symbolic version of 'Data.List.elemIndices', the result would be merged and +-- propagate the mergeable knowledge. +-- +-- Can generate O(n) cases, and O(n^3) sized constraints. +mrgElemIndices :: + (MonadUnion u, Mergeable int, SEq a, Num int) => + a -> + [a] -> + u [int] +mrgElemIndices x = mrgFindIndices (x .==) + +-- | Symbolic version of 'Data.List.findIndex', the result would be merged and +-- propagate the mergeable knowledge. +-- +-- Can generate O(n) cases (or O(1) if int is merged), and O(n^2) sized +-- constraints, assuming the predicate only generates O(1) constraints. +mrgFindIndex :: + (Applicative u, UnionMergeable1 u, Mergeable int, SEq a, Num int) => + (a -> SymBool) -> + [a] -> + u (Maybe int) +mrgFindIndex p l = mrgFmap listToMaybe $ mrgFindIndices p l + +-- | Symbolic version of 'Data.List.findIndices', the result would be merged and +-- propagate the mergeable knowledge. +-- +-- Can generate O(n) cases, and O(n^3) sized constraints, assuming the predicate +-- only generates O(1) constraints. +mrgFindIndices :: + (Applicative u, UnionMergeable1 u, Mergeable int, SEq a, Num int) => + (a -> SymBool) -> + [a] -> + u [int] +mrgFindIndices p xs = go $ zip xs $ fromIntegral <$> [0 ..] where - go [] = mrgReturn [] - go (x : xs) = do - r <- go xs - mrgIf (f x) (mrgReturn (x : r)) (mrgReturn r) + go [] = mrgPure [] + go ((x, y) : xys) = mrgIf (p x) (mrgFmap (y :) $ go xys) (go xys) --- | Symbolic version of 'Data.List.take', the result would be merged and +-- | Symbolic version of 'Data.List.nub', the result would be merged and -- propagate the mergeable knowledge. -symTake :: (MonadUnion u, Mergeable a) => SymInteger -> [a] -> u [a] -symTake _ [] = mrgReturn [] -symTake x (v : vs) = mrgIf (x .<= 0) (mrgReturn []) (mrgFmap (v :) $ symTake (x - 1) vs) +-- +-- Can generate O(n) cases, and O(n^3) sized constraints. +mrgNub :: + (Applicative u, UnionMergeable1 u, Mergeable a, SEq a) => + [a] -> + u [a] +mrgNub = mrgNubBy (.==) --- | Symbolic version of 'Data.List.drop', the result would be merged and +-- | Symbolic version of 'Data.List.delete', the result would be merged and -- propagate the mergeable knowledge. -symDrop :: (MonadUnion u, Mergeable a) => SymInteger -> [a] -> u [a] -symDrop _ [] = mrgReturn [] -symDrop x r@(_ : vs) = mrgIf (x .<= 0) (mrgReturn r) (symDrop (x - 1) vs) +-- +-- Can generate O(n) cases, and O(n^2) sized constraints. +mrgDelete :: + (Applicative u, UnionMergeable1 u, Mergeable a, SEq a) => + a -> + [a] -> + u [a] +mrgDelete = mrgDeleteBy (.==) + +-- | Symbolic version of 'Data.List.\\', the result would be merged and +-- propagate the mergeable knowledge. +-- +-- Can generate O(len(lhs)) cases, and O(len(lhs)^2 * len(rhs)) sized +-- constraints. +(.\\) :: + (MonadUnion u, Mergeable a, SEq a) => + [a] -> + [a] -> + u [a] +(.\\) = mrgDeleteFirstsBy (.==) + +-- | Symbolic version of 'Data.List.union', the result would be merged and +-- propagate the mergeable knowledge. +-- +-- Can generate O(len(rhs)) cases, and O(len(rhs)^5 * len(lhs)) sized +-- constraints. +-- +-- Should be improvable. +mrgUnion :: + (MonadUnion u, Mergeable a, SEq a) => + [a] -> + [a] -> + u [a] +mrgUnion = mrgUnionBy (.==) + +mrgIntersect :: + (MonadUnion u, Mergeable a, SEq a) => + [a] -> + [a] -> + u [a] +mrgIntersect = mrgIntersectBy (.==) + +-- | Symbolic version of 'Data.List.nubBy', the result would be merged and +-- propagate the mergeable knowledge. +-- +-- Can generate O(n) cases, and O(n^3) sized constraints, assuming the predicate +-- only generates O(1) constraints. +mrgNubBy :: + (Applicative u, UnionMergeable1 u, Mergeable a) => + (a -> a -> SymBool) -> + [a] -> + u [a] +mrgNubBy eq l = mrgNubBy' l [] + where + mrgNubBy' [] _ = mrgPure [] + mrgNubBy' (y : ys) xs = + mrgIf + (mrgElemBy y xs) + (mrgNubBy' ys xs) + (mrgFmap (y :) $ mrgNubBy' ys (y : xs)) + mrgElemBy _ [] = con False + mrgElemBy x (y : ys) = eq x y .|| mrgElemBy x ys + +-- | Symbolic version of 'Data.List.deleteBy', the result would be merged and +-- propagate the mergeable knowledge. +-- +-- Can generate O(n) cases, and O(n^2) sized constraints, assuming the predicate +-- only generates O(1) constraints. +mrgDeleteBy :: + (Applicative u, UnionMergeable1 u, Mergeable a) => + (a -> a -> SymBool) -> + a -> + [a] -> + u [a] +mrgDeleteBy _ _ [] = mrgPure [] +mrgDeleteBy eq x (y : ys) = + mrgIf (eq x y) (mrgPure ys) (mrgFmap (y :) $ mrgDeleteBy eq x ys) + +-- | Symbolic version of 'Data.List.deleteFirstsBy', the result would be merged +-- and propagate the mergeable knowledge. +-- +-- Can generate O(len(lhs)) cases, and O(len(lhs)^2 * len(rhs)) sized +-- constraints, assuming the predicate only generates O(1) constraints. +mrgDeleteFirstsBy :: + (MonadUnion u, Mergeable a) => + (a -> a -> SymBool) -> + [a] -> + [a] -> + u [a] +mrgDeleteFirstsBy eq = mrgFoldlM (flip $ mrgDeleteBy eq) + +-- | Symbolic version of 'Data.List.unionBy', the result would be merged and +-- propagate the mergeable knowledge. +-- +-- Can generate O(len(rhs)) cases, and O(len(rhs)^5 * len(lhs)) sized +-- constraints, assuming the predicate only generates O(1) constraints. +-- +-- Should be improvable. +mrgUnionBy :: + (MonadUnion u, Mergeable a) => + (a -> a -> SymBool) -> + [a] -> + [a] -> + u [a] +mrgUnionBy eq xs ys = + mrgFmap (xs ++) $ + (mrgNubBy eq ys) + >>= \nubbed -> mrgFoldlM (flip $ mrgDeleteBy eq) nubbed xs + +-- | Symbolic version of 'Data.List.intersectBy', the result would be merged and +-- propagate the mergeable knowledge. +-- +-- Can generate O(len(rhs)) cases, and O(len(lhs) * len(rhs)) constraints, +-- assuming the predicate only generates O(1) constraints. +mrgIntersectBy :: + (MonadUnion u, Mergeable a) => + (a -> a -> SymBool) -> + [a] -> + [a] -> + u [a] +mrgIntersectBy _ [] _ = mrgPure [] +mrgIntersectBy _ _ [] = mrgPure [] +mrgIntersectBy eq xs ys = do + tl <- mrgIntersectBy eq (tail xs) ys + mrgIf (symAny (eq (head xs)) ys) (mrgReturn $ head xs : tl) (mrgPure tl) + +-- | This function can be very inefficient on large symbolic lists and generate +-- O(2^n) cases. Use with caution. +mrgGroupBy :: + (MonadUnion u, Mergeable a) => + (a -> a -> SymBool) -> + [a] -> + u [[a]] +mrgGroupBy _ [] = mrgPure [] +mrgGroupBy eq (x : xs) = do + (ys, zs) <- mrgSpan (eq x) xs + tl <- mrgGroupBy eq zs + mrgReturn $ (x : ys) : tl + +-- | Symbolic version of 'Data.List.insert', the result would be merged and +-- propagate the mergeable knowledge. +-- +-- Can generate 1 case, and O(n^2) sized constraints. +mrgInsert :: + (MonadUnion m, Mergeable a, SOrd a) => + a -> + [a] -> + m [a] +mrgInsert x [] = mrgPure [x] +mrgInsert x ys@(y : ys') = + mrgIf (x .<= y) (mrgReturn $ x : ys) (mrgFmap (y :) $ mrgInsert x ys') + +-- | Symbolic version of 'Data.List.insertBy', the result would be merged and +-- propagate the mergeable knowledge. +-- +-- Can generate 1 case, and O(n^2) sized constraints, assuming the ordering +-- function only generates O(1) constraints. +mrgInsertBy :: + (MonadUnion m, Mergeable a) => + (a -> a -> UnionM Ordering) -> + a -> + [a] -> + m [a] +mrgInsertBy _ x [] = mrgPure [x] +mrgInsertBy cmp x ys@(y : ys') = do + r <- liftUnionM $ cmp x y + case r of + GT -> mrgFmap (y :) $ mrgInsertBy cmp x ys' + _ -> mrgReturn $ x : ys diff --git a/src/Grisette/Lib/Data/Maybe.hs b/src/Grisette/Lib/Data/Maybe.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Lib/Data/Maybe.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE TemplateHaskell #-} + +module Grisette.Lib.Data.Maybe (mrgNothing, mrgJust) where + +import Grisette.Internal.Core.Data.Class.TryMerge (mrgSingle) +import Grisette.Internal.Core.TH.MergeConstructor + ( mkMergeConstructor, + ) + +mkMergeConstructor "mrg" ''Maybe diff --git a/src/Grisette/Lib/Data/Traversable.hs b/src/Grisette/Lib/Data/Traversable.hs --- a/src/Grisette/Lib/Data/Traversable.hs +++ b/src/Grisette/Lib/Data/Traversable.hs @@ -11,39 +11,47 @@ -- Stability : Experimental -- Portability : GHC only module Grisette.Lib.Data.Traversable - ( -- * mrg* variants for operations in "Data.Traversable" + ( -- * The 'Traversable' class mrgTraverse, mrgSequenceA, - mrgFor, mrgMapM, - mrgForM, mrgSequence, + + -- * Utility functions + mrgFor, + mrgForM, + mrgMapAccumM, + mrgForAccumM, ) where -import Grisette.Core.Control.Monad.Union (MonadUnion) -import Grisette.Core.Data.Class.Mergeable - ( Mergeable, +import Control.Monad.State (StateT (StateT, runStateT)) +import Grisette.Internal.Core.Data.Class.Mergeable + ( Mergeable (rootStrategy), Mergeable1, + Mergeable2 (liftRootStrategy2), rootStrategy1, ) -import Grisette.Core.Data.Class.SimpleMergeable - ( UnionLike (mergeWithStrategy), - merge, +import Grisette.Internal.Core.Data.Class.TryMerge + ( MonadTryMerge, + TryMerge (tryMergeWithStrategy), + tryMerge, ) +import Grisette.Lib.Control.Applicative (mrgPure) -- | 'Data.Traversable.traverse' with 'MergingStrategy' knowledge propagation. mrgTraverse :: forall a b t f. ( Mergeable b, Mergeable1 t, - MonadUnion f, + TryMerge f, + Applicative f, Traversable t ) => (a -> f b) -> t a -> f (t b) -mrgTraverse f = mergeWithStrategy rootStrategy1 . traverse (merge . f) +mrgTraverse f = tryMergeWithStrategy rootStrategy1 . traverse (tryMerge . f) {-# INLINE mrgTraverse #-} -- | 'Data.Traversable.sequenceA' with 'MergingStrategy' knowledge propagation. @@ -51,7 +59,8 @@ forall a t f. ( Mergeable a, Mergeable1 t, - MonadUnion f, + Applicative f, + TryMerge f, Traversable t ) => t (f a) -> @@ -64,7 +73,7 @@ forall a b t f. ( Mergeable b, Mergeable1 t, - MonadUnion f, + MonadTryMerge f, Traversable t ) => (a -> f b) -> @@ -78,7 +87,7 @@ forall a t f. ( Mergeable a, Mergeable1 t, - MonadUnion f, + MonadTryMerge f, Traversable t ) => t (f a) -> @@ -91,7 +100,8 @@ ( Mergeable b, Mergeable1 t, Traversable t, - MonadUnion m + TryMerge m, + Applicative m ) => t a -> (a -> m b) -> @@ -104,10 +114,39 @@ ( Mergeable b, Mergeable1 t, Traversable t, - MonadUnion m + MonadTryMerge m ) => t a -> (a -> m b) -> m (t b) mrgForM = flip mrgMapM {-# INLINE mrgForM #-} + +-- | 'Data.Traversable.mapAccumM' with 'MergingStrategy' knowledge propagation. +mrgMapAccumM :: + (MonadTryMerge m, Traversable t, Mergeable s, Mergeable b, Mergeable1 t) => + (s -> a -> m (s, b)) -> + s -> + t a -> + m (s, t b) +mrgMapAccumM f s t = + tryMergeWithStrategy (liftRootStrategy2 rootStrategy rootStrategy1) $ do + (tb, s) <- flip runStateT s $ do + mrgMapM + ( \a -> StateT $ \s -> do + (sr, br) <- f s a + mrgPure (br, sr) + ) + t + return (s, tb) +{-# INLINE mrgMapAccumM #-} + +-- | 'Data.Traversable.forAccumM' and 'MergingStrategy' knowledge propagation. +mrgForAccumM :: + (MonadTryMerge m, Traversable t, Mergeable s, Mergeable b, Mergeable1 t) => + s -> + t a -> + (s -> a -> m (s, b)) -> + m (s, t b) +mrgForAccumM s t f = mrgMapAccumM f s t +{-# INLINE mrgForAccumM #-} diff --git a/src/Grisette/Lib/Data/Tuple.hs b/src/Grisette/Lib/Data/Tuple.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Lib/Data/Tuple.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Grisette.Lib.Data.Tuple + ( mrgUnit, + mrgTuple2, + mrgTuple3, + mrgTuple4, + mrgTuple5, + mrgTuple6, + mrgTuple7, + mrgTuple8, + ) +where + +import Grisette.Internal.Core.Data.Class.TryMerge (mrgSingle) +import Grisette.Internal.Core.TH.MergeConstructor + ( mkMergeConstructor', + ) + +mkMergeConstructor' ["mrgUnit"] ''() +mkMergeConstructor' ["mrgTuple2"] ''(,) +mkMergeConstructor' ["mrgTuple3"] ''(,,) +mkMergeConstructor' ["mrgTuple4"] ''(,,,) +mkMergeConstructor' ["mrgTuple5"] ''(,,,,) +mkMergeConstructor' ["mrgTuple6"] ''(,,,,,) +mkMergeConstructor' ["mrgTuple7"] ''(,,,,,,) +mkMergeConstructor' ["mrgTuple8"] ''(,,,,,,,) diff --git a/src/Grisette/Qualified/ParallelUnionDo.hs b/src/Grisette/Qualified/ParallelUnionDo.hs deleted file mode 100644 --- a/src/Grisette/Qualified/ParallelUnionDo.hs +++ /dev/null @@ -1,22 +0,0 @@ --- | --- Module : Grisette.Qualified.ParallelUnionDo --- Copyright : (c) Sirui Lu 2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Qualified.ParallelUnionDo ((>>=), (>>)) where - -import Control.Parallel.Strategies (NFData) -import Grisette.Core.Control.Monad.Class.MonadParallelUnion - ( MonadParallelUnion (parBindUnion), - ) -import Grisette.Core.Data.Class.Mergeable (Mergeable) -import Prelude (const, ($)) - -(>>=) :: (MonadParallelUnion m, Mergeable b, NFData b) => m a -> (a -> m b) -> m b -(>>=) = parBindUnion - -(>>) :: (MonadParallelUnion m, Mergeable b, NFData b) => m a -> m b -> m b -(>>) a b = parBindUnion a $ const b diff --git a/src/Grisette/SymPrim.hs b/src/Grisette/SymPrim.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/SymPrim.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE PatternSynonyms #-} +-- Disable this warning because we are re-exporting things. +{-# OPTIONS_GHC -Wno-missing-import-lists #-} + +-- | +-- Module : Grisette.SymPrim +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.SymPrim + ( -- * Symbolic type implementation + + -- ** Extended types + IntN, + WordN, + SomeBV (..), + BitwidthMismatch (..), + pattern SomeIntN, + type SomeIntN, + pattern SomeWordN, + type SomeWordN, + type (=->) (..), + type (-->), + (-->), + unsafeSomeBV, + unarySomeBV, + unarySomeBVR1, + binSomeBV, + binSomeBVR1, + binSomeBVR2, + binSomeBVSafe, + binSomeBVSafeR1, + binSomeBVSafeR2, + conBV, + conBVView, + pattern ConBV, + symBV, + ssymBV, + isymBV, + arbitraryBV, + + -- ** Symbolic types + SupportedPrim, + SymRep (SymType), + ConRep (ConType), + LinkedRep, + SymBool (..), + SymInteger (..), + SymWordN (..), + SymIntN (..), + SomeSymIntN, + SomeSymWordN, + pattern SomeSymIntN, + pattern SomeSymWordN, + type (=~>) (..), + type (-~>) (..), + TypedSymbol (..), + symSize, + symsSize, + AllSyms (..), + allSymsSize, + + -- ** Symbolic constant sets and models + SymbolSet (..), + Model (..), + ModelValuePair (..), + ModelSymPair (..), + ) +where + +import Grisette.Internal.SymPrim.AllSyms + ( AllSyms (..), + allSymsSize, + symSize, + symsSize, + ) +import Grisette.Internal.SymPrim.BV + ( BitwidthMismatch (..), + IntN, + WordN, + ) +import Grisette.Internal.SymPrim.GeneralFun (type (-->)) +import Grisette.Internal.SymPrim.ModelRep (ModelSymPair (..)) +import Grisette.Internal.SymPrim.Prim.Model + ( Model (..), + ModelValuePair (..), + SymbolSet (..), + ) +import Grisette.Internal.SymPrim.Prim.Term + ( ConRep (..), + LinkedRep, + SupportedPrim, + SymRep (..), + TypedSymbol (..), + ) +import Grisette.Internal.SymPrim.SomeBV + ( SomeBV (..), + arbitraryBV, + binSomeBV, + binSomeBVR1, + binSomeBVR2, + binSomeBVSafe, + binSomeBVSafeR1, + binSomeBVSafeR2, + conBV, + conBVView, + isymBV, + ssymBV, + symBV, + unarySomeBV, + unarySomeBVR1, + unsafeSomeBV, + pattern ConBV, + pattern SomeIntN, + pattern SomeSymIntN, + pattern SomeSymWordN, + pattern SomeWordN, + type SomeIntN, + type SomeSymIntN, + type SomeSymWordN, + type SomeWordN, + ) +import Grisette.Internal.SymPrim.SymBV + ( SymIntN (..), + SymWordN (..), + ) +import Grisette.Internal.SymPrim.SymBool + ( SymBool (..), + ) +import Grisette.Internal.SymPrim.SymGeneralFun ((-->), type (-~>) (..)) +import Grisette.Internal.SymPrim.SymInteger + ( SymInteger (..), + ) +import Grisette.Internal.SymPrim.SymTabularFun (type (=~>) (..)) +import Grisette.Internal.SymPrim.TabularFun (type (=->) (..)) diff --git a/src/Grisette/Utils.hs b/src/Grisette/Utils.hs --- a/src/Grisette/Utils.hs +++ b/src/Grisette/Utils.hs @@ -18,7 +18,6 @@ -- ** Runtime representation of type-level natural numbers NatRepr, natValue, - unsafeMkNatRepr, natRepr, decNat, predNat, @@ -50,7 +49,7 @@ ) where -import Grisette.Utils.Parameterized +import Grisette.Internal.Utils.Parameterized ( KnownProof (..), LeqProof (..), NatRepr, @@ -76,7 +75,6 @@ unsafeAxiom, unsafeKnownProof, unsafeLeqProof, - unsafeMkNatRepr, withKnownProof, withLeqProof, ) diff --git a/src/Grisette/Utils/Parameterized.hs b/src/Grisette/Utils/Parameterized.hs deleted file mode 100644 --- a/src/Grisette/Utils/Parameterized.hs +++ /dev/null @@ -1,244 +0,0 @@ -{- -Part of the code in this file comes from the parameterized-utils package: - -Copyright (c) 2013-2022 Galois Inc. -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions -are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in - the documentation and/or other materials provided with the - distribution. - - * Neither the name of Galois, Inc. nor the names of its contributors - may be used to endorse or promote products derived from this - software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS -IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A -PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER -OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} - --- | --- Module : Grisette.Utils.Parameterized --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Utils.Parameterized - ( -- * Unsafe axiom - unsafeAxiom, - - -- * Runtime representation of type-level natural numbers - NatRepr, - natValue, - unsafeMkNatRepr, - natRepr, - decNat, - predNat, - incNat, - addNat, - subNat, - divNat, - halfNat, - - -- * Proof of KnownNat - KnownProof (..), - hasRepr, - withKnownProof, - unsafeKnownProof, - knownAdd, - - -- * Proof of (<=) for type-level natural numbers - LeqProof (..), - withLeqProof, - unsafeLeqProof, - testLeq, - leqRefl, - leqSucc, - leqTrans, - leqZero, - leqAdd2, - leqAdd, - leqAddPos, - ) -where - -import Data.Typeable (Proxy (Proxy), type (:~:) (Refl)) -import GHC.Natural (Natural) -import GHC.TypeNats - ( Div, - KnownNat, - Nat, - SomeNat (SomeNat), - natVal, - someNatVal, - type (+), - type (-), - type (<=), - ) -import Unsafe.Coerce (unsafeCoerce) - --- | Assert a proof of equality between two types. --- This is unsafe if used improperly, so use this with caution! -unsafeAxiom :: forall a b. a :~: b -unsafeAxiom = unsafeCoerce (Refl @a) - --- | A runtime representation of type-level natural numbers. --- This can be used for performing dynamic checks on type-level natural numbers. -newtype NatRepr (n :: Nat) = NatRepr Natural - --- | The underlying runtime natural number value of a type-level natural number. -natValue :: NatRepr n -> Natural -natValue (NatRepr n) = n - --- | Construct a runtime representation of a type-level natural number. --- --- __Note:__ This function is unsafe, as it does not check that the runtime --- representation is consistent with the type-level representation. --- You should ensure the consistency yourself or the program can crash or --- generate incorrect results. -unsafeMkNatRepr :: Natural -> NatRepr n -unsafeMkNatRepr = NatRepr - --- | Construct a runtime representation of a type-level natural number when its --- runtime value is known. -natRepr :: forall n. (KnownNat n) => NatRepr n -natRepr = NatRepr (natVal (Proxy @n)) - --- | Decrement a 'NatRepr' by 1. -decNat :: (1 <= n) => NatRepr n -> NatRepr (n - 1) -decNat (NatRepr n) = NatRepr (n - 1) - --- | Predecessor of a 'NatRepr' -predNat :: NatRepr (n + 1) -> NatRepr n -predNat (NatRepr n) = NatRepr (n - 1) - --- | Increment a 'NatRepr' by 1. -incNat :: NatRepr n -> NatRepr (n + 1) -incNat (NatRepr n) = NatRepr (n + 1) - --- | Addition of two 'NatRepr's. -addNat :: NatRepr m -> NatRepr n -> NatRepr (m + n) -addNat (NatRepr m) (NatRepr n) = NatRepr (m + n) - --- | Subtraction of two 'NatRepr's. -subNat :: (n <= m) => NatRepr m -> NatRepr n -> NatRepr (m - n) -subNat (NatRepr m) (NatRepr n) = NatRepr (m - n) - --- | Division of two 'NatRepr's. -divNat :: (1 <= n) => NatRepr m -> NatRepr n -> NatRepr (Div m n) -divNat (NatRepr m) (NatRepr n) = NatRepr (m `div` n) - --- | Half of a 'NatRepr'. -halfNat :: NatRepr (n + n) -> NatRepr n -halfNat (NatRepr n) = NatRepr (n `div` 2) - --- | @'KnownProof n'@ is a type whose values are only inhabited when @n@ has --- a known runtime value. -data KnownProof (n :: Nat) where - KnownProof :: (KnownNat n) => KnownProof n - --- | Introduces the 'KnownNat' constraint when it's proven. -withKnownProof :: KnownProof n -> ((KnownNat n) => r) -> r -withKnownProof p r = case p of KnownProof -> r - --- | Construct a 'KnownProof' given the runtime value. --- --- __Note:__ This function is unsafe, as it does not check that the runtime --- representation is consistent with the type-level representation. --- You should ensure the consistency yourself or the program can crash or --- generate incorrect results. -unsafeKnownProof :: Natural -> KnownProof n -unsafeKnownProof nVal = hasRepr (NatRepr nVal) - --- | Construct a 'KnownProof' given the runtime representation. -hasRepr :: forall n. NatRepr n -> KnownProof n -hasRepr (NatRepr nVal) = - case someNatVal nVal of - SomeNat (Proxy :: Proxy n') -> - case unsafeAxiom :: n :~: n' of - Refl -> KnownProof - --- | Adding two type-level natural numbers with known runtime values gives a --- type-level natural number with a known runtime value. -knownAdd :: forall m n. KnownProof m -> KnownProof n -> KnownProof (m + n) -knownAdd KnownProof KnownProof = hasRepr @(m + n) (NatRepr (natVal (Proxy @m) + natVal (Proxy @n))) - --- | @'LeqProof m n'@ is a type whose values are only inhabited when @m <= n@. -data LeqProof (m :: Nat) (n :: Nat) where - LeqProof :: (m <= n) => LeqProof m n - --- | Introduces the @m <= n@ constraint when it's proven. -withLeqProof :: LeqProof m n -> ((m <= n) => r) -> r -withLeqProof p r = case p of LeqProof -> r - --- | Construct a 'LeqProof'. --- --- __Note:__ This function is unsafe, as it does not check that the left-hand --- side is less than or equal to the right-hand side. --- You should ensure the consistency yourself or the program can crash or --- generate incorrect results. -unsafeLeqProof :: forall m n. LeqProof m n -unsafeLeqProof = unsafeCoerce (LeqProof @0 @0) - --- | Checks if a 'NatRepr' is less than or equal to another 'NatRepr'. -testLeq :: NatRepr m -> NatRepr n -> Maybe (LeqProof m n) -testLeq (NatRepr m) (NatRepr n) = - case compare m n of - LT -> Nothing - EQ -> Just unsafeLeqProof - GT -> Just unsafeLeqProof - --- | Apply reflexivity to 'LeqProof'. -leqRefl :: f n -> LeqProof n n -leqRefl _ = LeqProof - --- | A natural number is less than or equal to its successor. -leqSucc :: f n -> LeqProof n (n + 1) -leqSucc _ = unsafeLeqProof - --- | Apply transitivity to 'LeqProof'. -leqTrans :: LeqProof a b -> LeqProof b c -> LeqProof a c -leqTrans _ _ = unsafeLeqProof - --- | Zero is less than or equal to any natural number. -leqZero :: LeqProof 0 n -leqZero = unsafeLeqProof - --- | Add both sides of two inequalities. -leqAdd2 :: LeqProof xl xh -> LeqProof yl yh -> LeqProof (xl + yl) (xh + yh) -leqAdd2 _ _ = unsafeLeqProof - --- | Produce proof that adding a value to the larger element in an 'LeqProof' --- is larger. -leqAdd :: LeqProof m n -> f o -> LeqProof m (n + o) -leqAdd _ _ = unsafeLeqProof - --- | Adding two positive natural numbers is positive. -leqAddPos :: (1 <= m, 1 <= n) => p m -> q n -> LeqProof 1 (m + n) -leqAddPos _ _ = unsafeLeqProof diff --git a/test/Grisette/Backend/CEGISTests.hs b/test/Grisette/Backend/CEGISTests.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/Backend/CEGISTests.hs @@ -0,0 +1,408 @@ +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Grisette.Backend.CEGISTests (cegisTests) where + +import Control.Monad.Except (ExceptT) +import Data.Proxy (Proxy (Proxy)) +import qualified Data.SBV as SBV +import Data.String (IsString (fromString)) +import GHC.Stack (HasCallStack) +import Grisette + ( Apply (apply), + CEGISResult (CEGISSuccess), + EvaluateSym (evaluateSym), + ExtractSymbolics, + Function ((#)), + GrisetteSMTConfig, + ITEOp (symIte), + LogicalOp (symNot, symXor, (.&&), (.||)), + SEq ((.==)), + SOrd ((.<), (.>=)), + SizedBV (sizedBVConcat, sizedBVSelect, sizedBVSext, sizedBVZext), + Solvable (con), + UnionM, + VerificationConditions, + cegis, + cegisExceptVC, + cegisForAllExceptVC, + cegisMultiInputs, + cegisPostCond, + mrgIf, + precise, + solve, + symAssert, + symAssume, + z3, + ) +import Grisette.SymPrim + ( SymBool, + SymIntN, + SymInteger, + type (-~>), + type (=~>), + ) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion, assertFailure, (@=?)) + +testCegis :: + (HasCallStack, ExtractSymbolics a, EvaluateSym a, Show a, SEq a) => + GrisetteSMTConfig i -> + Bool -> + a -> + (a -> [SymBool]) -> + Assertion +testCegis config shouldSuccess inputs bs = do + cegisExceptVCResult <- + cegisExceptVC config (inputs, "internal" :: SymInteger) return $ + \(cexInputs, internal) -> buildFormula internal (bs cexInputs) + case cegisExceptVCResult of + (_, CEGISSuccess m) -> do + shouldSuccess @=? True + verify "cegisExceptVC" m (bs inputs) + _ -> shouldSuccess @=? False + cegisForAllExceptVCResult <- + cegisForAllExceptVC config (inputs, "internal" :: SymInteger) return $ + buildFormula "internal" (bs inputs) + case cegisForAllExceptVCResult of + (_, CEGISSuccess m) -> do + shouldSuccess @=? True + verify "cegisForAllExceptVC" m (bs inputs) + _ -> shouldSuccess @=? False + where + verify _ _ [] = return () + verify funName m (v : vs) = do + y <- solve config (evaluateSym False m $ symNot v) + case y of + Left _ -> verify funName m vs + Right _ -> + assertFailure $ + funName + ++ ": Failed to verify " + ++ show v + ++ " with the model " + ++ show m + buildFormula internal l = do + symAssume (internal .>= 0) + go l 0 + where + go :: + [SymBool] -> SymInteger -> ExceptT VerificationConditions UnionM () + go [] _ = return () + go (x : xs) i = + mrgIf + (internal .>= i .&& internal .< (i + 1)) + (symAssert x) + (go xs (i + 1)) + +cegisTests :: Test +cegisTests = + let unboundedConfig = precise SBV.z3 + in testGroup + "CEGIS" + [ testGroup + "Regression" + [ testCase "Empty symbolic inputs makes cegis work like solve" $ do + (_, CEGISSuccess m1) <- + cegisMultiInputs + (precise z3) + [1 :: Integer, 2] + (\idx -> cegisPostCond $ fromString $ "a" ++ show idx) + Right m2 <- solve (precise z3) ("a1" .&& "a2") + m1 @=? m2, + testCase "Lowering of TabularFun" $ do + let s1 = "s1" :: SymInteger =~> SymInteger + let s2 = "s2" :: SymInteger =~> SymInteger + (_, CEGISSuccess m1) <- + cegis unboundedConfig ("cond" :: SymBool) $ + \cond -> + cegisPostCond $ + apply (symIte cond s1 s2) (symIte cond 1 2) + .== 10 + .&& apply (symIte cond s1 s2) (symIte cond 3 4) + .== 100 + let s1e = evaluateSym False m1 s1 + let s2e = evaluateSym False m1 s2 + s1e # 1 @=? 10 + s1e # 3 @=? 100 + s2e # 2 @=? 10 + s2e # 4 @=? 100, + testCase "Lowering of GeneralFun" $ do + let s1 = "s1" :: SymInteger -~> SymInteger + let s2 = "s2" :: SymInteger -~> SymInteger + (_, CEGISSuccess m1) <- + cegis unboundedConfig ("cond" :: SymBool) $ + \cond -> + cegisPostCond $ + apply (symIte cond s1 s2) (symIte cond 1 2) + .== 10 + .&& apply (symIte cond s1 s2) (symIte cond 3 4) + .== 100 + let s1e = evaluateSym False m1 s1 + let s2e = evaluateSym False m1 s2 + s1e # 1 @=? 10 + s1e # 3 @=? 100 + s2e # 2 @=? 10 + s2e # 4 @=? 100 + ], + testGroup + "Boolean" + [ testCase "Basic" $ do + testCegis unboundedConfig True () $ const ["a", "b", "c"] + testCegis unboundedConfig False () $ const ["a", symNot "a"], + testCase "And" $ do + testCegis unboundedConfig True () $ + const ["a" .&& "b", "b" .&& symNot "c", "a", "b", symNot "c"] + testCegis unboundedConfig False () $ + const ["a" .&& "b", "b" .&& symNot "c", "a", "b", "c"] + testCegis unboundedConfig True ("a" :: SymBool) $ + \a -> [symNot $ a .&& "b", symNot "b"] + testCegis unboundedConfig False ("a" :: SymBool) $ + \a -> [symNot $ a .&& "b", "b"], + testCase "Or" $ do + testCegis unboundedConfig True () $ + const ["a" .|| "b", "b" .|| symNot "c", "a", "b", symNot "c"] + testCegis unboundedConfig True () $ + const ["a" .|| "b", "b" .|| symNot "c", "a", "b", "c"] + testCegis unboundedConfig True ("a" :: SymBool) $ + \a -> [a .|| "b", "b"] + testCegis unboundedConfig False ("a" :: SymBool) $ + \a -> [a .|| "b", symNot "b"], + testCase "And / Or should be consistent" $ do + testCegis unboundedConfig True () $ + const ["a" .&& "b", "a" .|| "b"] + testCegis unboundedConfig True () $ + const [symNot "a" .&& "b", "a" .|| "b"] + testCegis unboundedConfig False () $ + const ["a" .&& "b", symNot $ "a" .|| "b"] + testCegis unboundedConfig True () $ + const [symNot $ "a" .&& "b", symNot $ "a" .|| "b"], + testCase "Eqv" $ do + testCegis unboundedConfig True () $ + const [("a" :: SymBool) .== "b", "a", "b"] + testCegis unboundedConfig True () $ + const [("a" :: SymBool) .== "b", symNot "a", symNot "b"] + testCegis unboundedConfig False () $ + const [("a" :: SymBool) .== "b", symNot "a", "b"] + testCegis unboundedConfig False () $ + const [("a" :: SymBool) .== "b", symNot "a", "b"] + testCegis unboundedConfig True () $ + const [("a" :: SymBool) .== "b", symNot "a" `symXor` "b"] + testCegis unboundedConfig False () $ + const [("a" :: SymBool) .== "b", "a" `symXor` "b"], + testCase "symIte" $ do + testCegis unboundedConfig True ("c" :: SymBool) $ + \c -> [symIte "a" "b" c, "a", "b"] + testCegis unboundedConfig False ("c" :: SymBool) $ + \c -> [symIte "a" "b" c, symNot "a"] + testCegis unboundedConfig True ("b" :: SymBool) $ + \b -> [symIte "a" b "c", symNot "a", "c"] + testCegis unboundedConfig False ("b" :: SymBool) $ + \b -> [symIte "a" b "c", "a"] + testCegis unboundedConfig True () $ + const [symIte "a" "b" "c", "a", "b", "c"] + testCegis unboundedConfig True () $ + const [symIte "a" "b" "c", "a", "b", symNot "c"] + testCegis unboundedConfig True () $ + const [symIte "a" "b" "c", symNot "a", "b", "c"] + testCegis unboundedConfig True () $ + const [symIte "a" "b" "c", symNot "a", symNot "b", "c"] + testCegis unboundedConfig False () $ + const [symIte "a" "b" "c", "a", symNot "b", "c"] + testCegis unboundedConfig False () $ + const [symIte "a" "b" "c", "a", symNot "b", symNot "c"] + testCegis unboundedConfig False () $ + const [symIte "a" "b" "c", symNot "a", "b", symNot "c"] + testCegis unboundedConfig False () $ + const [symIte "a" "b" "c", symNot "a", symNot "b", symNot "c"] + ], + let a = "a" :: SymIntN 5 + b = "b" :: SymIntN 5 + c = "c" :: SymIntN 5 + d = "c" :: SymIntN 10 + in testGroup + "Different sized BV" + [ testGroup + "Select" + [ testCase "sizedBVSelect" $ do + testCegis unboundedConfig True () $ + const + [ sizedBVSelect (Proxy @2) (Proxy @2) a + .== (con 1 :: SymIntN 2), + a .== con 0b10101 + ] + testCegis unboundedConfig False () $ + const + [ sizedBVSelect (Proxy @2) (Proxy @2) a + .== (con 1 :: SymIntN 2), + a .== con 0b10001 + ], + testCase "sizedBVSelect when lowered twice" $ do + testCegis unboundedConfig True a $ + \ca -> + [ sizedBVSelect + (Proxy @2) + (Proxy @2) + (sizedBVConcat ca b) + .== (con 1 :: SymIntN 2) + ] + testCegis unboundedConfig True b $ + \cb -> + [ sizedBVSelect + (Proxy @7) + (Proxy @2) + (sizedBVConcat a cb) + .== (con 1 :: SymIntN 2) + ] + ], + testGroup + "Concat" + [ testCase "sizedBVConcat" $ do + testCegis unboundedConfig True () $ + const + [ sizedBVConcat a b .== d, + a .== con 1, + b .== con 1, + d .== con 0b100001 + ] + testCegis unboundedConfig False () $ + const + [ sizedBVConcat a b .== d, + a .== con 1, + b .== con 1, + d .== con 0b100010 + ], + testCase "sizedBVConcat when lowered twice" $ do + testCegis unboundedConfig True (a, c) $ + \(ca, cc) -> + [ sizedBVConcat + cc + ( sizedBVSelect + (Proxy @2) + (Proxy @2) + (sizedBVConcat ca b) :: + SymIntN 2 + ) + .== sizedBVConcat cc (con 1 :: SymIntN 2) + ] + testCegis unboundedConfig True (b, c) $ + \(cb, cc) -> + [ sizedBVConcat + cc + ( sizedBVSelect + (Proxy @7) + (Proxy @2) + (sizedBVConcat a cb) :: + SymIntN 2 + ) + .== sizedBVConcat cc (con 1 :: SymIntN 2) + ] + ], + testGroup + "Zext" + [ testCase "sizedBVZext" $ do + testCegis unboundedConfig True () $ + const + [ sizedBVZext (Proxy @10) a .== d, + a .== con 1, + d .== (con 1 :: SymIntN 10) + ] + testCegis unboundedConfig True () $ + const + [ sizedBVZext (Proxy @10) a .== d, + a .== con 0b11111, + d .== (con 0b11111 :: SymIntN 10) + ] + testCegis unboundedConfig False () $ + const + [ sizedBVZext (Proxy @10) a .== d, + d .== (con 0b111111 :: SymIntN 10) + ] + testCegis unboundedConfig False () $ + const + [ sizedBVZext (Proxy @10) a .== d, + d .== (con 0b1111111111 :: SymIntN 10) + ], + testCase "sizedBVZext when lowered twice" $ do + testCegis unboundedConfig True a $ + \ca -> + [ sizedBVZext + (Proxy @10) + ( sizedBVSelect + (Proxy @2) + (Proxy @2) + (sizedBVConcat ca b) :: + SymIntN 2 + ) + .== (con 1 :: SymIntN 10) + ] + testCegis unboundedConfig True b $ + \cb -> + [ sizedBVZext + (Proxy @10) + ( sizedBVSelect + (Proxy @7) + (Proxy @2) + (sizedBVConcat a cb) :: + SymIntN 2 + ) + .== (con 1 :: SymIntN 10) + ] + ], + testGroup + "Sext" + [ testCase "sizedBVSext" $ do + testCegis unboundedConfig True () $ + const + [ sizedBVSext (Proxy @10) a .== d, + a .== con 1, + d .== (con 1 :: SymIntN 10) + ] + testCegis unboundedConfig True () $ + const + [ sizedBVSext (Proxy @10) a .== d, + a .== con 0b11111, + d .== (con 0b1111111111 :: SymIntN 10) + ] + testCegis unboundedConfig False () $ + const + [ sizedBVSext (Proxy @10) a .== d, + d .== (con 0b111111 :: SymIntN 10) + ] + testCegis unboundedConfig False () $ + const + [ sizedBVSext (Proxy @10) a .== d, + d .== (con 0b11111 :: SymIntN 10) + ], + testCase "sizedBVSext when lowered twice" $ do + testCegis unboundedConfig True a $ \ca -> + [ sizedBVSext + (Proxy @10) + ( sizedBVSelect + (Proxy @2) + (Proxy @2) + (sizedBVConcat ca b) :: + SymIntN 2 + ) + .== (con 1 :: SymIntN 10) + ] + testCegis unboundedConfig True b $ + \cb -> + [ sizedBVSext + (Proxy @10) + ( sizedBVSelect + (Proxy @7) + (Proxy @2) + (sizedBVConcat a cb) :: + SymIntN 2 + ) + .== (con 1 :: SymIntN 10) + ] + ] + ] + ] diff --git a/test/Grisette/Backend/LoweringTests.hs b/test/Grisette/Backend/LoweringTests.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/Backend/LoweringTests.hs @@ -0,0 +1,834 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Grisette.Backend.LoweringTests (loweringTests) where + +import Control.Monad.Trans (MonadTrans (lift)) +import Data.Bits + ( Bits (complement, xor, (.&.), (.|.)), + ) +import Data.Dynamic (Typeable, fromDynamic) +import qualified Data.HashMap.Strict as M +import Data.Proxy (Proxy (Proxy)) +import qualified Data.SBV as SBV +import qualified Data.SBV.Control as SBV +import qualified Data.Text as T +import GHC.Stack (HasCallStack) +import Grisette + ( EvaluateSym (evaluateSym), + Function ((#)), + IntN, + LogicalOp ((.&&)), + SEq ((.==)), + Solvable (con), + SymInteger, + WordN, + solve, + type (-~>), + type (=~>), + ) +import Grisette.Internal.Backend.Solving + ( GrisetteSMTConfig (sbvConfig), + approx, + lowerSinglePrim, + precise, + ) +import Grisette.Internal.Backend.SymBiMap + ( SymBiMap (biMapToSBV), + ) +import Grisette.Internal.SymPrim.Prim.SomeTerm + ( SomeTerm (SomeTerm), + ) +import Grisette.Internal.SymPrim.Prim.Term + ( SBVRep (SBVType), + SupportedPrim, + Term, + absNumTerm, + addNumTerm, + andBitsTerm, + andTerm, + bvconcatTerm, + bvselectTerm, + bvsignExtendTerm, + bvzeroExtendTerm, + complementBitsTerm, + divIntegralTerm, + eqTerm, + iteTerm, + leOrdTerm, + ltOrdTerm, + modIntegralTerm, + mulNumTerm, + negNumTerm, + notTerm, + orBitsTerm, + orTerm, + quotIntegralTerm, + remIntegralTerm, + rotateLeftTerm, + rotateRightTerm, + shiftLeftTerm, + shiftRightTerm, + signumNumTerm, + ssymTerm, + toSignedTerm, + toUnsignedTerm, + xorBitsTerm, + ) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion, assertFailure, (@?=)) + +testUnaryOpLowering :: + forall a b as n. + ( HasCallStack, + SupportedPrim a, + SBV.EqSymbolic (SBVType n b), + Typeable (SBVType n a), + SBV.SymVal as, + SBVType n a ~ SBV.SBV as, + Show as + ) => + GrisetteSMTConfig n -> + (Term a -> Term b) -> + String -> + (SBVType n a -> SBVType n b) -> + Assertion +testUnaryOpLowering config f name sbvfun = do + let a :: Term a = ssymTerm "a" + let fa :: Term b = f a + SBV.runSMTWith (sbvConfig config) $ do + (m, lt) <- lowerSinglePrim config fa + let sbva :: Maybe (SBVType n a) = M.lookup (SomeTerm a) (biMapToSBV m) >>= fromDynamic + case sbva of + Nothing -> lift $ assertFailure "Failed to extract the term" + Just sbvav -> SBV.query $ do + SBV.constrain $ lt SBV..== sbvfun sbvav + satres <- SBV.checkSat + case satres of + SBV.Sat -> return () + _ -> lift $ assertFailure $ "Lowering for " ++ name ++ " generated unsolvable formula" + SBV.runSMTWith (sbvConfig config) $ do + (m, lt) <- lowerSinglePrim config fa + let sbvv :: Maybe (SBVType n a) = M.lookup (SomeTerm a) (biMapToSBV m) >>= fromDynamic + case sbvv of + Nothing -> lift $ assertFailure "Failed to extract the term" + Just sbvvv -> SBV.query $ do + SBV.constrain $ lt SBV../= sbvfun sbvvv + r <- SBV.checkSat + case r of + SBV.Sat -> do + counterExample <- SBV.getValue sbvvv + lift $ assertFailure $ "Translation counter example found: " ++ show counterExample + SBV.Unsat -> return () + _ -> lift $ assertFailure $ "Lowering for " ++ name ++ " generated unknown formula" + +-- testUnaryOpLowering' :: +-- forall a b as n tag. +-- ( HasCallStack, +-- UnaryOp tag a b, +-- SBV.EqSymbolic (SBVType n b), +-- Typeable (SBVType n a), +-- SBV.SymVal as, +-- SBVType n a ~ SBV.SBV as, +-- Show as +-- ) => +-- GrisetteSMTConfig n -> +-- tag -> +-- (SBVType n a -> SBVType n b) -> +-- Assertion +-- testUnaryOpLowering' config t = testUnaryOpLowering @a @b @as config (constructUnary t) (show t) + +testBinaryOpLowering :: + forall a b c as bs n. + ( HasCallStack, + SupportedPrim a, + SupportedPrim b, + SBV.EqSymbolic (SBVType n c), + Typeable (SBVType n a), + Typeable (SBVType n b), + SBV.SymVal as, + SBV.SymVal bs, + Show as, + Show bs, + SBVType n a ~ SBV.SBV as, + SBVType n b ~ SBV.SBV bs + ) => + GrisetteSMTConfig n -> + (Term a -> Term b -> Term c) -> + String -> + (SBVType n a -> SBVType n b -> SBVType n c) -> + Assertion +testBinaryOpLowering config f name sbvfun = do + let a :: Term a = ssymTerm "a" + let b :: Term b = ssymTerm "b" + let fab :: Term c = f a b + SBV.runSMTWith (sbvConfig config) $ do + (m, lt) <- lowerSinglePrim config fab + let sbva :: Maybe (SBVType n a) = M.lookup (SomeTerm a) (biMapToSBV m) >>= fromDynamic + let sbvb :: Maybe (SBVType n b) = M.lookup (SomeTerm b) (biMapToSBV m) >>= fromDynamic + case (sbva, sbvb) of + (Just sbvav, Just sbvbv) -> SBV.query $ do + SBV.constrain $ lt SBV..== sbvfun sbvav sbvbv + satres <- SBV.checkSat + case satres of + SBV.Sat -> return () + _ -> lift $ assertFailure $ "Lowering for " ++ name ++ " generated unsolvable formula" + _ -> lift $ assertFailure "Failed to extract the term" + SBV.runSMTWith (sbvConfig config) $ do + (m, lt) <- lowerSinglePrim config fab + let sbva :: Maybe (SBVType n a) = M.lookup (SomeTerm a) (biMapToSBV m) >>= fromDynamic + let sbvb :: Maybe (SBVType n b) = M.lookup (SomeTerm b) (biMapToSBV m) >>= fromDynamic + case (sbva, sbvb) of + (Just sbvav, Just sbvbv) -> SBV.query $ do + SBV.constrain $ lt SBV../= sbvfun sbvav sbvbv + r <- SBV.checkSat + case r of + SBV.Sat -> do + counterExampleA <- SBV.getValue sbvav + counterExampleB <- SBV.getValue sbvbv + lift $ assertFailure $ "Translation counter example found: " ++ show (counterExampleA, counterExampleB) + SBV.Unsat -> return () + _ -> lift $ assertFailure $ "Lowering for " ++ name ++ " generated unknown formula" + _ -> lift $ assertFailure "Failed to extract the term" + +-- testBinaryOpLowering' :: +-- forall a b c as bs n tag. +-- ( HasCallStack, +-- BinaryOp tag a b c, +-- SBV.EqSymbolic (SBVType n c), +-- Typeable (SBVType n a), +-- Typeable (SBVType n b), +-- SBV.SymVal as, +-- SBV.SymVal bs, +-- Show as, +-- Show bs, +-- SBVType n a ~ SBV.SBV as, +-- SBVType n b ~ SBV.SBV bs +-- ) => +-- GrisetteSMTConfig n -> +-- tag -> +-- (SBVType n a -> SBVType n b -> SBVType n c) -> +-- Assertion +-- testBinaryOpLowering' config t = testBinaryOpLowering @a @b @c @as @bs config (constructBinary t) (show t) + +testTernaryOpLowering :: + forall a b c d as bs cs n. + ( HasCallStack, + SupportedPrim a, + SupportedPrim b, + SupportedPrim c, + SBV.EqSymbolic (SBVType n d), + Typeable (SBVType n a), + Typeable (SBVType n b), + Typeable (SBVType n c), + SBV.SymVal as, + SBV.SymVal bs, + SBV.SymVal cs, + Show as, + Show bs, + Show cs, + SBVType n a ~ SBV.SBV as, + SBVType n b ~ SBV.SBV bs, + SBVType n c ~ SBV.SBV cs + ) => + GrisetteSMTConfig n -> + (Term a -> Term b -> Term c -> Term d) -> + T.Text -> + (SBVType n a -> SBVType n b -> SBVType n c -> SBVType n d) -> + Assertion +testTernaryOpLowering config f name sbvfun = do + let a :: Term a = ssymTerm "a" + let b :: Term b = ssymTerm "b" + let c :: Term c = ssymTerm "c" + let fabc :: Term d = f a b c + SBV.runSMTWith (sbvConfig config) $ do + (m, lt) <- lowerSinglePrim config fabc + let sbva :: Maybe (SBVType n a) = M.lookup (SomeTerm a) (biMapToSBV m) >>= fromDynamic + let sbvb :: Maybe (SBVType n b) = M.lookup (SomeTerm b) (biMapToSBV m) >>= fromDynamic + let sbvc :: Maybe (SBVType n c) = M.lookup (SomeTerm c) (biMapToSBV m) >>= fromDynamic + case (sbva, sbvb, sbvc) of + (Just sbvav, Just sbvbv, Just sbvcv) -> SBV.query $ do + SBV.constrain $ lt SBV..== sbvfun sbvav sbvbv sbvcv + satres <- SBV.checkSat + case satres of + SBV.Sat -> return () + _ -> lift $ assertFailure $ T.unpack $ "Lowering for " <> name <> " generated unsolvable formula" + _ -> lift $ assertFailure "Failed to extract the term" + SBV.runSMTWith (sbvConfig config) $ do + (m, lt) <- lowerSinglePrim config fabc + let sbva :: Maybe (SBVType n a) = M.lookup (SomeTerm a) (biMapToSBV m) >>= fromDynamic + let sbvb :: Maybe (SBVType n b) = M.lookup (SomeTerm b) (biMapToSBV m) >>= fromDynamic + let sbvc :: Maybe (SBVType n c) = M.lookup (SomeTerm c) (biMapToSBV m) >>= fromDynamic + case (sbva, sbvb, sbvc) of + (Just sbvav, Just sbvbv, Just sbvcv) -> SBV.query $ do + SBV.constrain $ lt SBV../= sbvfun sbvav sbvbv sbvcv + r <- SBV.checkSat + case r of + SBV.Sat -> do + counterExampleA <- SBV.getValue sbvav + counterExampleB <- SBV.getValue sbvbv + counterExampleC <- SBV.getValue sbvcv + lift $ + assertFailure $ + "Translation counter example found: " + ++ show (counterExampleA, counterExampleB, counterExampleC) + SBV.Unsat -> return () + _ -> lift $ assertFailure $ T.unpack $ "Lowering for " <> name <> " generated unknown formula" + _ -> lift $ assertFailure "Failed to extract the term" + +-- testTernaryOpLowering' :: +-- forall a b c d as bs cs n tag. +-- ( HasCallStack, +-- TernaryOp tag a b c d, +-- SBV.EqSymbolic (SBVType n d), +-- Typeable (SBVType n a), +-- Typeable (SBVType n b), +-- Typeable (SBVType n c), +-- SBV.SymVal as, +-- SBV.SymVal bs, +-- SBV.SymVal cs, +-- Show as, +-- Show bs, +-- Show cs, +-- SBVType n a ~ SBV.SBV as, +-- SBVType n b ~ SBV.SBV bs, +-- SBVType n c ~ SBV.SBV cs +-- ) => +-- GrisetteSMTConfig n -> +-- tag -> +-- (SBVType n a -> SBVType n b -> SBVType n c -> SBVType n d) -> +-- Assertion +-- testTernaryOpLowering' config t = testTernaryOpLowering @a @b @c @d @as @bs @cs config (constructTernary t) (show t) + +loweringTests :: Test +loweringTests = + let unboundedConfig = precise SBV.z3 + boundedConfig = approx (Proxy @5) SBV.z3 + in testGroup + "Lowering" + [ testGroup + "Bool Lowering" + [ testCase "Not" $ do + testUnaryOpLowering @Bool @Bool unboundedConfig notTerm "not" SBV.sNot, + testCase "And" $ do + testBinaryOpLowering @Bool @Bool @Bool unboundedConfig andTerm "and" (SBV..&&) + testBinaryOpLowering @Bool @Bool @Bool + unboundedConfig + andTerm + "and" + (\x y -> SBV.sNot (x SBV..<+> y) SBV..&& (x SBV..|| y)), + testCase "Or" $ do + testBinaryOpLowering @Bool @Bool @Bool unboundedConfig orTerm "or" (SBV..||) + testBinaryOpLowering @Bool @Bool @Bool + unboundedConfig + orTerm + "or" + (\x y -> (x SBV..<+> y) SBV..|| (x SBV..&& y)), + testCase "Eqv" $ do + testBinaryOpLowering @Bool @Bool @Bool unboundedConfig eqTerm "eqv" (SBV..==) + testBinaryOpLowering @Bool @Bool @Bool + unboundedConfig + eqTerm + "eqv" + (\x y -> SBV.sNot (x SBV..<+> y)), + testCase "ITE" $ do + testTernaryOpLowering @Bool @Bool @Bool @Bool unboundedConfig iteTerm "ite" SBV.ite + testTernaryOpLowering @Bool @Bool @Bool @Bool + unboundedConfig + iteTerm + "ite" + (\c x y -> (c SBV..=> x) SBV..&& (SBV.sNot c SBV..=> y)) + ], + testGroup + "Integer Lowering" + [ testCase "Add" $ do + testBinaryOpLowering @Integer @Integer @Integer unboundedConfig addNumTerm "(+)" (+) + testBinaryOpLowering @Integer @Integer @Integer + unboundedConfig + addNumTerm + "(+)" + (\x y -> (x + 1) * (y + 1) - x * y - 1) + testBinaryOpLowering @Integer @Integer @Integer boundedConfig addNumTerm "(+)" (+) + testBinaryOpLowering @Integer @Integer @Integer + boundedConfig + addNumTerm + "(+)" + (\x y -> (x + 1) * (y + 1) - x * y - 1), + testCase "Uminus" $ do + testUnaryOpLowering @Integer @Integer unboundedConfig negNumTerm "negate" negate + testUnaryOpLowering @Integer @Integer + unboundedConfig + negNumTerm + "negate" + (\x -> (x + 1) * (x + 1) - 3 * x - x * x - 1) + testUnaryOpLowering @Integer @Integer boundedConfig negNumTerm "negate" negate + testUnaryOpLowering @Integer @Integer + boundedConfig + negNumTerm + "negate" + (\x -> (x + 1) * (x + 1) - 3 * x - x * x - 1), + testCase "Abs" $ do + testUnaryOpLowering @Integer @Integer unboundedConfig absNumTerm "abs" abs + testUnaryOpLowering @Integer @Integer boundedConfig absNumTerm "abs" abs, + testCase "Signum" $ do + testUnaryOpLowering @Integer @Integer unboundedConfig signumNumTerm "signum" signum + testUnaryOpLowering @Integer @Integer boundedConfig signumNumTerm "signum" signum, + testCase "Times" $ do + testBinaryOpLowering @Integer @Integer @Integer unboundedConfig mulNumTerm "(*)" (*) + testBinaryOpLowering @Integer @Integer @Integer + unboundedConfig + mulNumTerm + "(*)" + (\x y -> (x + 1) * (y + 1) - x - y - 1) + testBinaryOpLowering @Integer @Integer @Integer boundedConfig mulNumTerm "(*)" (*) + testBinaryOpLowering @Integer @Integer @Integer + boundedConfig + mulNumTerm + "(*)" + (\x y -> (x + 1) * (y + 1) - x - y - 1), + testCase "Lt" $ do + testBinaryOpLowering @Integer @Integer @Bool unboundedConfig ltOrdTerm "(<)" (SBV..<) + testBinaryOpLowering @Integer @Integer @Bool + unboundedConfig + ltOrdTerm + "(<)" + (\x y -> x * 2 - x SBV..< y * 2 - y) + testBinaryOpLowering @Integer @Integer @Bool boundedConfig ltOrdTerm "(<)" (SBV..<) + testBinaryOpLowering @Integer @Integer @Bool + boundedConfig + ltOrdTerm + "(<=)" + (\x y -> x * 2 - x SBV..< y * 2 - y), + testCase "Le" $ do + testBinaryOpLowering @Integer @Integer @Bool unboundedConfig leOrdTerm "(<=)" (SBV..<=) + testBinaryOpLowering @Integer @Integer @Bool + unboundedConfig + leOrdTerm + "(<=)" + (\x y -> x * 2 - x SBV..<= y * 2 - y) + testBinaryOpLowering @Integer @Integer @Bool boundedConfig leOrdTerm "(<=)" (SBV..<=) + testBinaryOpLowering @Integer @Integer @Bool + boundedConfig + leOrdTerm + "(<=)" + (\x y -> x * 2 - x SBV..<= y * 2 - y), + testCase "Div" $ do + testBinaryOpLowering @Integer @Integer @Integer unboundedConfig divIntegralTerm "div" SBV.sDiv + testBinaryOpLowering @Integer @Integer @Integer boundedConfig divIntegralTerm "div" SBV.sDiv, + testCase "Mod" $ do + testBinaryOpLowering @Integer @Integer @Integer unboundedConfig modIntegralTerm "mod" SBV.sMod + testBinaryOpLowering @Integer @Integer @Integer boundedConfig modIntegralTerm "mod" SBV.sMod, + testCase "Quot" $ do + testBinaryOpLowering @Integer @Integer @Integer unboundedConfig quotIntegralTerm "quot" SBV.sQuot + testBinaryOpLowering @Integer @Integer @Integer boundedConfig quotIntegralTerm "quot" SBV.sQuot, + testCase "Rem" $ do + testBinaryOpLowering @Integer @Integer @Integer unboundedConfig remIntegralTerm "rem" SBV.sRem + testBinaryOpLowering @Integer @Integer @Integer boundedConfig remIntegralTerm "rem" SBV.sRem + ], + testGroup + "IntN Lowering" + [ testCase "Add" $ do + testBinaryOpLowering @(IntN 5) @(IntN 5) unboundedConfig addNumTerm "(+)" (+) + testBinaryOpLowering @(IntN 5) @(IntN 5) + unboundedConfig + addNumTerm + "(+)" + (\x y -> (x + 1) * (y + 1) - x * y - 1), + testCase "Uminus" $ do + testUnaryOpLowering @(IntN 5) unboundedConfig negNumTerm "negate" negate + testUnaryOpLowering @(IntN 5) + unboundedConfig + negNumTerm + "negate" + (\x -> (x + 1) * (x + 1) - 3 * x - x * x - 1), + testCase "Abs" $ do + testUnaryOpLowering @(IntN 5) unboundedConfig absNumTerm "abs" abs, + testCase "Signum" $ do + testUnaryOpLowering @(IntN 5) unboundedConfig signumNumTerm "signum" signum, + testCase "Times" $ do + testBinaryOpLowering @(IntN 5) @(IntN 5) unboundedConfig mulNumTerm "(*)" (*) + testBinaryOpLowering @(IntN 5) @(IntN 5) + unboundedConfig + mulNumTerm + "(*)" + (\x y -> (x + 1) * (y + 1) - x - y - 1), + testCase "Lt" $ do + testBinaryOpLowering @(IntN 5) @(IntN 5) unboundedConfig ltOrdTerm "(<)" (SBV..<) + testBinaryOpLowering @(IntN 5) @(IntN 5) + unboundedConfig + ltOrdTerm + "(<)" + (\x y -> x * 2 - x SBV..< y * 2 - y), + testCase "Le" $ do + testBinaryOpLowering @(IntN 5) @(IntN 5) unboundedConfig leOrdTerm "(<=)" (SBV..<=) + testBinaryOpLowering @(IntN 5) @(IntN 5) + unboundedConfig + leOrdTerm + "(<=)" + (\x y -> x * 2 - x SBV..<= y * 2 - y), + testCase "Extract" $ do + testUnaryOpLowering @(IntN 5) @(IntN 1) + unboundedConfig + (bvselectTerm (Proxy @0) (Proxy @1)) + "select" + (SBV.bvExtract @0 @0 @5 Proxy Proxy) + testUnaryOpLowering @(IntN 5) @(IntN 1) + unboundedConfig + (bvselectTerm (Proxy @1) (Proxy @1)) + "select" + (SBV.bvExtract @1 @1 @5 Proxy Proxy) + testUnaryOpLowering @(IntN 5) @(IntN 1) + unboundedConfig + (bvselectTerm (Proxy @2) (Proxy @1)) + "select" + (SBV.bvExtract @2 @2 @5 Proxy Proxy) + testUnaryOpLowering @(IntN 5) @(IntN 1) + unboundedConfig + (bvselectTerm (Proxy @3) (Proxy @1)) + "select" + (SBV.bvExtract @3 @3 @5 Proxy Proxy) + testUnaryOpLowering @(IntN 5) @(IntN 1) + unboundedConfig + (bvselectTerm (Proxy @4) (Proxy @1)) + "select" + (SBV.bvExtract @4 @4 @5 Proxy Proxy) + testUnaryOpLowering @(IntN 5) @(IntN 2) + unboundedConfig + (bvselectTerm (Proxy @0) (Proxy @2)) + "select" + (SBV.bvExtract @1 @0 @5 Proxy Proxy) + testUnaryOpLowering @(IntN 5) @(IntN 2) + unboundedConfig + (bvselectTerm (Proxy @1) (Proxy @2)) + "select" + (SBV.bvExtract @2 @1 @5 Proxy Proxy) + testUnaryOpLowering @(IntN 5) @(IntN 2) + unboundedConfig + (bvselectTerm (Proxy @2) (Proxy @2)) + "select" + (SBV.bvExtract @3 @2 @5 Proxy Proxy) + testUnaryOpLowering @(IntN 5) @(IntN 2) + unboundedConfig + (bvselectTerm (Proxy @3) (Proxy @2)) + "select" + (SBV.bvExtract @4 @3 @5 Proxy Proxy) + testUnaryOpLowering @(IntN 5) @(IntN 3) + unboundedConfig + (bvselectTerm (Proxy @0) (Proxy @3)) + "select" + (SBV.bvExtract @2 @0 @5 Proxy Proxy) + testUnaryOpLowering @(IntN 5) @(IntN 3) + unboundedConfig + (bvselectTerm (Proxy @1) (Proxy @3)) + "select" + (SBV.bvExtract @3 @1 @5 Proxy Proxy) + testUnaryOpLowering @(IntN 5) @(IntN 3) + unboundedConfig + (bvselectTerm (Proxy @2) (Proxy @3)) + "select" + (SBV.bvExtract @4 @2 @5 Proxy Proxy) + testUnaryOpLowering @(IntN 5) @(IntN 4) + unboundedConfig + (bvselectTerm (Proxy @0) (Proxy @4)) + "select" + (SBV.bvExtract @3 @0 @5 Proxy Proxy) + testUnaryOpLowering @(IntN 5) @(IntN 4) + unboundedConfig + (bvselectTerm (Proxy @1) (Proxy @4)) + "select" + (SBV.bvExtract @4 @1 @5 Proxy Proxy) + testUnaryOpLowering @(IntN 5) @(IntN 5) + unboundedConfig + (bvselectTerm (Proxy @0) (Proxy @5)) + "select" + id, + testCase "Extension" $ do + testUnaryOpLowering @(IntN 5) @(IntN 6) + unboundedConfig + (bvzeroExtendTerm (Proxy @6)) + "bvzeroExtend" + SBV.zeroExtend + testUnaryOpLowering @(IntN 5) @(IntN 10) + unboundedConfig + (bvzeroExtendTerm (Proxy @10)) + "bvzeroExtend" + SBV.zeroExtend + testUnaryOpLowering @(IntN 5) @(IntN 6) + unboundedConfig + (bvsignExtendTerm (Proxy @6)) + "bvsignExtend" + SBV.signExtend + testUnaryOpLowering @(IntN 5) @(IntN 10) + unboundedConfig + (bvsignExtendTerm (Proxy @10)) + "bvsignExtend" + SBV.signExtend, + testCase "Concat" $ do + testBinaryOpLowering @(IntN 4) @(IntN 5) @(IntN 9) + unboundedConfig + bvconcatTerm + "bvconcat" + (SBV.#), + testCase "AndBits" $ do + testBinaryOpLowering @(IntN 5) @(IntN 5) unboundedConfig andBitsTerm "(.&.)" (.&.), + testCase "OrBits" $ do + testBinaryOpLowering @(IntN 5) @(IntN 5) unboundedConfig orBitsTerm "(.|.)" (.|.), + testCase "XorBits" $ do + testBinaryOpLowering @(IntN 5) @(IntN 5) unboundedConfig xorBitsTerm "xor" xor, + testCase "ComplementBits" $ do + testUnaryOpLowering @(IntN 5) unboundedConfig complementBitsTerm "complement" complement, + testCase "ShiftLeft" $ do + testBinaryOpLowering @(IntN 5) unboundedConfig shiftLeftTerm "shiftLeft" SBV.sShiftLeft, + testCase "ShiftRight" $ do + testBinaryOpLowering @(IntN 5) unboundedConfig shiftRightTerm "shiftRight" SBV.sShiftRight, + testCase "RotateLeft" $ do + testBinaryOpLowering @(IntN 5) + unboundedConfig + rotateLeftTerm + "rotateLeft" + ( \a b -> + SBV.sFromIntegral $ + SBV.sRotateLeft + (SBV.sFromIntegral a :: SBV.SWord 5) + (SBV.sFromIntegral b :: SBV.SWord 5) + ), + testCase "RotateRight" $ do + testBinaryOpLowering @(IntN 5) + unboundedConfig + rotateRightTerm + "rotateRight" + ( \a b -> + SBV.sFromIntegral $ + SBV.sRotateRight + (SBV.sFromIntegral a :: SBV.SWord 5) + (SBV.sFromIntegral b :: SBV.SWord 5) + ), + testCase "Div - bounded" $ do + testBinaryOpLowering @(IntN 5) @(IntN 5) @(IntN 5) unboundedConfig divIntegralTerm "div" SBV.sDiv + testBinaryOpLowering @(IntN 5) @(IntN 5) @(IntN 5) boundedConfig divIntegralTerm "div" SBV.sDiv, + testCase "Mod - bounded" $ do + testBinaryOpLowering @(IntN 5) @(IntN 5) @(IntN 5) unboundedConfig modIntegralTerm "mod" SBV.sMod + testBinaryOpLowering @(IntN 5) @(IntN 5) @(IntN 5) boundedConfig modIntegralTerm "mod" SBV.sMod, + testCase "Quot - bounded" $ do + testBinaryOpLowering @(IntN 5) @(IntN 5) @(IntN 5) unboundedConfig quotIntegralTerm "quot" SBV.sQuot + testBinaryOpLowering @(IntN 5) @(IntN 5) @(IntN 5) boundedConfig quotIntegralTerm "quot" SBV.sQuot, + testCase "Rem - bounded" $ do + testBinaryOpLowering @(IntN 5) @(IntN 5) @(IntN 5) unboundedConfig remIntegralTerm "rem" SBV.sRem + testBinaryOpLowering @(IntN 5) @(IntN 5) @(IntN 5) boundedConfig remIntegralTerm "rem" SBV.sRem, + testCase "ToUnsigned" $ do + testUnaryOpLowering @(IntN 5) @(WordN 5) unboundedConfig toUnsignedTerm "toUnsigned" SBV.sFromIntegral + testUnaryOpLowering @(IntN 5) @(WordN 5) boundedConfig toUnsignedTerm "toUnsigned" SBV.sFromIntegral + ], + testGroup + "WordN" + [ testCase "Add" $ do + testBinaryOpLowering @(WordN 5) @(WordN 5) unboundedConfig addNumTerm "(+)" (+) + testBinaryOpLowering @(WordN 5) @(WordN 5) + unboundedConfig + addNumTerm + "(+)" + (\x y -> (x + 1) * (y + 1) - x * y - 1), + testCase "Uminus" $ do + testUnaryOpLowering @(WordN 5) unboundedConfig negNumTerm "negate" negate + testUnaryOpLowering @(WordN 5) + unboundedConfig + negNumTerm + "negate" + (\x -> (x + 1) * (x + 1) - 3 * x - x * x - 1), + testCase "Abs" $ do + testUnaryOpLowering @(WordN 5) unboundedConfig absNumTerm "abs" abs, + testCase "Signum" $ do + testUnaryOpLowering @(WordN 5) unboundedConfig signumNumTerm "signum" signum, + testCase "Times" $ do + testBinaryOpLowering @(WordN 5) @(WordN 5) unboundedConfig mulNumTerm "(*)" (*) + testBinaryOpLowering @(WordN 5) @(WordN 5) + unboundedConfig + mulNumTerm + "(*)" + (\x y -> (x + 1) * (y + 1) - x - y - 1), + testCase "Lt" $ do + testBinaryOpLowering @(WordN 5) @(WordN 5) unboundedConfig ltOrdTerm "(<)" (SBV..<) + testBinaryOpLowering @(WordN 5) @(WordN 5) + unboundedConfig + ltOrdTerm + "(<)" + (\x y -> x * 2 - x SBV..< y * 2 - y), + testCase "Le" $ do + testBinaryOpLowering @(WordN 5) @(WordN 5) unboundedConfig leOrdTerm "(<=)" (SBV..<=) + testBinaryOpLowering @(WordN 5) @(WordN 5) + unboundedConfig + leOrdTerm + "(<=)" + (\x y -> x * 2 - x SBV..<= y * 2 - y), + testCase "Extract" $ do + testUnaryOpLowering @(WordN 5) @(WordN 1) + unboundedConfig + (bvselectTerm (Proxy @0) (Proxy @1)) + "select" + (SBV.bvExtract @0 @0 @5 Proxy Proxy) + testUnaryOpLowering @(WordN 5) @(WordN 1) + unboundedConfig + (bvselectTerm (Proxy @1) (Proxy @1)) + "select" + (SBV.bvExtract @1 @1 @5 Proxy Proxy) + testUnaryOpLowering @(WordN 5) @(WordN 1) + unboundedConfig + (bvselectTerm (Proxy @2) (Proxy @1)) + "select" + (SBV.bvExtract @2 @2 @5 Proxy Proxy) + testUnaryOpLowering @(WordN 5) @(WordN 1) + unboundedConfig + (bvselectTerm (Proxy @3) (Proxy @1)) + "select" + (SBV.bvExtract @3 @3 @5 Proxy Proxy) + testUnaryOpLowering @(WordN 5) @(WordN 1) + unboundedConfig + (bvselectTerm (Proxy @4) (Proxy @1)) + "select" + (SBV.bvExtract @4 @4 @5 Proxy Proxy) + testUnaryOpLowering @(WordN 5) @(WordN 2) + unboundedConfig + (bvselectTerm (Proxy @0) (Proxy @2)) + "select" + (SBV.bvExtract @1 @0 @5 Proxy Proxy) + testUnaryOpLowering @(WordN 5) @(WordN 2) + unboundedConfig + (bvselectTerm (Proxy @1) (Proxy @2)) + "select" + (SBV.bvExtract @2 @1 @5 Proxy Proxy) + testUnaryOpLowering @(WordN 5) @(WordN 2) + unboundedConfig + (bvselectTerm (Proxy @2) (Proxy @2)) + "select" + (SBV.bvExtract @3 @2 @5 Proxy Proxy) + testUnaryOpLowering @(WordN 5) @(WordN 2) + unboundedConfig + (bvselectTerm (Proxy @3) (Proxy @2)) + "select" + (SBV.bvExtract @4 @3 @5 Proxy Proxy) + testUnaryOpLowering @(WordN 5) @(WordN 3) + unboundedConfig + (bvselectTerm (Proxy @0) (Proxy @3)) + "select" + (SBV.bvExtract @2 @0 @5 Proxy Proxy) + testUnaryOpLowering @(WordN 5) @(WordN 3) + unboundedConfig + (bvselectTerm (Proxy @1) (Proxy @3)) + "select" + (SBV.bvExtract @3 @1 @5 Proxy Proxy) + testUnaryOpLowering @(WordN 5) @(WordN 3) + unboundedConfig + (bvselectTerm (Proxy @2) (Proxy @3)) + "select" + (SBV.bvExtract @4 @2 @5 Proxy Proxy) + testUnaryOpLowering @(WordN 5) @(WordN 4) + unboundedConfig + (bvselectTerm (Proxy @0) (Proxy @4)) + "select" + (SBV.bvExtract @3 @0 @5 Proxy Proxy) + testUnaryOpLowering @(WordN 5) @(WordN 4) + unboundedConfig + (bvselectTerm (Proxy @1) (Proxy @4)) + "select" + (SBV.bvExtract @4 @1 @5 Proxy Proxy) + testUnaryOpLowering @(WordN 5) @(WordN 5) + unboundedConfig + (bvselectTerm (Proxy @0) (Proxy @5)) + "select" + id, + testCase "Extension" $ do + testUnaryOpLowering @(WordN 5) @(WordN 6) + unboundedConfig + (bvzeroExtendTerm (Proxy @6)) + "bvzeroExtend" + SBV.zeroExtend + testUnaryOpLowering @(WordN 5) @(WordN 10) + unboundedConfig + (bvzeroExtendTerm (Proxy @10)) + "bvzeroExtend" + SBV.zeroExtend + testUnaryOpLowering @(WordN 5) @(WordN 6) + unboundedConfig + (bvsignExtendTerm (Proxy @6)) + "bvsignExtend" + SBV.signExtend + testUnaryOpLowering @(WordN 5) @(WordN 10) + unboundedConfig + (bvsignExtendTerm (Proxy @10)) + "bvsignExtend" + SBV.signExtend, + testCase "Concat" $ do + testBinaryOpLowering @(WordN 4) @(WordN 5) @(WordN 9) + unboundedConfig + bvconcatTerm + "bvconcat" + (SBV.#), + testCase "AndBits" $ do + testBinaryOpLowering @(WordN 5) @(WordN 5) unboundedConfig andBitsTerm "(.&.)" (.&.), + testCase "OrBits" $ do + testBinaryOpLowering @(WordN 5) @(WordN 5) unboundedConfig orBitsTerm "(.|.)" (.|.), + testCase "XorBits" $ do + testBinaryOpLowering @(WordN 5) @(WordN 5) unboundedConfig xorBitsTerm "xor" xor, + testCase "ComplementBits" $ do + testUnaryOpLowering @(WordN 5) unboundedConfig complementBitsTerm "complement" complement, + testCase "ShiftLeft" $ do + testBinaryOpLowering @(WordN 5) unboundedConfig shiftLeftTerm "shiftLeft" SBV.sShiftLeft, + testCase "ShiftRight" $ do + testBinaryOpLowering @(WordN 5) unboundedConfig shiftRightTerm "shiftRight" SBV.sShiftRight, + testCase "RotateLeft" $ do + testBinaryOpLowering @(WordN 5) unboundedConfig rotateLeftTerm "rotateLeft" SBV.sRotateLeft, + testCase "RotateRight" $ do + testBinaryOpLowering @(WordN 5) unboundedConfig rotateRightTerm "rotateRight" SBV.sRotateRight, + testCase "Div" $ do + testBinaryOpLowering @(WordN 5) @(WordN 5) @(WordN 5) unboundedConfig divIntegralTerm "div" SBV.sDiv + testBinaryOpLowering @(WordN 5) @(WordN 5) @(WordN 5) boundedConfig divIntegralTerm "div" SBV.sDiv, + testCase "Mod" $ do + testBinaryOpLowering @(WordN 5) @(WordN 5) @(WordN 5) unboundedConfig modIntegralTerm "mod" SBV.sMod + testBinaryOpLowering @(WordN 5) @(WordN 5) @(WordN 5) boundedConfig modIntegralTerm "mod" SBV.sMod, + testCase "Quot" $ do + testBinaryOpLowering @(WordN 5) @(WordN 5) @(WordN 5) unboundedConfig quotIntegralTerm "quot" SBV.sQuot + testBinaryOpLowering @(WordN 5) @(WordN 5) @(WordN 5) boundedConfig quotIntegralTerm "quot" SBV.sQuot, + testCase "Rem" $ do + testBinaryOpLowering @(WordN 5) @(WordN 5) @(WordN 5) unboundedConfig remIntegralTerm "rem" SBV.sRem + testBinaryOpLowering @(WordN 5) @(WordN 5) @(WordN 5) boundedConfig remIntegralTerm "rem" SBV.sRem, + testCase "ToSigned" $ do + testUnaryOpLowering @(WordN 5) @(IntN 5) unboundedConfig toSignedTerm "toSigned" SBV.sFromIntegral + testUnaryOpLowering @(WordN 5) @(IntN 5) boundedConfig toSignedTerm "toSigned" SBV.sFromIntegral + ], + testCase "TabularFun" $ do + let f = "f" :: SymInteger =~> SymInteger =~> SymInteger + let a = "a" :: SymInteger + let b = "b" :: SymInteger + let c = "c" :: SymInteger + let d = "d" :: SymInteger + Right m <- + solve unboundedConfig $ + (f # a # b .== a + b .&& a .== 10 .&& b .== 20) + .&& (f # a # c .== a + c .&& a .== 10 .&& c .== 30) + .&& (f # a # d .== a + d .&& a .== 10 .&& d .== 40) + evaluateSym False m (f # a # b .== a + b) @?= con True + evaluateSym False m (f # a # c .== a + c) @?= con True + evaluateSym False m (f # a # d .== a + d) @?= con True, + testCase "GeneralFun" $ do + let f = "f" :: SymInteger -~> SymInteger -~> SymInteger + let a = "a" :: SymInteger + let b = "b" :: SymInteger + let c = "c" :: SymInteger + let d = "d" :: SymInteger + Right m <- + solve unboundedConfig $ + (f # a # b .== a + b .&& a .== 10 .&& b .== 20) + .&& (f # a # c .== a + c .&& a .== 10 .&& c .== 30) + .&& (f # a # d .== a + d .&& a .== 10 .&& d .== 40) + evaluateSym False m (f # a # b .== a + b) @?= con True + evaluateSym False m (f # a # c .== a + c) @?= con True + evaluateSym False m (f # a # d .== a + d) @?= con True + ] diff --git a/test/Grisette/Backend/SBV/Data/SMT/CEGISTests.hs b/test/Grisette/Backend/SBV/Data/SMT/CEGISTests.hs deleted file mode 100644 --- a/test/Grisette/Backend/SBV/Data/SMT/CEGISTests.hs +++ /dev/null @@ -1,415 +0,0 @@ -{-# LANGUAGE BinaryLiterals #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} - -module Grisette.Backend.SBV.Data.SMT.CEGISTests (cegisTests) where - -import Control.Monad.Except (ExceptT) -import Data.Proxy (Proxy (Proxy)) -import qualified Data.SBV as SBV -import Data.String (IsString (fromString)) -import GHC.Stack (HasCallStack) -import Grisette.Backend.SBV (GrisetteSMTConfig, precise, z3) -import Grisette.Core.Control.Exception - ( VerificationConditions, - ) -import Grisette.Core.Control.Monad.UnionM (UnionM) -import Grisette.Core.Data.Class.BitVector - ( SizedBV (sizedBVConcat, sizedBVSelect, sizedBVSext, sizedBVZext), - ) -import Grisette.Core.Data.Class.CEGISSolver - ( CEGISResult (CEGISSuccess), - cegis, - cegisExceptVC, - cegisForAllExceptVC, - cegisMultiInputs, - cegisPostCond, - ) -import Grisette.Core.Data.Class.Error - ( symAssert, - symAssume, - ) -import Grisette.Core.Data.Class.EvaluateSym (EvaluateSym (evaluateSym)) -import Grisette.Core.Data.Class.ExtractSymbolics - ( ExtractSymbolics, - ) -import Grisette.Core.Data.Class.Function (Apply (apply), Function ((#))) -import Grisette.Core.Data.Class.ITEOp (ITEOp (symIte)) -import Grisette.Core.Data.Class.LogicalOp - ( LogicalOp (symNot, symXor, (.&&), (.||)), - ) -import Grisette.Core.Data.Class.SEq (SEq ((.==))) -import Grisette.Core.Data.Class.SOrd (SOrd ((.<), (.>=))) -import Grisette.Core.Data.Class.SimpleMergeable (mrgIf) -import Grisette.Core.Data.Class.Solvable (Solvable (con)) -import Grisette.Core.Data.Class.Solver (solve) -import Grisette.IR.SymPrim.Data.SymPrim - ( SymBool, - SymIntN, - SymInteger, - type (-~>), - type (=~>), - ) -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (Assertion, assertFailure, (@=?)) - -testCegis :: - (HasCallStack, ExtractSymbolics a, EvaluateSym a, Show a, SEq a) => - GrisetteSMTConfig i -> - Bool -> - a -> - (a -> [SymBool]) -> - Assertion -testCegis config shouldSuccess inputs bs = do - cegisExceptVCResult <- - cegisExceptVC config (inputs, "internal" :: SymInteger) return $ - \(cexInputs, internal) -> buildFormula internal (bs cexInputs) - case cegisExceptVCResult of - (_, CEGISSuccess m) -> do - shouldSuccess @=? True - verify "cegisExceptVC" m (bs inputs) - _ -> shouldSuccess @=? False - cegisForAllExceptVCResult <- - cegisForAllExceptVC config (inputs, "internal" :: SymInteger) return $ - buildFormula "internal" (bs inputs) - case cegisForAllExceptVCResult of - (_, CEGISSuccess m) -> do - shouldSuccess @=? True - verify "cegisForAllExceptVC" m (bs inputs) - _ -> shouldSuccess @=? False - where - verify _ _ [] = return () - verify funName m (v : vs) = do - y <- solve config (evaluateSym False m $ symNot v) - case y of - Left _ -> verify funName m vs - Right _ -> - assertFailure $ - funName - ++ ": Failed to verify " - ++ show v - ++ " with the model " - ++ show m - buildFormula internal l = do - symAssume (internal .>= 0) - go l 0 - where - go :: - [SymBool] -> SymInteger -> ExceptT VerificationConditions UnionM () - go [] _ = return () - go (x : xs) i = - mrgIf - (internal .>= i .&& internal .< (i + 1)) - (symAssert x) - (go xs (i + 1)) - -cegisTests :: Test -cegisTests = - let unboundedConfig = precise SBV.z3 - in testGroup - "CEGIS" - [ testGroup - "Regression" - [ testCase "Empty symbolic inputs makes cegis work like solve" $ do - (_, CEGISSuccess m1) <- - cegisMultiInputs - (precise z3) - [1 :: Integer, 2] - (\idx -> cegisPostCond $ fromString $ "a" ++ show idx) - Right m2 <- solve (precise z3) ("a1" .&& "a2") - m1 @=? m2, - testCase "Lowering of TabularFun" $ do - let s1 = "s1" :: SymInteger =~> SymInteger - let s2 = "s2" :: SymInteger =~> SymInteger - (_, CEGISSuccess m1) <- - cegis unboundedConfig ("cond" :: SymBool) $ - \cond -> - cegisPostCond $ - apply (symIte cond s1 s2) (symIte cond 1 2) - .== 10 - .&& apply (symIte cond s1 s2) (symIte cond 3 4) - .== 100 - let s1e = evaluateSym False m1 s1 - let s2e = evaluateSym False m1 s2 - s1e # 1 @=? 10 - s1e # 3 @=? 100 - s2e # 2 @=? 10 - s2e # 4 @=? 100, - testCase "Lowering of GeneralFun" $ do - let s1 = "s1" :: SymInteger -~> SymInteger - let s2 = "s2" :: SymInteger -~> SymInteger - (_, CEGISSuccess m1) <- - cegis unboundedConfig ("cond" :: SymBool) $ - \cond -> - cegisPostCond $ - apply (symIte cond s1 s2) (symIte cond 1 2) - .== 10 - .&& apply (symIte cond s1 s2) (symIte cond 3 4) - .== 100 - let s1e = evaluateSym False m1 s1 - let s2e = evaluateSym False m1 s2 - s1e # 1 @=? 10 - s1e # 3 @=? 100 - s2e # 2 @=? 10 - s2e # 4 @=? 100 - ], - testGroup - "Boolean" - [ testCase "Basic" $ do - testCegis unboundedConfig True () $ const ["a", "b", "c"] - testCegis unboundedConfig False () $ const ["a", symNot "a"], - testCase "And" $ do - testCegis unboundedConfig True () $ - const ["a" .&& "b", "b" .&& symNot "c", "a", "b", symNot "c"] - testCegis unboundedConfig False () $ - const ["a" .&& "b", "b" .&& symNot "c", "a", "b", "c"] - testCegis unboundedConfig True ("a" :: SymBool) $ - \a -> [symNot $ a .&& "b", symNot "b"] - testCegis unboundedConfig False ("a" :: SymBool) $ - \a -> [symNot $ a .&& "b", "b"], - testCase "Or" $ do - testCegis unboundedConfig True () $ - const ["a" .|| "b", "b" .|| symNot "c", "a", "b", symNot "c"] - testCegis unboundedConfig True () $ - const ["a" .|| "b", "b" .|| symNot "c", "a", "b", "c"] - testCegis unboundedConfig True ("a" :: SymBool) $ - \a -> [a .|| "b", "b"] - testCegis unboundedConfig False ("a" :: SymBool) $ - \a -> [a .|| "b", symNot "b"], - testCase "And / Or should be consistent" $ do - testCegis unboundedConfig True () $ - const ["a" .&& "b", "a" .|| "b"] - testCegis unboundedConfig True () $ - const [symNot "a" .&& "b", "a" .|| "b"] - testCegis unboundedConfig False () $ - const ["a" .&& "b", symNot $ "a" .|| "b"] - testCegis unboundedConfig True () $ - const [symNot $ "a" .&& "b", symNot $ "a" .|| "b"], - testCase "Eqv" $ do - testCegis unboundedConfig True () $ - const [("a" :: SymBool) .== "b", "a", "b"] - testCegis unboundedConfig True () $ - const [("a" :: SymBool) .== "b", symNot "a", symNot "b"] - testCegis unboundedConfig False () $ - const [("a" :: SymBool) .== "b", symNot "a", "b"] - testCegis unboundedConfig False () $ - const [("a" :: SymBool) .== "b", symNot "a", "b"] - testCegis unboundedConfig True () $ - const [("a" :: SymBool) .== "b", symNot "a" `symXor` "b"] - testCegis unboundedConfig False () $ - const [("a" :: SymBool) .== "b", "a" `symXor` "b"], - testCase "symIte" $ do - testCegis unboundedConfig True ("c" :: SymBool) $ - \c -> [symIte "a" "b" c, "a", "b"] - testCegis unboundedConfig False ("c" :: SymBool) $ - \c -> [symIte "a" "b" c, symNot "a"] - testCegis unboundedConfig True ("b" :: SymBool) $ - \b -> [symIte "a" b "c", symNot "a", "c"] - testCegis unboundedConfig False ("b" :: SymBool) $ - \b -> [symIte "a" b "c", "a"] - testCegis unboundedConfig True () $ - const [symIte "a" "b" "c", "a", "b", "c"] - testCegis unboundedConfig True () $ - const [symIte "a" "b" "c", "a", "b", symNot "c"] - testCegis unboundedConfig True () $ - const [symIte "a" "b" "c", symNot "a", "b", "c"] - testCegis unboundedConfig True () $ - const [symIte "a" "b" "c", symNot "a", symNot "b", "c"] - testCegis unboundedConfig False () $ - const [symIte "a" "b" "c", "a", symNot "b", "c"] - testCegis unboundedConfig False () $ - const [symIte "a" "b" "c", "a", symNot "b", symNot "c"] - testCegis unboundedConfig False () $ - const [symIte "a" "b" "c", symNot "a", "b", symNot "c"] - testCegis unboundedConfig False () $ - const [symIte "a" "b" "c", symNot "a", symNot "b", symNot "c"] - ], - let a = "a" :: SymIntN 5 - b = "b" :: SymIntN 5 - c = "c" :: SymIntN 5 - d = "c" :: SymIntN 10 - in testGroup - "Different sized BV" - [ testGroup - "Select" - [ testCase "sizedBVSelect" $ do - testCegis unboundedConfig True () $ - const - [ sizedBVSelect (Proxy @2) (Proxy @2) a - .== (con 1 :: SymIntN 2), - a .== con 0b10101 - ] - testCegis unboundedConfig False () $ - const - [ sizedBVSelect (Proxy @2) (Proxy @2) a - .== (con 1 :: SymIntN 2), - a .== con 0b10001 - ], - testCase "sizedBVSelect when lowered twice" $ do - testCegis unboundedConfig True a $ - \ca -> - [ sizedBVSelect - (Proxy @2) - (Proxy @2) - (sizedBVConcat ca b) - .== (con 1 :: SymIntN 2) - ] - testCegis unboundedConfig True b $ - \cb -> - [ sizedBVSelect - (Proxy @7) - (Proxy @2) - (sizedBVConcat a cb) - .== (con 1 :: SymIntN 2) - ] - ], - testGroup - "Concat" - [ testCase "sizedBVConcat" $ do - testCegis unboundedConfig True () $ - const - [ sizedBVConcat a b .== d, - a .== con 1, - b .== con 1, - d .== con 0b100001 - ] - testCegis unboundedConfig False () $ - const - [ sizedBVConcat a b .== d, - a .== con 1, - b .== con 1, - d .== con 0b100010 - ], - testCase "sizedBVConcat when lowered twice" $ do - testCegis unboundedConfig True (a, c) $ - \(ca, cc) -> - [ sizedBVConcat - cc - ( sizedBVSelect - (Proxy @2) - (Proxy @2) - (sizedBVConcat ca b) :: - SymIntN 2 - ) - .== sizedBVConcat cc (con 1 :: SymIntN 2) - ] - testCegis unboundedConfig True (b, c) $ - \(cb, cc) -> - [ sizedBVConcat - cc - ( sizedBVSelect - (Proxy @7) - (Proxy @2) - (sizedBVConcat a cb) :: - SymIntN 2 - ) - .== sizedBVConcat cc (con 1 :: SymIntN 2) - ] - ], - testGroup - "Zext" - [ testCase "sizedBVZext" $ do - testCegis unboundedConfig True () $ - const - [ sizedBVZext (Proxy @10) a .== d, - a .== con 1, - d .== (con 1 :: SymIntN 10) - ] - testCegis unboundedConfig True () $ - const - [ sizedBVZext (Proxy @10) a .== d, - a .== con 0b11111, - d .== (con 0b11111 :: SymIntN 10) - ] - testCegis unboundedConfig False () $ - const - [ sizedBVZext (Proxy @10) a .== d, - d .== (con 0b111111 :: SymIntN 10) - ] - testCegis unboundedConfig False () $ - const - [ sizedBVZext (Proxy @10) a .== d, - d .== (con 0b1111111111 :: SymIntN 10) - ], - testCase "sizedBVZext when lowered twice" $ do - testCegis unboundedConfig True a $ - \ca -> - [ sizedBVZext - (Proxy @10) - ( sizedBVSelect - (Proxy @2) - (Proxy @2) - (sizedBVConcat ca b) :: - SymIntN 2 - ) - .== (con 1 :: SymIntN 10) - ] - testCegis unboundedConfig True b $ - \cb -> - [ sizedBVZext - (Proxy @10) - ( sizedBVSelect - (Proxy @7) - (Proxy @2) - (sizedBVConcat a cb) :: - SymIntN 2 - ) - .== (con 1 :: SymIntN 10) - ] - ], - testGroup - "Sext" - [ testCase "sizedBVSext" $ do - testCegis unboundedConfig True () $ - const - [ sizedBVSext (Proxy @10) a .== d, - a .== con 1, - d .== (con 1 :: SymIntN 10) - ] - testCegis unboundedConfig True () $ - const - [ sizedBVSext (Proxy @10) a .== d, - a .== con 0b11111, - d .== (con 0b1111111111 :: SymIntN 10) - ] - testCegis unboundedConfig False () $ - const - [ sizedBVSext (Proxy @10) a .== d, - d .== (con 0b111111 :: SymIntN 10) - ] - testCegis unboundedConfig False () $ - const - [ sizedBVSext (Proxy @10) a .== d, - d .== (con 0b11111 :: SymIntN 10) - ], - testCase "sizedBVSext when lowered twice" $ do - testCegis unboundedConfig True a $ \ca -> - [ sizedBVSext - (Proxy @10) - ( sizedBVSelect - (Proxy @2) - (Proxy @2) - (sizedBVConcat ca b) :: - SymIntN 2 - ) - .== (con 1 :: SymIntN 10) - ] - testCegis unboundedConfig True b $ - \cb -> - [ sizedBVSext - (Proxy @10) - ( sizedBVSelect - (Proxy @7) - (Proxy @2) - (sizedBVConcat a cb) :: - SymIntN 2 - ) - .== (con 1 :: SymIntN 10) - ] - ] - ] - ] diff --git a/test/Grisette/Backend/SBV/Data/SMT/LoweringTests.hs b/test/Grisette/Backend/SBV/Data/SMT/LoweringTests.hs deleted file mode 100644 --- a/test/Grisette/Backend/SBV/Data/SMT/LoweringTests.hs +++ /dev/null @@ -1,800 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} - -module Grisette.Backend.SBV.Data.SMT.LoweringTests (loweringTests) where - -import Control.Monad.Trans (MonadTrans (lift)) -import Data.Bits - ( Bits (complement, xor, (.&.), (.|.)), - ) -import Data.Dynamic (Typeable, fromDynamic) -import qualified Data.HashMap.Strict as M -import Data.Proxy (Proxy (Proxy)) -import qualified Data.SBV as SBV -import qualified Data.SBV.Control as SBV -import qualified Data.Text as T -import GHC.Stack (HasCallStack) -import Grisette.Backend.SBV.Data.SMT.Lowering (lowerSinglePrim) -import Grisette.Backend.SBV.Data.SMT.Solving - ( GrisetteSMTConfig (sbvConfig), - TermTy, - approx, - precise, - ) -import Grisette.Backend.SBV.Data.SMT.SymBiMap - ( SymBiMap (biMapToSBV), - ) -import Grisette.Core.Data.BV (IntN, WordN) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors - ( absNumTerm, - addNumTerm, - andBitsTerm, - andTerm, - bvconcatTerm, - bvselectTerm, - bvsignExtendTerm, - bvzeroExtendTerm, - complementBitsTerm, - divBoundedIntegralTerm, - divIntegralTerm, - eqvTerm, - iteTerm, - leNumTerm, - ltNumTerm, - modBoundedIntegralTerm, - modIntegralTerm, - notTerm, - orBitsTerm, - orTerm, - quotBoundedIntegralTerm, - quotIntegralTerm, - remBoundedIntegralTerm, - remIntegralTerm, - rotateLeftTerm, - rotateRightTerm, - shiftLeftTerm, - shiftRightTerm, - signumNumTerm, - ssymTerm, - timesNumTerm, - toSignedTerm, - toUnsignedTerm, - uminusNumTerm, - xorBitsTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.SomeTerm - ( SomeTerm (SomeTerm), - ) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term - ( SupportedPrim, - Term, - ) -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (Assertion, assertFailure) - -testUnaryOpLowering :: - forall a b as n. - ( HasCallStack, - SupportedPrim a, - SBV.EqSymbolic (TermTy n b), - Typeable (TermTy n a), - SBV.SymVal as, - TermTy n a ~ SBV.SBV as, - Show as - ) => - GrisetteSMTConfig n -> - (Term a -> Term b) -> - String -> - (TermTy n a -> TermTy n b) -> - Assertion -testUnaryOpLowering config f name sbvfun = do - let a :: Term a = ssymTerm "a" - let fa :: Term b = f a - SBV.runSMTWith (sbvConfig config) $ do - (m, lt) <- lowerSinglePrim config fa - let sbva :: Maybe (TermTy n a) = M.lookup (SomeTerm a) (biMapToSBV m) >>= fromDynamic - case sbva of - Nothing -> lift $ assertFailure "Failed to extract the term" - Just sbvav -> SBV.query $ do - SBV.constrain $ lt SBV..== sbvfun sbvav - satres <- SBV.checkSat - case satres of - SBV.Sat -> return () - _ -> lift $ assertFailure $ "Lowering for " ++ name ++ " generated unsolvable formula" - SBV.runSMTWith (sbvConfig config) $ do - (m, lt) <- lowerSinglePrim config fa - let sbvv :: Maybe (TermTy n a) = M.lookup (SomeTerm a) (biMapToSBV m) >>= fromDynamic - case sbvv of - Nothing -> lift $ assertFailure "Failed to extract the term" - Just sbvvv -> SBV.query $ do - SBV.constrain $ lt SBV../= sbvfun sbvvv - r <- SBV.checkSat - case r of - SBV.Sat -> do - counterExample <- SBV.getValue sbvvv - lift $ assertFailure $ "Translation counter example found: " ++ show counterExample - SBV.Unsat -> return () - _ -> lift $ assertFailure $ "Lowering for " ++ name ++ " generated unknown formula" - --- testUnaryOpLowering' :: --- forall a b as n tag. --- ( HasCallStack, --- UnaryOp tag a b, --- SBV.EqSymbolic (TermTy n b), --- Typeable (TermTy n a), --- SBV.SymVal as, --- TermTy n a ~ SBV.SBV as, --- Show as --- ) => --- GrisetteSMTConfig n -> --- tag -> --- (TermTy n a -> TermTy n b) -> --- Assertion --- testUnaryOpLowering' config t = testUnaryOpLowering @a @b @as config (constructUnary t) (show t) - -testBinaryOpLowering :: - forall a b c as bs n. - ( HasCallStack, - SupportedPrim a, - SupportedPrim b, - SBV.EqSymbolic (TermTy n c), - Typeable (TermTy n a), - Typeable (TermTy n b), - SBV.SymVal as, - SBV.SymVal bs, - Show as, - Show bs, - TermTy n a ~ SBV.SBV as, - TermTy n b ~ SBV.SBV bs - ) => - GrisetteSMTConfig n -> - (Term a -> Term b -> Term c) -> - String -> - (TermTy n a -> TermTy n b -> TermTy n c) -> - Assertion -testBinaryOpLowering config f name sbvfun = do - let a :: Term a = ssymTerm "a" - let b :: Term b = ssymTerm "b" - let fab :: Term c = f a b - SBV.runSMTWith (sbvConfig config) $ do - (m, lt) <- lowerSinglePrim config fab - let sbva :: Maybe (TermTy n a) = M.lookup (SomeTerm a) (biMapToSBV m) >>= fromDynamic - let sbvb :: Maybe (TermTy n b) = M.lookup (SomeTerm b) (biMapToSBV m) >>= fromDynamic - case (sbva, sbvb) of - (Just sbvav, Just sbvbv) -> SBV.query $ do - SBV.constrain $ lt SBV..== sbvfun sbvav sbvbv - satres <- SBV.checkSat - case satres of - SBV.Sat -> return () - _ -> lift $ assertFailure $ "Lowering for " ++ name ++ " generated unsolvable formula" - _ -> lift $ assertFailure "Failed to extract the term" - SBV.runSMTWith (sbvConfig config) $ do - (m, lt) <- lowerSinglePrim config fab - let sbva :: Maybe (TermTy n a) = M.lookup (SomeTerm a) (biMapToSBV m) >>= fromDynamic - let sbvb :: Maybe (TermTy n b) = M.lookup (SomeTerm b) (biMapToSBV m) >>= fromDynamic - case (sbva, sbvb) of - (Just sbvav, Just sbvbv) -> SBV.query $ do - SBV.constrain $ lt SBV../= sbvfun sbvav sbvbv - r <- SBV.checkSat - case r of - SBV.Sat -> do - counterExampleA <- SBV.getValue sbvav - counterExampleB <- SBV.getValue sbvbv - lift $ assertFailure $ "Translation counter example found: " ++ show (counterExampleA, counterExampleB) - SBV.Unsat -> return () - _ -> lift $ assertFailure $ "Lowering for " ++ name ++ " generated unknown formula" - _ -> lift $ assertFailure "Failed to extract the term" - --- testBinaryOpLowering' :: --- forall a b c as bs n tag. --- ( HasCallStack, --- BinaryOp tag a b c, --- SBV.EqSymbolic (TermTy n c), --- Typeable (TermTy n a), --- Typeable (TermTy n b), --- SBV.SymVal as, --- SBV.SymVal bs, --- Show as, --- Show bs, --- TermTy n a ~ SBV.SBV as, --- TermTy n b ~ SBV.SBV bs --- ) => --- GrisetteSMTConfig n -> --- tag -> --- (TermTy n a -> TermTy n b -> TermTy n c) -> --- Assertion --- testBinaryOpLowering' config t = testBinaryOpLowering @a @b @c @as @bs config (constructBinary t) (show t) - -testTernaryOpLowering :: - forall a b c d as bs cs n. - ( HasCallStack, - SupportedPrim a, - SupportedPrim b, - SupportedPrim c, - SBV.EqSymbolic (TermTy n d), - Typeable (TermTy n a), - Typeable (TermTy n b), - Typeable (TermTy n c), - SBV.SymVal as, - SBV.SymVal bs, - SBV.SymVal cs, - Show as, - Show bs, - Show cs, - TermTy n a ~ SBV.SBV as, - TermTy n b ~ SBV.SBV bs, - TermTy n c ~ SBV.SBV cs - ) => - GrisetteSMTConfig n -> - (Term a -> Term b -> Term c -> Term d) -> - T.Text -> - (TermTy n a -> TermTy n b -> TermTy n c -> TermTy n d) -> - Assertion -testTernaryOpLowering config f name sbvfun = do - let a :: Term a = ssymTerm "a" - let b :: Term b = ssymTerm "b" - let c :: Term c = ssymTerm "c" - let fabc :: Term d = f a b c - SBV.runSMTWith (sbvConfig config) $ do - (m, lt) <- lowerSinglePrim config fabc - let sbva :: Maybe (TermTy n a) = M.lookup (SomeTerm a) (biMapToSBV m) >>= fromDynamic - let sbvb :: Maybe (TermTy n b) = M.lookup (SomeTerm b) (biMapToSBV m) >>= fromDynamic - let sbvc :: Maybe (TermTy n c) = M.lookup (SomeTerm c) (biMapToSBV m) >>= fromDynamic - case (sbva, sbvb, sbvc) of - (Just sbvav, Just sbvbv, Just sbvcv) -> SBV.query $ do - SBV.constrain $ lt SBV..== sbvfun sbvav sbvbv sbvcv - satres <- SBV.checkSat - case satres of - SBV.Sat -> return () - _ -> lift $ assertFailure $ T.unpack $ "Lowering for " <> name <> " generated unsolvable formula" - _ -> lift $ assertFailure "Failed to extract the term" - SBV.runSMTWith (sbvConfig config) $ do - (m, lt) <- lowerSinglePrim config fabc - let sbva :: Maybe (TermTy n a) = M.lookup (SomeTerm a) (biMapToSBV m) >>= fromDynamic - let sbvb :: Maybe (TermTy n b) = M.lookup (SomeTerm b) (biMapToSBV m) >>= fromDynamic - let sbvc :: Maybe (TermTy n c) = M.lookup (SomeTerm c) (biMapToSBV m) >>= fromDynamic - case (sbva, sbvb, sbvc) of - (Just sbvav, Just sbvbv, Just sbvcv) -> SBV.query $ do - SBV.constrain $ lt SBV../= sbvfun sbvav sbvbv sbvcv - r <- SBV.checkSat - case r of - SBV.Sat -> do - counterExampleA <- SBV.getValue sbvav - counterExampleB <- SBV.getValue sbvbv - counterExampleC <- SBV.getValue sbvcv - lift $ - assertFailure $ - "Translation counter example found: " - ++ show (counterExampleA, counterExampleB, counterExampleC) - SBV.Unsat -> return () - _ -> lift $ assertFailure $ T.unpack $ "Lowering for " <> name <> " generated unknown formula" - _ -> lift $ assertFailure "Failed to extract the term" - --- testTernaryOpLowering' :: --- forall a b c d as bs cs n tag. --- ( HasCallStack, --- TernaryOp tag a b c d, --- SBV.EqSymbolic (TermTy n d), --- Typeable (TermTy n a), --- Typeable (TermTy n b), --- Typeable (TermTy n c), --- SBV.SymVal as, --- SBV.SymVal bs, --- SBV.SymVal cs, --- Show as, --- Show bs, --- Show cs, --- TermTy n a ~ SBV.SBV as, --- TermTy n b ~ SBV.SBV bs, --- TermTy n c ~ SBV.SBV cs --- ) => --- GrisetteSMTConfig n -> --- tag -> --- (TermTy n a -> TermTy n b -> TermTy n c -> TermTy n d) -> --- Assertion --- testTernaryOpLowering' config t = testTernaryOpLowering @a @b @c @d @as @bs @cs config (constructTernary t) (show t) - -loweringTests :: Test -loweringTests = - let unboundedConfig = precise SBV.z3 - boundedConfig = approx (Proxy @5) SBV.z3 - in testGroup - "Lowering" - [ testGroup - "Bool Lowering" - [ testCase "Not" $ do - testUnaryOpLowering @Bool @Bool unboundedConfig notTerm "not" SBV.sNot, - testCase "And" $ do - testBinaryOpLowering @Bool @Bool @Bool unboundedConfig andTerm "and" (SBV..&&) - testBinaryOpLowering @Bool @Bool @Bool - unboundedConfig - andTerm - "and" - (\x y -> SBV.sNot (x SBV..<+> y) SBV..&& (x SBV..|| y)), - testCase "Or" $ do - testBinaryOpLowering @Bool @Bool @Bool unboundedConfig orTerm "or" (SBV..||) - testBinaryOpLowering @Bool @Bool @Bool - unboundedConfig - orTerm - "or" - (\x y -> (x SBV..<+> y) SBV..|| (x SBV..&& y)), - testCase "Eqv" $ do - testBinaryOpLowering @Bool @Bool @Bool unboundedConfig eqvTerm "eqv" (SBV..==) - testBinaryOpLowering @Bool @Bool @Bool - unboundedConfig - eqvTerm - "eqv" - (\x y -> SBV.sNot (x SBV..<+> y)), - testCase "ITE" $ do - testTernaryOpLowering @Bool @Bool @Bool @Bool unboundedConfig iteTerm "ite" SBV.ite - testTernaryOpLowering @Bool @Bool @Bool @Bool - unboundedConfig - iteTerm - "ite" - (\c x y -> (c SBV..=> x) SBV..&& (SBV.sNot c SBV..=> y)) - ], - testGroup - "Integer Lowering" - [ testCase "Add" $ do - testBinaryOpLowering @Integer @Integer @Integer unboundedConfig addNumTerm "(+)" (+) - testBinaryOpLowering @Integer @Integer @Integer - unboundedConfig - addNumTerm - "(+)" - (\x y -> (x + 1) * (y + 1) - x * y - 1) - testBinaryOpLowering @Integer @Integer @Integer boundedConfig addNumTerm "(+)" (+) - testBinaryOpLowering @Integer @Integer @Integer - boundedConfig - addNumTerm - "(+)" - (\x y -> (x + 1) * (y + 1) - x * y - 1), - testCase "Uminus" $ do - testUnaryOpLowering @Integer @Integer unboundedConfig uminusNumTerm "negate" negate - testUnaryOpLowering @Integer @Integer - unboundedConfig - uminusNumTerm - "negate" - (\x -> (x + 1) * (x + 1) - 3 * x - x * x - 1) - testUnaryOpLowering @Integer @Integer boundedConfig uminusNumTerm "negate" negate - testUnaryOpLowering @Integer @Integer - boundedConfig - uminusNumTerm - "negate" - (\x -> (x + 1) * (x + 1) - 3 * x - x * x - 1), - testCase "Abs" $ do - testUnaryOpLowering @Integer @Integer unboundedConfig absNumTerm "abs" abs - testUnaryOpLowering @Integer @Integer boundedConfig absNumTerm "abs" abs, - testCase "Signum" $ do - testUnaryOpLowering @Integer @Integer unboundedConfig signumNumTerm "signum" signum - testUnaryOpLowering @Integer @Integer boundedConfig signumNumTerm "signum" signum, - testCase "Times" $ do - testBinaryOpLowering @Integer @Integer @Integer unboundedConfig timesNumTerm "(*)" (*) - testBinaryOpLowering @Integer @Integer @Integer - unboundedConfig - timesNumTerm - "(*)" - (\x y -> (x + 1) * (y + 1) - x - y - 1) - testBinaryOpLowering @Integer @Integer @Integer boundedConfig timesNumTerm "(*)" (*) - testBinaryOpLowering @Integer @Integer @Integer - boundedConfig - timesNumTerm - "(*)" - (\x y -> (x + 1) * (y + 1) - x - y - 1), - testCase "Lt" $ do - testBinaryOpLowering @Integer @Integer @Bool unboundedConfig ltNumTerm "(<)" (SBV..<) - testBinaryOpLowering @Integer @Integer @Bool - unboundedConfig - ltNumTerm - "(<)" - (\x y -> x * 2 - x SBV..< y * 2 - y) - testBinaryOpLowering @Integer @Integer @Bool boundedConfig ltNumTerm "(<)" (SBV..<) - testBinaryOpLowering @Integer @Integer @Bool - boundedConfig - ltNumTerm - "(<=)" - (\x y -> x * 2 - x SBV..< y * 2 - y), - testCase "Le" $ do - testBinaryOpLowering @Integer @Integer @Bool unboundedConfig leNumTerm "(<=)" (SBV..<=) - testBinaryOpLowering @Integer @Integer @Bool - unboundedConfig - leNumTerm - "(<=)" - (\x y -> x * 2 - x SBV..<= y * 2 - y) - testBinaryOpLowering @Integer @Integer @Bool boundedConfig leNumTerm "(<=)" (SBV..<=) - testBinaryOpLowering @Integer @Integer @Bool - boundedConfig - leNumTerm - "(<=)" - (\x y -> x * 2 - x SBV..<= y * 2 - y), - testCase "Div" $ do - testBinaryOpLowering @Integer @Integer @Integer unboundedConfig divIntegralTerm "div" SBV.sDiv - testBinaryOpLowering @Integer @Integer @Integer boundedConfig divIntegralTerm "div" SBV.sDiv, - testCase "Mod" $ do - testBinaryOpLowering @Integer @Integer @Integer unboundedConfig modIntegralTerm "mod" SBV.sMod - testBinaryOpLowering @Integer @Integer @Integer boundedConfig modIntegralTerm "mod" SBV.sMod, - testCase "Quot" $ do - testBinaryOpLowering @Integer @Integer @Integer unboundedConfig quotIntegralTerm "quot" SBV.sQuot - testBinaryOpLowering @Integer @Integer @Integer boundedConfig quotIntegralTerm "quot" SBV.sQuot, - testCase "Rem" $ do - testBinaryOpLowering @Integer @Integer @Integer unboundedConfig remIntegralTerm "rem" SBV.sRem - testBinaryOpLowering @Integer @Integer @Integer boundedConfig remIntegralTerm "rem" SBV.sRem - ], - testGroup - "IntN Lowering" - [ testCase "Add" $ do - testBinaryOpLowering @(IntN 5) @(IntN 5) unboundedConfig addNumTerm "(+)" (+) - testBinaryOpLowering @(IntN 5) @(IntN 5) - unboundedConfig - addNumTerm - "(+)" - (\x y -> (x + 1) * (y + 1) - x * y - 1), - testCase "Uminus" $ do - testUnaryOpLowering @(IntN 5) unboundedConfig uminusNumTerm "negate" negate - testUnaryOpLowering @(IntN 5) - unboundedConfig - uminusNumTerm - "negate" - (\x -> (x + 1) * (x + 1) - 3 * x - x * x - 1), - testCase "Abs" $ do - testUnaryOpLowering @(IntN 5) unboundedConfig absNumTerm "abs" abs, - testCase "Signum" $ do - testUnaryOpLowering @(IntN 5) unboundedConfig signumNumTerm "signum" signum, - testCase "Times" $ do - testBinaryOpLowering @(IntN 5) @(IntN 5) unboundedConfig timesNumTerm "(*)" (*) - testBinaryOpLowering @(IntN 5) @(IntN 5) - unboundedConfig - timesNumTerm - "(*)" - (\x y -> (x + 1) * (y + 1) - x - y - 1), - testCase "Lt" $ do - testBinaryOpLowering @(IntN 5) @(IntN 5) unboundedConfig ltNumTerm "(<)" (SBV..<) - testBinaryOpLowering @(IntN 5) @(IntN 5) - unboundedConfig - ltNumTerm - "(<)" - (\x y -> x * 2 - x SBV..< y * 2 - y), - testCase "Le" $ do - testBinaryOpLowering @(IntN 5) @(IntN 5) unboundedConfig leNumTerm "(<=)" (SBV..<=) - testBinaryOpLowering @(IntN 5) @(IntN 5) - unboundedConfig - leNumTerm - "(<=)" - (\x y -> x * 2 - x SBV..<= y * 2 - y), - testCase "Extract" $ do - testUnaryOpLowering @(IntN 5) @(IntN 1) - unboundedConfig - (bvselectTerm (Proxy @0) (Proxy @1)) - "select" - (SBV.bvExtract @0 @0 @5 Proxy Proxy) - testUnaryOpLowering @(IntN 5) @(IntN 1) - unboundedConfig - (bvselectTerm (Proxy @1) (Proxy @1)) - "select" - (SBV.bvExtract @1 @1 @5 Proxy Proxy) - testUnaryOpLowering @(IntN 5) @(IntN 1) - unboundedConfig - (bvselectTerm (Proxy @2) (Proxy @1)) - "select" - (SBV.bvExtract @2 @2 @5 Proxy Proxy) - testUnaryOpLowering @(IntN 5) @(IntN 1) - unboundedConfig - (bvselectTerm (Proxy @3) (Proxy @1)) - "select" - (SBV.bvExtract @3 @3 @5 Proxy Proxy) - testUnaryOpLowering @(IntN 5) @(IntN 1) - unboundedConfig - (bvselectTerm (Proxy @4) (Proxy @1)) - "select" - (SBV.bvExtract @4 @4 @5 Proxy Proxy) - testUnaryOpLowering @(IntN 5) @(IntN 2) - unboundedConfig - (bvselectTerm (Proxy @0) (Proxy @2)) - "select" - (SBV.bvExtract @1 @0 @5 Proxy Proxy) - testUnaryOpLowering @(IntN 5) @(IntN 2) - unboundedConfig - (bvselectTerm (Proxy @1) (Proxy @2)) - "select" - (SBV.bvExtract @2 @1 @5 Proxy Proxy) - testUnaryOpLowering @(IntN 5) @(IntN 2) - unboundedConfig - (bvselectTerm (Proxy @2) (Proxy @2)) - "select" - (SBV.bvExtract @3 @2 @5 Proxy Proxy) - testUnaryOpLowering @(IntN 5) @(IntN 2) - unboundedConfig - (bvselectTerm (Proxy @3) (Proxy @2)) - "select" - (SBV.bvExtract @4 @3 @5 Proxy Proxy) - testUnaryOpLowering @(IntN 5) @(IntN 3) - unboundedConfig - (bvselectTerm (Proxy @0) (Proxy @3)) - "select" - (SBV.bvExtract @2 @0 @5 Proxy Proxy) - testUnaryOpLowering @(IntN 5) @(IntN 3) - unboundedConfig - (bvselectTerm (Proxy @1) (Proxy @3)) - "select" - (SBV.bvExtract @3 @1 @5 Proxy Proxy) - testUnaryOpLowering @(IntN 5) @(IntN 3) - unboundedConfig - (bvselectTerm (Proxy @2) (Proxy @3)) - "select" - (SBV.bvExtract @4 @2 @5 Proxy Proxy) - testUnaryOpLowering @(IntN 5) @(IntN 4) - unboundedConfig - (bvselectTerm (Proxy @0) (Proxy @4)) - "select" - (SBV.bvExtract @3 @0 @5 Proxy Proxy) - testUnaryOpLowering @(IntN 5) @(IntN 4) - unboundedConfig - (bvselectTerm (Proxy @1) (Proxy @4)) - "select" - (SBV.bvExtract @4 @1 @5 Proxy Proxy) - testUnaryOpLowering @(IntN 5) @(IntN 5) - unboundedConfig - (bvselectTerm (Proxy @0) (Proxy @5)) - "select" - id, - testCase "Extension" $ do - testUnaryOpLowering @(IntN 5) @(IntN 6) - unboundedConfig - (bvzeroExtendTerm (Proxy @6)) - "bvzeroExtend" - SBV.zeroExtend - testUnaryOpLowering @(IntN 5) @(IntN 10) - unboundedConfig - (bvzeroExtendTerm (Proxy @10)) - "bvzeroExtend" - SBV.zeroExtend - testUnaryOpLowering @(IntN 5) @(IntN 6) - unboundedConfig - (bvsignExtendTerm (Proxy @6)) - "bvsignExtend" - SBV.signExtend - testUnaryOpLowering @(IntN 5) @(IntN 10) - unboundedConfig - (bvsignExtendTerm (Proxy @10)) - "bvsignExtend" - SBV.signExtend, - testCase "Concat" $ do - testBinaryOpLowering @(IntN 4) @(IntN 5) @(IntN 9) - unboundedConfig - bvconcatTerm - "bvconcat" - (SBV.#), - testCase "AndBits" $ do - testBinaryOpLowering @(IntN 5) @(IntN 5) unboundedConfig andBitsTerm "(.&.)" (.&.), - testCase "OrBits" $ do - testBinaryOpLowering @(IntN 5) @(IntN 5) unboundedConfig orBitsTerm "(.|.)" (.|.), - testCase "XorBits" $ do - testBinaryOpLowering @(IntN 5) @(IntN 5) unboundedConfig xorBitsTerm "xor" xor, - testCase "ComplementBits" $ do - testUnaryOpLowering @(IntN 5) unboundedConfig complementBitsTerm "complement" complement, - testCase "ShiftLeft" $ do - testBinaryOpLowering @(IntN 5) unboundedConfig shiftLeftTerm "shiftLeft" SBV.sShiftLeft, - testCase "ShiftRight" $ do - testBinaryOpLowering @(IntN 5) unboundedConfig shiftRightTerm "shiftRight" SBV.sShiftRight, - testCase "RotateLeft" $ do - testBinaryOpLowering @(IntN 5) - unboundedConfig - rotateLeftTerm - "rotateLeft" - ( \a b -> - SBV.sFromIntegral $ - SBV.sRotateLeft - (SBV.sFromIntegral a :: SBV.SWord 5) - (SBV.sFromIntegral b :: SBV.SWord 5) - ), - testCase "RotateRight" $ do - testBinaryOpLowering @(IntN 5) - unboundedConfig - rotateRightTerm - "rotateRight" - ( \a b -> - SBV.sFromIntegral $ - SBV.sRotateRight - (SBV.sFromIntegral a :: SBV.SWord 5) - (SBV.sFromIntegral b :: SBV.SWord 5) - ), - testCase "Div - bounded" $ do - testBinaryOpLowering @(IntN 5) @(IntN 5) @(IntN 5) unboundedConfig divBoundedIntegralTerm "div" SBV.sDiv - testBinaryOpLowering @(IntN 5) @(IntN 5) @(IntN 5) boundedConfig divBoundedIntegralTerm "div" SBV.sDiv, - testCase "Mod - bounded" $ do - testBinaryOpLowering @(IntN 5) @(IntN 5) @(IntN 5) unboundedConfig modBoundedIntegralTerm "mod" SBV.sMod - testBinaryOpLowering @(IntN 5) @(IntN 5) @(IntN 5) boundedConfig modBoundedIntegralTerm "mod" SBV.sMod, - testCase "Quot - bounded" $ do - testBinaryOpLowering @(IntN 5) @(IntN 5) @(IntN 5) unboundedConfig quotBoundedIntegralTerm "quot" SBV.sQuot - testBinaryOpLowering @(IntN 5) @(IntN 5) @(IntN 5) boundedConfig quotBoundedIntegralTerm "quot" SBV.sQuot, - testCase "Rem - bounded" $ do - testBinaryOpLowering @(IntN 5) @(IntN 5) @(IntN 5) unboundedConfig remBoundedIntegralTerm "rem" SBV.sRem - testBinaryOpLowering @(IntN 5) @(IntN 5) @(IntN 5) boundedConfig remBoundedIntegralTerm "rem" SBV.sRem, - testCase "ToUnsigned" $ do - testUnaryOpLowering @(IntN 5) @(WordN 5) unboundedConfig toUnsignedTerm "toUnsigned" SBV.sFromIntegral - testUnaryOpLowering @(IntN 5) @(WordN 5) boundedConfig toUnsignedTerm "toUnsigned" SBV.sFromIntegral - ], - testGroup - "WordN" - [ testCase "Add" $ do - testBinaryOpLowering @(WordN 5) @(WordN 5) unboundedConfig addNumTerm "(+)" (+) - testBinaryOpLowering @(WordN 5) @(WordN 5) - unboundedConfig - addNumTerm - "(+)" - (\x y -> (x + 1) * (y + 1) - x * y - 1), - testCase "Uminus" $ do - testUnaryOpLowering @(WordN 5) unboundedConfig uminusNumTerm "negate" negate - testUnaryOpLowering @(WordN 5) - unboundedConfig - uminusNumTerm - "negate" - (\x -> (x + 1) * (x + 1) - 3 * x - x * x - 1), - testCase "Abs" $ do - testUnaryOpLowering @(WordN 5) unboundedConfig absNumTerm "abs" abs, - testCase "Signum" $ do - testUnaryOpLowering @(WordN 5) unboundedConfig signumNumTerm "signum" signum, - testCase "Times" $ do - testBinaryOpLowering @(WordN 5) @(WordN 5) unboundedConfig timesNumTerm "(*)" (*) - testBinaryOpLowering @(WordN 5) @(WordN 5) - unboundedConfig - timesNumTerm - "(*)" - (\x y -> (x + 1) * (y + 1) - x - y - 1), - testCase "Lt" $ do - testBinaryOpLowering @(WordN 5) @(WordN 5) unboundedConfig ltNumTerm "(<)" (SBV..<) - testBinaryOpLowering @(WordN 5) @(WordN 5) - unboundedConfig - ltNumTerm - "(<)" - (\x y -> x * 2 - x SBV..< y * 2 - y), - testCase "Le" $ do - testBinaryOpLowering @(WordN 5) @(WordN 5) unboundedConfig leNumTerm "(<=)" (SBV..<=) - testBinaryOpLowering @(WordN 5) @(WordN 5) - unboundedConfig - leNumTerm - "(<=)" - (\x y -> x * 2 - x SBV..<= y * 2 - y), - testCase "Extract" $ do - testUnaryOpLowering @(WordN 5) @(WordN 1) - unboundedConfig - (bvselectTerm (Proxy @0) (Proxy @1)) - "select" - (SBV.bvExtract @0 @0 @5 Proxy Proxy) - testUnaryOpLowering @(WordN 5) @(WordN 1) - unboundedConfig - (bvselectTerm (Proxy @1) (Proxy @1)) - "select" - (SBV.bvExtract @1 @1 @5 Proxy Proxy) - testUnaryOpLowering @(WordN 5) @(WordN 1) - unboundedConfig - (bvselectTerm (Proxy @2) (Proxy @1)) - "select" - (SBV.bvExtract @2 @2 @5 Proxy Proxy) - testUnaryOpLowering @(WordN 5) @(WordN 1) - unboundedConfig - (bvselectTerm (Proxy @3) (Proxy @1)) - "select" - (SBV.bvExtract @3 @3 @5 Proxy Proxy) - testUnaryOpLowering @(WordN 5) @(WordN 1) - unboundedConfig - (bvselectTerm (Proxy @4) (Proxy @1)) - "select" - (SBV.bvExtract @4 @4 @5 Proxy Proxy) - testUnaryOpLowering @(WordN 5) @(WordN 2) - unboundedConfig - (bvselectTerm (Proxy @0) (Proxy @2)) - "select" - (SBV.bvExtract @1 @0 @5 Proxy Proxy) - testUnaryOpLowering @(WordN 5) @(WordN 2) - unboundedConfig - (bvselectTerm (Proxy @1) (Proxy @2)) - "select" - (SBV.bvExtract @2 @1 @5 Proxy Proxy) - testUnaryOpLowering @(WordN 5) @(WordN 2) - unboundedConfig - (bvselectTerm (Proxy @2) (Proxy @2)) - "select" - (SBV.bvExtract @3 @2 @5 Proxy Proxy) - testUnaryOpLowering @(WordN 5) @(WordN 2) - unboundedConfig - (bvselectTerm (Proxy @3) (Proxy @2)) - "select" - (SBV.bvExtract @4 @3 @5 Proxy Proxy) - testUnaryOpLowering @(WordN 5) @(WordN 3) - unboundedConfig - (bvselectTerm (Proxy @0) (Proxy @3)) - "select" - (SBV.bvExtract @2 @0 @5 Proxy Proxy) - testUnaryOpLowering @(WordN 5) @(WordN 3) - unboundedConfig - (bvselectTerm (Proxy @1) (Proxy @3)) - "select" - (SBV.bvExtract @3 @1 @5 Proxy Proxy) - testUnaryOpLowering @(WordN 5) @(WordN 3) - unboundedConfig - (bvselectTerm (Proxy @2) (Proxy @3)) - "select" - (SBV.bvExtract @4 @2 @5 Proxy Proxy) - testUnaryOpLowering @(WordN 5) @(WordN 4) - unboundedConfig - (bvselectTerm (Proxy @0) (Proxy @4)) - "select" - (SBV.bvExtract @3 @0 @5 Proxy Proxy) - testUnaryOpLowering @(WordN 5) @(WordN 4) - unboundedConfig - (bvselectTerm (Proxy @1) (Proxy @4)) - "select" - (SBV.bvExtract @4 @1 @5 Proxy Proxy) - testUnaryOpLowering @(WordN 5) @(WordN 5) - unboundedConfig - (bvselectTerm (Proxy @0) (Proxy @5)) - "select" - id, - testCase "Extension" $ do - testUnaryOpLowering @(WordN 5) @(WordN 6) - unboundedConfig - (bvzeroExtendTerm (Proxy @6)) - "bvzeroExtend" - SBV.zeroExtend - testUnaryOpLowering @(WordN 5) @(WordN 10) - unboundedConfig - (bvzeroExtendTerm (Proxy @10)) - "bvzeroExtend" - SBV.zeroExtend - testUnaryOpLowering @(WordN 5) @(WordN 6) - unboundedConfig - (bvsignExtendTerm (Proxy @6)) - "bvsignExtend" - SBV.signExtend - testUnaryOpLowering @(WordN 5) @(WordN 10) - unboundedConfig - (bvsignExtendTerm (Proxy @10)) - "bvsignExtend" - SBV.signExtend, - testCase "Concat" $ do - testBinaryOpLowering @(WordN 4) @(WordN 5) @(WordN 9) - unboundedConfig - bvconcatTerm - "bvconcat" - (SBV.#), - testCase "AndBits" $ do - testBinaryOpLowering @(WordN 5) @(WordN 5) unboundedConfig andBitsTerm "(.&.)" (.&.), - testCase "OrBits" $ do - testBinaryOpLowering @(WordN 5) @(WordN 5) unboundedConfig orBitsTerm "(.|.)" (.|.), - testCase "XorBits" $ do - testBinaryOpLowering @(WordN 5) @(WordN 5) unboundedConfig xorBitsTerm "xor" xor, - testCase "ComplementBits" $ do - testUnaryOpLowering @(WordN 5) unboundedConfig complementBitsTerm "complement" complement, - testCase "ShiftLeft" $ do - testBinaryOpLowering @(WordN 5) unboundedConfig shiftLeftTerm "shiftLeft" SBV.sShiftLeft, - testCase "ShiftRight" $ do - testBinaryOpLowering @(WordN 5) unboundedConfig shiftRightTerm "shiftRight" SBV.sShiftRight, - testCase "RotateLeft" $ do - testBinaryOpLowering @(WordN 5) unboundedConfig rotateLeftTerm "rotateLeft" SBV.sRotateLeft, - testCase "RotateRight" $ do - testBinaryOpLowering @(WordN 5) unboundedConfig rotateRightTerm "rotateRight" SBV.sRotateRight, - testCase "Div" $ do - testBinaryOpLowering @(WordN 5) @(WordN 5) @(WordN 5) unboundedConfig divIntegralTerm "div" SBV.sDiv - testBinaryOpLowering @(WordN 5) @(WordN 5) @(WordN 5) boundedConfig divIntegralTerm "div" SBV.sDiv, - testCase "Mod" $ do - testBinaryOpLowering @(WordN 5) @(WordN 5) @(WordN 5) unboundedConfig modIntegralTerm "mod" SBV.sMod - testBinaryOpLowering @(WordN 5) @(WordN 5) @(WordN 5) boundedConfig modIntegralTerm "mod" SBV.sMod, - testCase "Quot" $ do - testBinaryOpLowering @(WordN 5) @(WordN 5) @(WordN 5) unboundedConfig quotIntegralTerm "quot" SBV.sQuot - testBinaryOpLowering @(WordN 5) @(WordN 5) @(WordN 5) boundedConfig quotIntegralTerm "quot" SBV.sQuot, - testCase "Rem" $ do - testBinaryOpLowering @(WordN 5) @(WordN 5) @(WordN 5) unboundedConfig remIntegralTerm "rem" SBV.sRem - testBinaryOpLowering @(WordN 5) @(WordN 5) @(WordN 5) boundedConfig remIntegralTerm "rem" SBV.sRem, - testCase "ToSigned" $ do - testUnaryOpLowering @(WordN 5) @(IntN 5) unboundedConfig toSignedTerm "toSigned" SBV.sFromIntegral - testUnaryOpLowering @(WordN 5) @(IntN 5) boundedConfig toSignedTerm "toSigned" SBV.sFromIntegral - ] - ] diff --git a/test/Grisette/Backend/SBV/Data/SMT/TermRewritingGen.hs b/test/Grisette/Backend/SBV/Data/SMT/TermRewritingGen.hs deleted file mode 100644 --- a/test/Grisette/Backend/SBV/Data/SMT/TermRewritingGen.hs +++ /dev/null @@ -1,863 +0,0 @@ -{-# LANGUAGE BinaryLiterals #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -module Grisette.Backend.SBV.Data.SMT.TermRewritingGen - ( TermRewritingSpec (..), - GeneralSpec (..), - DifferentSizeBVSpec (..), - FixedSizedBVWithBoolSpec (..), - BoolWithLIASpec (..), - LIAWithBoolSpec (..), - BoolOnlySpec (..), - constructUnarySpec', - constructBinarySpec', - constructTernarySpec', - divIntegralSpec, - modIntegralSpec, - quotIntegralSpec, - remIntegralSpec, - divBoundedIntegralSpec, - modBoundedIntegralSpec, - quotBoundedIntegralSpec, - remBoundedIntegralSpec, - uminusNumSpec, - timesNumSpec, - addNumSpec, - absNumSpec, - iteSpec, - eqvSpec, - notSpec, - andSpec, - orSpec, - shiftLeftSpec, - shiftRightSpec, - rotateLeftSpec, - rotateRightSpec, - xorBitsSpec, - ) -where - -import Data.Bits (Bits, FiniteBits) -import Data.Data (Proxy (Proxy), Typeable) -import Data.Kind (Type) -import qualified Data.Text as T -import GHC.TypeLits (KnownNat, Nat, type (+), type (<=)) -import Grisette.Core.Data.Class.BitVector (SizedBV) -import Grisette.Core.Data.Class.SymRotate (SymRotate) -import Grisette.Core.Data.Class.SymShift (SymShift) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors - ( absNumTerm, - addNumTerm, - andBitsTerm, - andTerm, - bvconcatTerm, - bvextendTerm, - bvselectTerm, - complementBitsTerm, - conTerm, - constructBinary, - constructTernary, - constructUnary, - divBoundedIntegralTerm, - divIntegralTerm, - eqvTerm, - iteTerm, - leNumTerm, - ltNumTerm, - modBoundedIntegralTerm, - modIntegralTerm, - notTerm, - orBitsTerm, - orTerm, - quotBoundedIntegralTerm, - quotIntegralTerm, - remBoundedIntegralTerm, - remIntegralTerm, - rotateLeftTerm, - rotateRightTerm, - shiftLeftTerm, - shiftRightTerm, - signumNumTerm, - ssymTerm, - timesNumTerm, - uminusNumTerm, - xorBitsTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term - ( BinaryOp (partialEvalBinary), - SupportedPrim, - Term, - TernaryOp (partialEvalTernary), - UnaryOp (partialEvalUnary), - ) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermUtils - ( pformat, - ) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.BV - ( pevalBVConcatTerm, - pevalBVExtendTerm, - pevalBVSelectTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bits - ( pevalAndBitsTerm, - pevalComplementBitsTerm, - pevalOrBitsTerm, - pevalRotateLeftTerm, - pevalRotateRightTerm, - pevalShiftLeftTerm, - pevalShiftRightTerm, - pevalXorBitsTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool - ( pevalAndTerm, - pevalEqvTerm, - pevalITETerm, - pevalNotTerm, - pevalOrTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.Integral - ( pevalDivBoundedIntegralTerm, - pevalDivIntegralTerm, - pevalModBoundedIntegralTerm, - pevalModIntegralTerm, - pevalQuotBoundedIntegralTerm, - pevalQuotIntegralTerm, - pevalRemBoundedIntegralTerm, - pevalRemIntegralTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.Num - ( pevalAbsNumTerm, - pevalAddNumTerm, - pevalLeNumTerm, - pevalLtNumTerm, - pevalSignumNumTerm, - pevalTimesNumTerm, - pevalUMinusNumTerm, - ) -import Test.QuickCheck (Arbitrary (arbitrary), Gen, frequency, oneof, sized) - -class (SupportedPrim b) => TermRewritingSpec a b | a -> b where - norewriteVer :: a -> Term b - rewriteVer :: a -> Term b - wrap :: Term b -> Term b -> a - same :: a -> Term Bool - counterExample :: a -> Term Bool - counterExample = notTerm . same - symSpec :: T.Text -> a - symSpec s = wrap (ssymTerm s) (ssymTerm s) - conSpec :: b -> a - conSpec v = wrap (conTerm v) (conTerm v) - -constructUnarySpec :: - forall a av b bv. - ( TermRewritingSpec a av, - TermRewritingSpec b bv - ) => - (Term av -> Term bv) -> - (Term av -> Term bv) -> - a -> - b -constructUnarySpec construct partial a = - wrap (construct $ norewriteVer a) (partial $ rewriteVer a) - -constructUnarySpec' :: - forall a av b bv tag. - ( TermRewritingSpec a av, - TermRewritingSpec b bv, - UnaryOp tag av bv - ) => - tag -> - a -> - b -constructUnarySpec' tag = constructUnarySpec @a @av @b @bv (constructUnary tag) (partialEvalUnary tag) - -constructBinarySpec :: - forall a av b bv c cv. - ( TermRewritingSpec a av, - TermRewritingSpec b bv, - TermRewritingSpec c cv - ) => - (Term av -> Term bv -> Term cv) -> - (Term av -> Term bv -> Term cv) -> - a -> - b -> - c -constructBinarySpec construct partial a b = - wrap - (construct (norewriteVer a) (norewriteVer b)) - (partial (rewriteVer a) (rewriteVer b)) - -constructBinarySpec' :: - forall a av b bv c cv tag. - ( TermRewritingSpec a av, - TermRewritingSpec b bv, - TermRewritingSpec c cv, - BinaryOp tag av bv cv - ) => - tag -> - a -> - b -> - c -constructBinarySpec' tag = constructBinarySpec @a @av @b @bv @c @cv (constructBinary tag) (partialEvalBinary tag) - -constructTernarySpec :: - forall a av b bv c cv d dv. - ( TermRewritingSpec a av, - TermRewritingSpec b bv, - TermRewritingSpec c cv, - TermRewritingSpec d dv - ) => - (Term av -> Term bv -> Term cv -> Term dv) -> - (Term av -> Term bv -> Term cv -> Term dv) -> - a -> - b -> - c -> - d -constructTernarySpec construct partial a b c = - wrap - (construct (norewriteVer a) (norewriteVer b) (norewriteVer c)) - (partial (rewriteVer a) (rewriteVer b) (rewriteVer c)) - -constructTernarySpec' :: - forall a av b bv c cv d dv tag. - ( TermRewritingSpec a av, - TermRewritingSpec b bv, - TermRewritingSpec c cv, - TermRewritingSpec d dv, - TernaryOp tag av bv cv dv - ) => - tag -> - a -> - b -> - c -> - d -constructTernarySpec' tag = - constructTernarySpec @a @av @b @bv @c @cv @d @dv - (constructTernary tag) - (partialEvalTernary tag) - -notSpec :: (TermRewritingSpec a Bool) => a -> a -notSpec = constructUnarySpec notTerm pevalNotTerm - -andSpec :: (TermRewritingSpec a Bool) => a -> a -> a -andSpec = constructBinarySpec andTerm pevalAndTerm - -orSpec :: (TermRewritingSpec a Bool) => a -> a -> a -orSpec = constructBinarySpec orTerm pevalOrTerm - -eqvSpec :: (TermRewritingSpec a av, TermRewritingSpec b Bool) => a -> a -> b -eqvSpec = constructBinarySpec eqvTerm pevalEqvTerm - -iteSpec :: (TermRewritingSpec a Bool, TermRewritingSpec b bv) => a -> b -> b -> b -iteSpec = constructTernarySpec iteTerm pevalITETerm - -addNumSpec :: (TermRewritingSpec a av, Num av) => a -> a -> a -addNumSpec = constructBinarySpec addNumTerm pevalAddNumTerm - -uminusNumSpec :: (TermRewritingSpec a av, Num av) => a -> a -uminusNumSpec = constructUnarySpec uminusNumTerm pevalUMinusNumTerm - -timesNumSpec :: (TermRewritingSpec a av, Num av) => a -> a -> a -timesNumSpec = constructBinarySpec timesNumTerm pevalTimesNumTerm - -absNumSpec :: (TermRewritingSpec a av, Num av) => a -> a -absNumSpec = constructUnarySpec absNumTerm pevalAbsNumTerm - -signumNumSpec :: (TermRewritingSpec a av, Num av) => a -> a -signumNumSpec = constructUnarySpec signumNumTerm pevalSignumNumTerm - -ltNumSpec :: (TermRewritingSpec a av, Num av, Ord av, TermRewritingSpec b Bool) => a -> a -> b -ltNumSpec = constructBinarySpec ltNumTerm pevalLtNumTerm - -leNumSpec :: (TermRewritingSpec a av, Num av, Ord av, TermRewritingSpec b Bool) => a -> a -> b -leNumSpec = constructBinarySpec leNumTerm pevalLeNumTerm - -andBitsSpec :: (TermRewritingSpec a av, Bits av) => a -> a -> a -andBitsSpec = constructBinarySpec andBitsTerm pevalAndBitsTerm - -orBitsSpec :: (TermRewritingSpec a av, Bits av) => a -> a -> a -orBitsSpec = constructBinarySpec orBitsTerm pevalOrBitsTerm - -xorBitsSpec :: (TermRewritingSpec a av, Bits av) => a -> a -> a -xorBitsSpec = constructBinarySpec xorBitsTerm pevalXorBitsTerm - -complementBitsSpec :: (TermRewritingSpec a av, Bits av) => a -> a -complementBitsSpec = constructUnarySpec complementBitsTerm pevalComplementBitsTerm - -shiftLeftSpec :: (TermRewritingSpec a av, Integral av, FiniteBits av, SymShift av) => a -> a -> a -shiftLeftSpec = constructBinarySpec shiftLeftTerm pevalShiftLeftTerm - -shiftRightSpec :: (TermRewritingSpec a av, Integral av, FiniteBits av, SymShift av) => a -> a -> a -shiftRightSpec = constructBinarySpec shiftRightTerm pevalShiftRightTerm - -rotateLeftSpec :: (TermRewritingSpec a av, Integral av, FiniteBits av, SymRotate av) => a -> a -> a -rotateLeftSpec = constructBinarySpec rotateLeftTerm pevalRotateLeftTerm - -rotateRightSpec :: (TermRewritingSpec a av, Integral av, FiniteBits av, SymRotate av) => a -> a -> a -rotateRightSpec = constructBinarySpec rotateRightTerm pevalRotateRightTerm - -bvconcatSpec :: - ( TermRewritingSpec a (bv an), - TermRewritingSpec b (bv bn), - TermRewritingSpec c (bv (an + bn)), - forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n), - Typeable bv, - KnownNat an, - KnownNat bn, - KnownNat (an + bn), - 1 <= an, - 1 <= bn, - 1 <= an + bn, - SizedBV bv - ) => - a -> - b -> - c -bvconcatSpec = constructBinarySpec bvconcatTerm pevalBVConcatTerm - -bvselectSpec :: - ( TermRewritingSpec a (bv an), - TermRewritingSpec b (bv bn), - forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n), - Typeable bv, - KnownNat an, - KnownNat ix, - KnownNat bn, - 1 <= an, - 1 <= bn, - 0 <= ix, - ix + bn <= an, - SizedBV bv - ) => - proxy ix -> - proxy bn -> - a -> - b -bvselectSpec p1 p2 = constructUnarySpec (bvselectTerm p1 p2) (pevalBVSelectTerm p1 p2) - -bvextendSpec :: - ( TermRewritingSpec a (bv an), - TermRewritingSpec b (bv bn), - forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n), - Typeable bv, - KnownNat an, - KnownNat bn, - 1 <= an, - 1 <= bn, - an <= bn, - SizedBV bv - ) => - Bool -> - proxy bn -> - a -> - b -bvextendSpec signed p = constructUnarySpec (bvextendTerm signed p) (pevalBVExtendTerm signed p) - -divIntegralSpec :: (TermRewritingSpec a b, Integral b) => a -> a -> a -divIntegralSpec = constructBinarySpec divIntegralTerm pevalDivIntegralTerm - -modIntegralSpec :: (TermRewritingSpec a b, Integral b) => a -> a -> a -modIntegralSpec = constructBinarySpec modIntegralTerm pevalModIntegralTerm - -quotIntegralSpec :: (TermRewritingSpec a b, Integral b) => a -> a -> a -quotIntegralSpec = constructBinarySpec quotIntegralTerm pevalQuotIntegralTerm - -remIntegralSpec :: (TermRewritingSpec a b, Integral b) => a -> a -> a -remIntegralSpec = constructBinarySpec remIntegralTerm pevalRemIntegralTerm - -divBoundedIntegralSpec :: (TermRewritingSpec a b, Bounded b, Integral b) => a -> a -> a -divBoundedIntegralSpec = constructBinarySpec divBoundedIntegralTerm pevalDivBoundedIntegralTerm - -modBoundedIntegralSpec :: (TermRewritingSpec a b, Bounded b, Integral b) => a -> a -> a -modBoundedIntegralSpec = constructBinarySpec modBoundedIntegralTerm pevalModBoundedIntegralTerm - -quotBoundedIntegralSpec :: (TermRewritingSpec a b, Bounded b, Integral b) => a -> a -> a -quotBoundedIntegralSpec = constructBinarySpec quotBoundedIntegralTerm pevalQuotBoundedIntegralTerm - -remBoundedIntegralSpec :: (TermRewritingSpec a b, Bounded b, Integral b) => a -> a -> a -remBoundedIntegralSpec = constructBinarySpec remBoundedIntegralTerm pevalRemBoundedIntegralTerm - -data BoolOnlySpec = BoolOnlySpec (Term Bool) (Term Bool) - -instance Show BoolOnlySpec where - show (BoolOnlySpec n r) = "BoolOnlySpec { no: " ++ pformat n ++ ", re: " ++ pformat r ++ " }" - -instance TermRewritingSpec BoolOnlySpec Bool where - norewriteVer (BoolOnlySpec n _) = n - rewriteVer (BoolOnlySpec _ r) = r - wrap = BoolOnlySpec - same s = eqvTerm (norewriteVer s) (rewriteVer s) - -boolonly :: Int -> Gen BoolOnlySpec -boolonly 0 = - let s = - oneof $ - return . symSpec . (<> "bool") - <$> ["a", "b", "c", "d", "e", "f", "g"] - r = oneof $ return . conSpec <$> [True, False] - in oneof [r, s] -boolonly n | n > 0 = do - v1 <- boolonly (n - 1) - v2 <- boolonly (n - 1) - v3 <- boolonly (n - 1) - oneof - [ return $ notSpec v1, - return $ andSpec v1 v2, - return $ orSpec v1 v2, - return $ eqvSpec v1 v2, - return $ iteSpec v1 v2 v3 - ] -boolonly _ = error "Should never be called" - -instance Arbitrary BoolOnlySpec where - arbitrary = sized boolonly - -data BoolWithLIASpec = BoolWithLIASpec (Term Bool) (Term Bool) - -instance Show BoolWithLIASpec where - show (BoolWithLIASpec n r) = "BoolWithLIASpec { no: " ++ pformat n ++ ", re: " ++ pformat r ++ " }" - -instance TermRewritingSpec BoolWithLIASpec Bool where - norewriteVer (BoolWithLIASpec n _) = n - rewriteVer (BoolWithLIASpec _ r) = r - wrap = BoolWithLIASpec - same s = eqvTerm (norewriteVer s) (rewriteVer s) - -data LIAWithBoolSpec = LIAWithBoolSpec (Term Integer) (Term Integer) - -instance Show LIAWithBoolSpec where - show (LIAWithBoolSpec n r) = - "LIAWithBoolSpec { no: " ++ pformat n ++ ", re: " ++ pformat r ++ " }" - -instance TermRewritingSpec LIAWithBoolSpec Integer where - norewriteVer (LIAWithBoolSpec n _) = n - rewriteVer (LIAWithBoolSpec _ r) = r - wrap = LIAWithBoolSpec - same s = eqvTerm (norewriteVer s) (rewriteVer s) - -boolWithLIA :: Int -> Gen BoolWithLIASpec -boolWithLIA 0 = - let s = - oneof $ - return . symSpec . (<> "bool") - <$> ["a", "b", "c", "d", "e", "f", "g"] - r = oneof $ return . conSpec <$> [True, False] - in oneof [r, s] -boolWithLIA n | n > 0 = do - v1 <- boolWithLIA (n - 1) - v2 <- boolWithLIA (n - 1) - v3 <- boolWithLIA (n - 1) - v1i <- liaWithBool (n - 1) - v2i <- liaWithBool (n - 1) - frequency - [ (1, return $ notSpec v1), - (1, return $ andSpec v1 v2), - (1, return $ orSpec v1 v2), - (1, return $ eqvSpec v1 v2), - (5, return $ eqvSpec v1i v2i), - (5, return $ ltNumSpec v1i v2i), - (5, return $ leNumSpec v1i v2i), - (1, return $ iteSpec v1 v2 v3) - ] -boolWithLIA _ = error "Should never be called" - -liaWithBool :: Int -> Gen LIAWithBoolSpec -liaWithBool 0 = - let s = - oneof $ - return . symSpec . (<> "int") - <$> ["a", "b", "c", "d", "e", "f", "g"] - r = conSpec <$> arbitrary - in oneof [r, s] -liaWithBool n | n > 0 = do - v1b <- boolWithLIA (n - 1) - v1i <- liaWithBool (n - 1) - v2i <- liaWithBool (n - 1) - oneof - [ return $ uminusNumSpec v1i, - return $ absNumSpec v1i, - return $ signumNumSpec v1i, - return $ addNumSpec v1i v2i, - return $ iteSpec v1b v1i v2i - ] -liaWithBool _ = error "Should never be called" - -instance Arbitrary BoolWithLIASpec where - arbitrary = sized boolWithLIA - -instance Arbitrary LIAWithBoolSpec where - arbitrary = sized liaWithBool - -data FixedSizedBVWithBoolSpec (bv :: Nat -> Type) (n :: Nat) = FixedSizedBVWithBoolSpec (Term (bv n)) (Term (bv n)) - -instance (SupportedPrim (bv n)) => Show (FixedSizedBVWithBoolSpec bv n) where - show (FixedSizedBVWithBoolSpec n r) = "FixedSizedBVWithBoolSpec { no: " ++ pformat n ++ ", re: " ++ pformat r ++ " }" - -instance (SupportedPrim (bv n)) => TermRewritingSpec (FixedSizedBVWithBoolSpec bv n) (bv n) where - norewriteVer (FixedSizedBVWithBoolSpec n _) = n - rewriteVer (FixedSizedBVWithBoolSpec _ r) = r - wrap = FixedSizedBVWithBoolSpec - same s = eqvTerm (norewriteVer s) (rewriteVer s) - -data BoolWithFixedSizedBVSpec (bv :: Nat -> Type) (n :: Nat) = BoolWithFixedSizedBVSpec (Term Bool) (Term Bool) - -instance Show (BoolWithFixedSizedBVSpec bv n) where - show (BoolWithFixedSizedBVSpec n r) = - "BoolWithFixedSizedBVSpec { no: " ++ pformat n ++ ", re: " ++ pformat r ++ " }" - -instance TermRewritingSpec (BoolWithFixedSizedBVSpec bv n) Bool where - norewriteVer (BoolWithFixedSizedBVSpec n _) = n - rewriteVer (BoolWithFixedSizedBVSpec _ r) = r - wrap = BoolWithFixedSizedBVSpec - same s = eqvTerm (norewriteVer s) (rewriteVer s) - -boolWithFSBV :: - forall p1 p2 bv n. - (SupportedBV bv n) => - p1 bv -> - p2 n -> - Int -> - Gen (BoolWithFixedSizedBVSpec bv n) -boolWithFSBV _ _ 0 = - let s = - oneof $ - return . symSpec . (<> "bool") - <$> ["a", "b", "c", "d", "e", "f", "g"] - r = oneof $ return . conSpec <$> [True, False] - in oneof [r, s] -boolWithFSBV pbv pn n | n > 0 = do - v1 <- boolWithFSBV pbv pn (n - 1) - v2 <- boolWithFSBV pbv pn (n - 1) - v3 <- boolWithFSBV pbv pn (n - 1) - v1i <- fsbvWithBool pbv pn (n - 1) - v2i <- fsbvWithBool pbv pn (n - 1) - frequency - [ (1, return $ notSpec v1), - (1, return $ andSpec v1 v2), - (1, return $ orSpec v1 v2), - (1, return $ eqvSpec v1 v2), - (5, return $ eqvSpec v1i v2i), - (5, return $ ltNumSpec v1i v2i), - (5, return $ leNumSpec v1i v2i), - (1, return $ iteSpec v1 v2 v3) - ] -boolWithFSBV _ _ _ = error "Should never be called" - -fsbvWithBool :: - forall p1 p2 bv n. - (SupportedBV bv n) => - p1 bv -> - p2 n -> - Int -> - Gen (FixedSizedBVWithBoolSpec bv n) -fsbvWithBool _ _ 0 = - let s = - oneof $ - return . symSpec . (<> "int") - <$> ["a", "b", "c", "d", "e", "f", "g"] - r = - conSpec - <$> oneof - [ return minBound, - return maxBound, - fromInteger <$> arbitrary - ] - in oneof [r, s] -fsbvWithBool pbv pn n | n > 0 = do - v1b <- boolWithFSBV pbv pn (n - 1) - v1i <- fsbvWithBool pbv pn (n - 1) - v2i <- fsbvWithBool pbv pn (n - 1) - oneof - [ return $ uminusNumSpec v1i, - return $ absNumSpec v1i, - return $ signumNumSpec v1i, - return $ addNumSpec v1i v2i, - return $ timesNumSpec v1i v2i, - return $ andBitsSpec v1i v2i, - return $ orBitsSpec v1i v2i, - return $ xorBitsSpec v1i v2i, - return $ complementBitsSpec v1i, - return $ shiftLeftSpec v1i v2i, - return $ rotateLeftSpec v1i v2i, - return $ shiftRightSpec v1i v2i, - return $ rotateRightSpec v1i v2i, - return $ iteSpec v1b v1i v2i - ] -fsbvWithBool _ _ _ = error "Should never be called" - -instance (SupportedBV bv n) => Arbitrary (BoolWithFixedSizedBVSpec bv n) where - arbitrary = sized (boolWithFSBV (Proxy @bv) (Proxy @n)) - -instance (SupportedBV bv n) => Arbitrary (FixedSizedBVWithBoolSpec bv n) where - arbitrary = sized (fsbvWithBool Proxy Proxy) - -data DifferentSizeBVSpec bv (n :: Nat) = DifferentSizeBVSpec (Term (bv n)) (Term (bv n)) - -instance (SupportedPrim (bv n)) => Show (DifferentSizeBVSpec bv n) where - show (DifferentSizeBVSpec n r) = "DSizeBVSpec { no: " ++ pformat n ++ ", re: " ++ pformat r ++ " }" - -instance (SupportedPrim (bv n)) => TermRewritingSpec (DifferentSizeBVSpec bv n) (bv n) where - norewriteVer (DifferentSizeBVSpec n _) = n - rewriteVer (DifferentSizeBVSpec _ r) = r - wrap = DifferentSizeBVSpec - same s = eqvTerm (norewriteVer s) (rewriteVer s) - -type SupportedBV bv (n :: Nat) = - ( SupportedPrim (bv n), - Ord (bv n), - Num (bv n), - FiniteBits (bv n), - Integral (bv n), - Bounded (bv n), - SymShift (bv n), - SymRotate (bv n) - ) - -dsbv1 :: - forall proxy bv. - ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n), - SupportedBV bv 1, - SupportedBV bv 2, - SupportedBV bv 3, - SupportedBV bv 4, - Typeable bv, - SizedBV bv - ) => - proxy bv -> - Int -> - Gen (DifferentSizeBVSpec bv 1) -dsbv1 _ 0 = - let s = - oneof $ - return . symSpec . (<> "bv1") - <$> ["a", "b", "c", "d", "e", "f", "g"] - r = conSpec . fromInteger <$> arbitrary - in oneof [r, s] -dsbv1 p depth | depth > 0 = do - v1 <- dsbv1 p (depth - 1) - v1' <- dsbv1 p (depth - 1) - v2 <- dsbv2 p (depth - 1) - v3 <- dsbv3 p (depth - 1) - v4 <- dsbv4 p (depth - 1) - oneof - [ return $ uminusNumSpec v1, - return $ absNumSpec v1, - return $ signumNumSpec v1, - return $ addNumSpec v1 v1', - return $ timesNumSpec v1 v1', - return $ andBitsSpec v1 v1', - return $ orBitsSpec v1 v1', - return $ xorBitsSpec v1 v1', - return $ complementBitsSpec v1, - return $ shiftLeftSpec v1 v1', - return $ rotateLeftSpec v1 v1', - return $ shiftRightSpec v1 v1', - return $ rotateRightSpec v1 v1', - return $ bvselectSpec (Proxy @0) (Proxy @1) v4, - return $ bvselectSpec (Proxy @1) (Proxy @1) v4, - return $ bvselectSpec (Proxy @2) (Proxy @1) v4, - return $ bvselectSpec (Proxy @3) (Proxy @1) v4, - return $ bvselectSpec (Proxy @0) (Proxy @1) v3, - return $ bvselectSpec (Proxy @1) (Proxy @1) v3, - return $ bvselectSpec (Proxy @2) (Proxy @1) v3, - return $ bvselectSpec (Proxy @0) (Proxy @1) v2, - return $ bvselectSpec (Proxy @1) (Proxy @1) v2, - return $ bvselectSpec (Proxy @0) (Proxy @1) v1 - ] -dsbv1 _ _ = error "Should never be called" - -dsbv2 :: - forall proxy bv. - ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n), - SupportedBV bv 1, - SupportedBV bv 2, - SupportedBV bv 3, - SupportedBV bv 4, - Typeable bv, - SizedBV bv - ) => - proxy bv -> - Int -> - Gen (DifferentSizeBVSpec bv 2) -dsbv2 _ 0 = - let s = - oneof $ - return . symSpec . (<> "bv2") - <$> ["a", "b", "c", "d", "e", "f", "g"] - r = conSpec . fromInteger <$> arbitrary - in oneof [r, s] -dsbv2 p depth | depth > 0 = do - v1 <- dsbv1 p (depth - 1) - v1' <- dsbv1 p (depth - 1) - v2 <- dsbv2 p (depth - 1) - v2' <- dsbv2 p (depth - 1) - v3 <- dsbv3 p (depth - 1) - v4 <- dsbv4 p (depth - 1) - oneof - [ return $ uminusNumSpec v2, - return $ absNumSpec v2, - return $ signumNumSpec v2, - return $ addNumSpec v2 v2', - return $ timesNumSpec v2 v2', - return $ andBitsSpec v2 v2', - return $ orBitsSpec v2 v2', - return $ xorBitsSpec v2 v2', - return $ complementBitsSpec v2, - return $ shiftLeftSpec v2 v2', - return $ rotateLeftSpec v2 v2', - return $ shiftRightSpec v2 v2', - return $ rotateRightSpec v2 v2', - return $ bvselectSpec (Proxy @0) (Proxy @2) v4, - return $ bvselectSpec (Proxy @1) (Proxy @2) v4, - return $ bvselectSpec (Proxy @2) (Proxy @2) v4, - return $ bvselectSpec (Proxy @0) (Proxy @2) v3, - return $ bvselectSpec (Proxy @1) (Proxy @2) v3, - return $ bvselectSpec (Proxy @0) (Proxy @2) v2, - return $ bvconcatSpec v1 v1', - return $ bvextendSpec False (Proxy @2) v1, - return $ bvextendSpec True (Proxy @2) v1 - ] -dsbv2 _ _ = error "Should never be called" - -dsbv3 :: - forall proxy bv. - ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n), - SupportedBV bv 1, - SupportedBV bv 2, - SupportedBV bv 3, - SupportedBV bv 4, - Typeable bv, - SizedBV bv - ) => - proxy bv -> - Int -> - Gen (DifferentSizeBVSpec bv 3) -dsbv3 _ 0 = - let s = - oneof $ - return . symSpec . (<> "bv3") - <$> ["a", "b", "c", "d", "e", "f", "g"] - r = conSpec . fromInteger <$> arbitrary - in oneof [r, s] -dsbv3 p depth | depth > 0 = do - v1 <- dsbv1 p (depth - 1) - v2 <- dsbv2 p (depth - 1) - v3 <- dsbv3 p (depth - 1) - v3' <- dsbv3 p (depth - 1) - v4 <- dsbv4 p (depth - 1) - oneof - [ return $ uminusNumSpec v3, - return $ absNumSpec v3, - return $ signumNumSpec v3, - return $ addNumSpec v3 v3', - return $ timesNumSpec v3 v3', - return $ andBitsSpec v3 v3', - return $ orBitsSpec v3 v3', - return $ xorBitsSpec v3 v3', - return $ complementBitsSpec v3, - return $ shiftLeftSpec v3 v3', - return $ rotateLeftSpec v3 v3', - return $ shiftRightSpec v3 v3', - return $ rotateRightSpec v3 v3', - return $ bvselectSpec (Proxy @0) (Proxy @3) v4, - return $ bvselectSpec (Proxy @1) (Proxy @3) v4, - return $ bvselectSpec (Proxy @0) (Proxy @3) v3, - return $ bvconcatSpec v1 v2, - return $ bvconcatSpec v2 v1, - return $ bvextendSpec False (Proxy @3) v1, - return $ bvextendSpec True (Proxy @3) v1, - return $ bvextendSpec False (Proxy @3) v2, - return $ bvextendSpec True (Proxy @3) v2 - ] -dsbv3 _ _ = error "Should never be called" - -dsbv4 :: - forall proxy bv. - ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n), - SupportedBV bv 1, - SupportedBV bv 2, - SupportedBV bv 3, - SupportedBV bv 4, - Typeable bv, - SizedBV bv - ) => - proxy bv -> - Int -> - Gen (DifferentSizeBVSpec bv 4) -dsbv4 _ 0 = - let s = - oneof $ - return . symSpec . (<> "bv4") - <$> ["a", "b", "c", "d", "e", "f", "g"] - r = conSpec . fromInteger <$> arbitrary - in oneof [r, s] -dsbv4 p depth | depth > 0 = do - v1 <- dsbv1 p (depth - 1) - v2 <- dsbv2 p (depth - 1) - v2' <- dsbv2 p (depth - 1) - v3 <- dsbv3 p (depth - 1) - v4 <- dsbv4 p (depth - 1) - v4' <- dsbv4 p (depth - 1) - oneof - [ return $ uminusNumSpec v4, - return $ absNumSpec v4, - return $ signumNumSpec v4, - return $ addNumSpec v4 v4', - return $ timesNumSpec v4 v4', - return $ andBitsSpec v4 v4', - return $ orBitsSpec v4 v4', - return $ xorBitsSpec v4 v4', - return $ complementBitsSpec v4, - return $ shiftLeftSpec v4 v4', - return $ rotateLeftSpec v4 v4', - return $ shiftRightSpec v4 v4', - return $ rotateRightSpec v4 v4', - return $ bvselectSpec (Proxy @0) (Proxy @4) v4, - return $ bvconcatSpec v1 v3, - return $ bvconcatSpec v2 v2', - return $ bvconcatSpec v3 v1, - return $ bvextendSpec False (Proxy @4) v1, - return $ bvextendSpec True (Proxy @4) v1, - return $ bvextendSpec False (Proxy @4) v2, - return $ bvextendSpec True (Proxy @4) v2, - return $ bvextendSpec False (Proxy @4) v3, - return $ bvextendSpec True (Proxy @4) v3 - ] -dsbv4 _ _ = error "Should never be called" - -instance - ( forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n), - SupportedBV bv 1, - SupportedBV bv 2, - SupportedBV bv 3, - SupportedBV bv 4, - Typeable bv, - SizedBV bv - ) => - Arbitrary (DifferentSizeBVSpec bv 4) - where - arbitrary = sized (dsbv4 Proxy) - -data GeneralSpec s = GeneralSpec (Term s) (Term s) - -instance (SupportedPrim s) => Show (GeneralSpec s) where - show (GeneralSpec n r) = "GeneralSpec { no: " ++ pformat n ++ ", re: " ++ pformat r ++ " }" - -instance (SupportedPrim s) => TermRewritingSpec (GeneralSpec s) s where - norewriteVer (GeneralSpec n _) = n - rewriteVer (GeneralSpec _ r) = r - wrap = GeneralSpec - same s = eqvTerm (norewriteVer s) (rewriteVer s) diff --git a/test/Grisette/Backend/SBV/Data/SMT/TermRewritingTests.hs b/test/Grisette/Backend/SBV/Data/SMT/TermRewritingTests.hs deleted file mode 100644 --- a/test/Grisette/Backend/SBV/Data/SMT/TermRewritingTests.hs +++ /dev/null @@ -1,331 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE UndecidableInstances #-} - -module Grisette.Backend.SBV.Data.SMT.TermRewritingTests - ( termRewritingTests, - validateSpec, - ) -where - -import Data.Foldable (traverse_) -import qualified Data.SBV as SBV -import Grisette.Backend.SBV.Data.SMT.Solving - ( GrisetteSMTConfig, - precise, - ) -import Grisette.Backend.SBV.Data.SMT.TermRewritingGen - ( BoolOnlySpec, - BoolWithLIASpec, - DifferentSizeBVSpec, - FixedSizedBVWithBoolSpec, - GeneralSpec, - LIAWithBoolSpec, - TermRewritingSpec - ( conSpec, - counterExample, - norewriteVer, - rewriteVer, - same, - symSpec - ), - absNumSpec, - addNumSpec, - andSpec, - divBoundedIntegralSpec, - divIntegralSpec, - eqvSpec, - iteSpec, - modBoundedIntegralSpec, - modIntegralSpec, - notSpec, - orSpec, - quotBoundedIntegralSpec, - quotIntegralSpec, - remBoundedIntegralSpec, - remIntegralSpec, - shiftRightSpec, - timesNumSpec, - uminusNumSpec, - ) -import Grisette.Core.Data.BV (IntN, WordN) -import Grisette.Core.Data.Class.Solver (solve) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term - ( SupportedPrim, - ) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.TermUtils - ( pformat, - ) -import Grisette.IR.SymPrim.Data.SymPrim (SymBool (SymBool)) -import Test.Framework (Test, TestName, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.HUnit (Assertion, assertFailure) -import Test.QuickCheck (ioProperty, mapSize, withMaxSuccess) - -validateSpec :: (TermRewritingSpec a av, Show a, SupportedPrim av) => GrisetteSMTConfig n -> a -> Assertion -validateSpec config a = do - r <- solve config (SymBool $ counterExample a) - rs <- solve config (SymBool $ same a) - case (r, rs) of - (Left _, Right _) -> do - return () - (Left _, Left _) -> do - assertFailure $ "Bad rewriting with unsolvable formula: " ++ pformat (norewriteVer a) ++ " was rewritten to " ++ pformat (rewriteVer a) - (Right m, _) -> do - assertFailure $ "With model" ++ show m ++ "Bad rewriting: " ++ pformat (norewriteVer a) ++ " was rewritten to " ++ pformat (rewriteVer a) - -unboundedConfig = precise SBV.z3 - -divisionTest :: - forall a b. - (TermRewritingSpec a b, Show a, Enum b, Num b, SupportedPrim b) => - TestName -> - (a -> a -> a) -> - Test -divisionTest name f = - testGroup - name - [ testCase "on concrete" $ do - traverse_ - ( \(x :: b, y :: b) -> do - validateSpec @a unboundedConfig $ f (conSpec x) (conSpec y) - ) - [(i, j) | i <- [-3 .. 3], j <- [-3 .. 3]], - testCase "on single concrete" $ do - traverse_ - ( \x -> do - validateSpec @a unboundedConfig $ f (conSpec x) (symSpec "a") - validateSpec @a unboundedConfig $ f (symSpec "a") (conSpec x) - ) - [-3 .. 3] - ] - -termRewritingTests :: Test -termRewritingTests = - testGroup - "TermRewriting" - [ testGroup - "Bool only" - [ testProperty "Bool only random test" $ - mapSize (`min` 10) $ - ioProperty . \(x :: BoolOnlySpec) -> do - validateSpec unboundedConfig x, - testCase "Regression nested ite with (ite a (ite b c d) e) with b is true" $ do - validateSpec @BoolOnlySpec - unboundedConfig - ( iteSpec - (symSpec "a" :: BoolOnlySpec) - ( iteSpec - (orSpec (notSpec (andSpec (symSpec "b1") (symSpec "b2"))) (symSpec "b2") :: BoolOnlySpec) - (symSpec "c") - (symSpec "d") - ) - (symSpec "e") - ), - testCase "Regression for pevalImpliesTerm _ false should be false" $ do - validateSpec @BoolOnlySpec - unboundedConfig - ( iteSpec - (symSpec "fbool" :: BoolOnlySpec) - ( notSpec - ( orSpec - (orSpec (notSpec (andSpec (symSpec "gbool" :: BoolOnlySpec) (symSpec "fbool" :: BoolOnlySpec))) (symSpec "gbool" :: BoolOnlySpec)) - (orSpec (symSpec "abool" :: BoolOnlySpec) (notSpec (andSpec (symSpec "gbool" :: BoolOnlySpec) (symSpec "bbool" :: BoolOnlySpec)))) - ) - ) - (symSpec "xxx" :: BoolOnlySpec) - ) - ], - testGroup - "LIA" - [ testProperty "LIA random test" $ - mapSize (`min` 10) $ - ioProperty . \(x :: LIAWithBoolSpec) -> do - validateSpec unboundedConfig x, - testCase "Regression nested ite with (ite a b (ite c d e)) with c implies a" $ do - validateSpec @LIAWithBoolSpec - unboundedConfig - ( iteSpec - (notSpec (eqvSpec (symSpec "v" :: LIAWithBoolSpec) (conSpec 1 :: LIAWithBoolSpec) :: BoolWithLIASpec)) - (symSpec "b") - ( iteSpec - (eqvSpec (symSpec "v" :: LIAWithBoolSpec) (conSpec 2 :: LIAWithBoolSpec) :: BoolWithLIASpec) - (symSpec "d") - (symSpec "d") - ) - ) - ], - testGroup - "Different sized signed BV" - [ testProperty "Random test" $ - withMaxSuccess 1000 . mapSize (`min` 5) $ - ioProperty . \(x :: (DifferentSizeBVSpec IntN 4)) -> do - validateSpec unboundedConfig x - ], - testGroup - "Fixed sized signed BV" - [ testProperty "Random test on IntN 1" $ - withMaxSuccess 200 . mapSize (`min` 5) $ - ioProperty . \(x :: (FixedSizedBVWithBoolSpec IntN 1)) -> do - validateSpec unboundedConfig x, - testProperty "Random test on IntN 2" $ - withMaxSuccess 200 . mapSize (`min` 5) $ - ioProperty . \(x :: (FixedSizedBVWithBoolSpec IntN 2)) -> do - validateSpec unboundedConfig x, - testProperty "Random test on IntN 4" $ - withMaxSuccess 200 . mapSize (`min` 5) $ - ioProperty . \(x :: (FixedSizedBVWithBoolSpec IntN 4)) -> do - validateSpec unboundedConfig x, - testProperty "Random test on IntN 63" $ - withMaxSuccess 200 . mapSize (`min` 1) $ - ioProperty . \(x :: (FixedSizedBVWithBoolSpec IntN 63)) -> do - validateSpec unboundedConfig x, - testProperty "Random test on IntN 64" $ - withMaxSuccess 200 . mapSize (`min` 1) $ - ioProperty . \(x :: (FixedSizedBVWithBoolSpec IntN 64)) -> do - validateSpec unboundedConfig x, - testProperty "Random test on IntN 65" $ - withMaxSuccess 200 . mapSize (`min` 1) $ - ioProperty . \(x :: (FixedSizedBVWithBoolSpec IntN 65)) -> do - validateSpec unboundedConfig x, - testProperty "Random test on IntN 128" $ - withMaxSuccess 200 . mapSize (`min` 1) $ - ioProperty . \(x :: (FixedSizedBVWithBoolSpec IntN 128)) -> do - validateSpec unboundedConfig x - ], - testGroup - "Different sized unsigned BV" - [ testProperty "random test" $ - withMaxSuccess 1000 . mapSize (`min` 5) $ - ioProperty . \(x :: (DifferentSizeBVSpec WordN 4)) -> do - validateSpec unboundedConfig x - ], - testGroup - "Fixed sized unsigned BV" - [ testProperty "Random test on WordN 1" $ - withMaxSuccess 200 . mapSize (`min` 5) $ - ioProperty . \(x :: (FixedSizedBVWithBoolSpec WordN 1)) -> do - validateSpec unboundedConfig x, - testProperty "Random test on WordN 2" $ - withMaxSuccess 200 . mapSize (`min` 5) $ - ioProperty . \(x :: (FixedSizedBVWithBoolSpec WordN 2)) -> do - validateSpec unboundedConfig x, - testProperty "Random test on WordN 4" $ - withMaxSuccess 200 . mapSize (`min` 5) $ - ioProperty . \(x :: (FixedSizedBVWithBoolSpec WordN 4)) -> do - validateSpec unboundedConfig x, - testProperty "Random test on WordN 63" $ - withMaxSuccess 200 . mapSize (`min` 1) $ - ioProperty . \(x :: (FixedSizedBVWithBoolSpec WordN 63)) -> do - validateSpec unboundedConfig x, - testProperty "Random test on WordN 64" $ - withMaxSuccess 200 . mapSize (`min` 1) $ - ioProperty . \(x :: (FixedSizedBVWithBoolSpec WordN 64)) -> do - validateSpec unboundedConfig x, - testProperty "Random test on WordN 65" $ - withMaxSuccess 200 . mapSize (`min` 1) $ - ioProperty . \(x :: (FixedSizedBVWithBoolSpec WordN 65)) -> do - validateSpec unboundedConfig x, - testProperty "Random test on WordN 128" $ - withMaxSuccess 200 . mapSize (`min` 1) $ - ioProperty . \(x :: (FixedSizedBVWithBoolSpec WordN 128)) -> do - validateSpec unboundedConfig x - ], - testCase "Regression: shift twice and the sum of shift amount overflows" $ do - validateSpec @(FixedSizedBVWithBoolSpec IntN 4) - unboundedConfig - ( shiftRightSpec - (shiftRightSpec (symSpec "fint") (conSpec 0x5)) - (conSpec 0x5) - ), - testGroup - "Regression for abs on unsigned BV" - [ testCase "abs on negate" $ - validateSpec @(FixedSizedBVWithBoolSpec WordN 4) - unboundedConfig - (absNumSpec (uminusNumSpec (symSpec "a"))), - testCase "abs on times negate" $ - validateSpec @(FixedSizedBVWithBoolSpec WordN 4) - unboundedConfig - (absNumSpec (timesNumSpec (symSpec "a") (uminusNumSpec (symSpec "b")))) - ], - testGroup - "timesNumSpec on integer" - [ testCase "times on both concrete" $ do - traverse_ - (\(x, y) -> validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (conSpec x) (conSpec y)) - [(i, j) | i <- [-3 .. 3], j <- [-3 .. 3]], - testCase "times on single concrete" $ do - traverse_ - ( \x -> do - validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (conSpec x) (symSpec "a") - validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (symSpec "a") (conSpec x) - ) - [-3 .. 3], - testCase "Two times with two concrete combined" $ do - traverse_ - ( \(x, y) -> do - validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (conSpec x) $ timesNumSpec (conSpec y) (symSpec "a") - validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (conSpec x) $ timesNumSpec (symSpec "a") (conSpec y) - validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (timesNumSpec (conSpec x) (symSpec "a")) (conSpec y) - validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (timesNumSpec (symSpec "a") (conSpec x)) (conSpec y) - ) - [(i, j) | i <- [-3 .. 3], j <- [-3 .. 3]], - testCase "Two times with one concrete" $ do - traverse_ - ( \x -> do - validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (conSpec x) $ timesNumSpec (symSpec "b") (symSpec "a") - validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (symSpec "b") $ timesNumSpec (symSpec "a") (conSpec x) - validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (symSpec "b") $ timesNumSpec (conSpec x) (symSpec "a") - validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (timesNumSpec (conSpec x) (symSpec "a")) (symSpec "b") - validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (timesNumSpec (symSpec "a") (conSpec x)) (symSpec "b") - validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (timesNumSpec (symSpec "a") (symSpec "b")) (conSpec x) - ) - [-3 .. 3], - testCase "times and add with two concretes combined" $ do - traverse_ - ( \(x, y) -> do - validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (conSpec x) $ addNumSpec (conSpec y) (symSpec "a") - validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (conSpec x) $ addNumSpec (symSpec "a") (conSpec y) - validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (addNumSpec (conSpec x) (symSpec "a")) (conSpec y) - validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (addNumSpec (symSpec "a") (conSpec x)) (conSpec y) - validateSpec @(GeneralSpec Integer) unboundedConfig $ addNumSpec (conSpec x) $ timesNumSpec (conSpec y) (symSpec "a") - validateSpec @(GeneralSpec Integer) unboundedConfig $ addNumSpec (conSpec x) $ timesNumSpec (symSpec "a") (conSpec y) - validateSpec @(GeneralSpec Integer) unboundedConfig $ addNumSpec (timesNumSpec (conSpec x) (symSpec "a")) (conSpec y) - validateSpec @(GeneralSpec Integer) unboundedConfig $ addNumSpec (timesNumSpec (symSpec "a") (conSpec x)) (conSpec y) - ) - [(i, j) | i <- [-3 .. 3], j <- [-3 .. 3]], - testCase "times concrete with uminusNumSpec symbolic" $ do - traverse_ - ( \x -> do - validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (conSpec x) (uminusNumSpec $ symSpec "a") - validateSpec @(GeneralSpec Integer) unboundedConfig $ timesNumSpec (uminusNumSpec $ symSpec "a") (conSpec x) - ) - [-3 .. 3] - ], - testGroup - "divisions on integer" - [ divisionTest @(GeneralSpec Integer) "div" divIntegralSpec, - divisionTest @(GeneralSpec Integer) "mod" modIntegralSpec, - divisionTest @(GeneralSpec Integer) "quot" quotIntegralSpec, - divisionTest @(GeneralSpec Integer) "rem" remIntegralSpec - ], - testGroup - "divisions on signed bv" - [ divisionTest @(GeneralSpec (IntN 4)) "div" divBoundedIntegralSpec, - divisionTest @(GeneralSpec (IntN 4)) "mod" modBoundedIntegralSpec, - divisionTest @(GeneralSpec (IntN 4)) "quot" quotBoundedIntegralSpec, - divisionTest @(GeneralSpec (IntN 4)) "rem" remBoundedIntegralSpec - ], - testGroup - "divisions on unsigned bv" - [ divisionTest @(GeneralSpec (WordN 4)) "div" divIntegralSpec, - divisionTest @(GeneralSpec (WordN 4)) "mod" modIntegralSpec, - divisionTest @(GeneralSpec (WordN 4)) "quot" quotIntegralSpec, - divisionTest @(GeneralSpec (WordN 4)) "rem" remIntegralSpec - ] - ] diff --git a/test/Grisette/Backend/TermRewritingGen.hs b/test/Grisette/Backend/TermRewritingGen.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/Backend/TermRewritingGen.hs @@ -0,0 +1,837 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Grisette.Backend.TermRewritingGen + ( TermRewritingSpec (..), + GeneralSpec (..), + DifferentSizeBVSpec (..), + FixedSizedBVWithBoolSpec (..), + BoolWithLIASpec (..), + LIAWithBoolSpec (..), + BoolOnlySpec (..), + constructUnarySpec', + constructBinarySpec', + constructTernarySpec', + divIntegralSpec, + modIntegralSpec, + quotIntegralSpec, + remIntegralSpec, + negNumSpec, + mulNumSpec, + addNumSpec, + absNumSpec, + iteSpec, + eqvSpec, + notSpec, + andSpec, + orSpec, + shiftLeftSpec, + shiftRightSpec, + rotateLeftSpec, + rotateRightSpec, + xorBitsSpec, + ) +where + +import Data.Bits (FiniteBits) +import Data.Data (Proxy (Proxy), Typeable) +import Data.Kind (Type) +import qualified Data.Text as T +import GHC.TypeLits (KnownNat, Nat, type (+), type (<=)) +import Grisette (Identifier, SizedBV, SymRotate, SymShift, withInfo) +import Grisette.Internal.SymPrim.Prim.Term + ( BinaryOp (pevalBinary), + PEvalBVTerm + ( pevalBVConcatTerm, + pevalBVExtendTerm, + pevalBVSelectTerm + ), + PEvalBitwiseTerm + ( pevalAndBitsTerm, + pevalComplementBitsTerm, + pevalOrBitsTerm, + pevalXorBitsTerm + ), + PEvalDivModIntegralTerm + ( pevalDivIntegralTerm, + pevalModIntegralTerm, + pevalQuotIntegralTerm, + pevalRemIntegralTerm + ), + PEvalNumTerm + ( pevalAbsNumTerm, + pevalAddNumTerm, + pevalMulNumTerm, + pevalNegNumTerm, + pevalSignumNumTerm + ), + PEvalOrdTerm (pevalLeOrdTerm, pevalLtOrdTerm), + PEvalRotateTerm + ( pevalRotateLeftTerm, + pevalRotateRightTerm + ), + PEvalShiftTerm + ( pevalShiftLeftTerm, + pevalShiftRightTerm + ), + SupportedPrim (pevalITETerm), + Term, + TernaryOp (pevalTernary), + UnaryOp (pevalUnary), + absNumTerm, + addNumTerm, + andBitsTerm, + andTerm, + bvconcatTerm, + bvextendTerm, + bvselectTerm, + complementBitsTerm, + conTerm, + constructBinary, + constructTernary, + constructUnary, + divIntegralTerm, + eqTerm, + iteTerm, + leOrdTerm, + ltOrdTerm, + modIntegralTerm, + mulNumTerm, + negNumTerm, + notTerm, + orBitsTerm, + orTerm, + pevalAndTerm, + pevalEqTerm, + pevalNotTerm, + pevalOrTerm, + pformat, + quotIntegralTerm, + remIntegralTerm, + rotateLeftTerm, + rotateRightTerm, + shiftLeftTerm, + shiftRightTerm, + signumNumTerm, + ssymTerm, + xorBitsTerm, + ) +import Test.QuickCheck (Arbitrary (arbitrary), Gen, frequency, oneof, sized) + +class (SupportedPrim b) => TermRewritingSpec a b | a -> b where + norewriteVer :: a -> Term b + rewriteVer :: a -> Term b + wrap :: Term b -> Term b -> a + same :: a -> Term Bool + counterExample :: a -> Term Bool + counterExample = notTerm . same + symSpec :: Identifier -> a + symSpec s = wrap (ssymTerm s) (ssymTerm s) + conSpec :: b -> a + conSpec v = wrap (conTerm v) (conTerm v) + +constructUnarySpec :: + forall a av b bv. + ( TermRewritingSpec a av, + TermRewritingSpec b bv + ) => + (Term av -> Term bv) -> + (Term av -> Term bv) -> + a -> + b +constructUnarySpec construct partial a = + wrap (construct $ norewriteVer a) (partial $ rewriteVer a) + +constructUnarySpec' :: + forall a av b bv tag. + ( TermRewritingSpec a av, + TermRewritingSpec b bv, + UnaryOp tag av bv + ) => + tag -> + a -> + b +constructUnarySpec' tag = constructUnarySpec @a @av @b @bv (constructUnary tag) (pevalUnary tag) + +constructBinarySpec :: + forall a av b bv c cv. + ( TermRewritingSpec a av, + TermRewritingSpec b bv, + TermRewritingSpec c cv + ) => + (Term av -> Term bv -> Term cv) -> + (Term av -> Term bv -> Term cv) -> + a -> + b -> + c +constructBinarySpec construct partial a b = + wrap + (construct (norewriteVer a) (norewriteVer b)) + (partial (rewriteVer a) (rewriteVer b)) + +constructBinarySpec' :: + forall a av b bv c cv tag. + ( TermRewritingSpec a av, + TermRewritingSpec b bv, + TermRewritingSpec c cv, + BinaryOp tag av bv cv + ) => + tag -> + a -> + b -> + c +constructBinarySpec' tag = constructBinarySpec @a @av @b @bv @c @cv (constructBinary tag) (pevalBinary tag) + +constructTernarySpec :: + forall a av b bv c cv d dv. + ( TermRewritingSpec a av, + TermRewritingSpec b bv, + TermRewritingSpec c cv, + TermRewritingSpec d dv + ) => + (Term av -> Term bv -> Term cv -> Term dv) -> + (Term av -> Term bv -> Term cv -> Term dv) -> + a -> + b -> + c -> + d +constructTernarySpec construct partial a b c = + wrap + (construct (norewriteVer a) (norewriteVer b) (norewriteVer c)) + (partial (rewriteVer a) (rewriteVer b) (rewriteVer c)) + +constructTernarySpec' :: + forall a av b bv c cv d dv tag. + ( TermRewritingSpec a av, + TermRewritingSpec b bv, + TermRewritingSpec c cv, + TermRewritingSpec d dv, + TernaryOp tag av bv cv dv + ) => + tag -> + a -> + b -> + c -> + d +constructTernarySpec' tag = + constructTernarySpec @a @av @b @bv @c @cv @d @dv + (constructTernary tag) + (pevalTernary tag) + +notSpec :: (TermRewritingSpec a Bool) => a -> a +notSpec = constructUnarySpec notTerm pevalNotTerm + +andSpec :: (TermRewritingSpec a Bool) => a -> a -> a +andSpec = constructBinarySpec andTerm pevalAndTerm + +orSpec :: (TermRewritingSpec a Bool) => a -> a -> a +orSpec = constructBinarySpec orTerm pevalOrTerm + +eqvSpec :: (TermRewritingSpec a av, TermRewritingSpec b Bool) => a -> a -> b +eqvSpec = constructBinarySpec eqTerm pevalEqTerm + +iteSpec :: (TermRewritingSpec a Bool, TermRewritingSpec b bv) => a -> b -> b -> b +iteSpec = constructTernarySpec iteTerm pevalITETerm + +addNumSpec :: (TermRewritingSpec a av, PEvalNumTerm av) => a -> a -> a +addNumSpec = constructBinarySpec addNumTerm pevalAddNumTerm + +negNumSpec :: (TermRewritingSpec a av, PEvalNumTerm av) => a -> a +negNumSpec = constructUnarySpec negNumTerm pevalNegNumTerm + +mulNumSpec :: (TermRewritingSpec a av, PEvalNumTerm av) => a -> a -> a +mulNumSpec = constructBinarySpec mulNumTerm pevalMulNumTerm + +absNumSpec :: (TermRewritingSpec a av, PEvalNumTerm av) => a -> a +absNumSpec = constructUnarySpec absNumTerm pevalAbsNumTerm + +signumNumSpec :: (TermRewritingSpec a av, PEvalNumTerm av) => a -> a +signumNumSpec = constructUnarySpec signumNumTerm pevalSignumNumTerm + +ltOrdSpec :: + (TermRewritingSpec a av, PEvalOrdTerm av, TermRewritingSpec b Bool) => + a -> + a -> + b +ltOrdSpec = constructBinarySpec ltOrdTerm pevalLtOrdTerm + +leOrdSpec :: + (TermRewritingSpec a av, PEvalOrdTerm av, TermRewritingSpec b Bool) => + a -> + a -> + b +leOrdSpec = constructBinarySpec leOrdTerm pevalLeOrdTerm + +andBitsSpec :: (TermRewritingSpec a av, PEvalBitwiseTerm av) => a -> a -> a +andBitsSpec = constructBinarySpec andBitsTerm pevalAndBitsTerm + +orBitsSpec :: (TermRewritingSpec a av, PEvalBitwiseTerm av) => a -> a -> a +orBitsSpec = constructBinarySpec orBitsTerm pevalOrBitsTerm + +xorBitsSpec :: (TermRewritingSpec a av, PEvalBitwiseTerm av) => a -> a -> a +xorBitsSpec = constructBinarySpec xorBitsTerm pevalXorBitsTerm + +complementBitsSpec :: (TermRewritingSpec a av, PEvalBitwiseTerm av) => a -> a +complementBitsSpec = constructUnarySpec complementBitsTerm pevalComplementBitsTerm + +shiftLeftSpec :: (TermRewritingSpec a av, PEvalShiftTerm av) => a -> a -> a +shiftLeftSpec = constructBinarySpec shiftLeftTerm pevalShiftLeftTerm + +shiftRightSpec :: (TermRewritingSpec a av, PEvalShiftTerm av) => a -> a -> a +shiftRightSpec = constructBinarySpec shiftRightTerm pevalShiftRightTerm + +rotateLeftSpec :: (TermRewritingSpec a av, PEvalRotateTerm av) => a -> a -> a +rotateLeftSpec = constructBinarySpec rotateLeftTerm pevalRotateLeftTerm + +rotateRightSpec :: (TermRewritingSpec a av, PEvalRotateTerm av) => a -> a -> a +rotateRightSpec = constructBinarySpec rotateRightTerm pevalRotateRightTerm + +bvconcatSpec :: + ( TermRewritingSpec a (bv an), + TermRewritingSpec b (bv bn), + TermRewritingSpec c (bv (an + bn)), + PEvalBVTerm bv, + KnownNat an, + KnownNat bn, + KnownNat (an + bn), + 1 <= an, + 1 <= bn, + 1 <= an + bn + ) => + a -> + b -> + c +bvconcatSpec = constructBinarySpec bvconcatTerm pevalBVConcatTerm + +bvselectSpec :: + ( TermRewritingSpec a (bv an), + TermRewritingSpec b (bv bn), + PEvalBVTerm bv, + KnownNat an, + KnownNat ix, + KnownNat bn, + 1 <= an, + 1 <= bn, + 0 <= ix, + ix + bn <= an + ) => + proxy ix -> + proxy bn -> + a -> + b +bvselectSpec p1 p2 = constructUnarySpec (bvselectTerm p1 p2) (pevalBVSelectTerm p1 p2) + +bvextendSpec :: + ( TermRewritingSpec a (bv an), + TermRewritingSpec b (bv bn), + PEvalBVTerm bv, + KnownNat an, + KnownNat bn, + 1 <= an, + 1 <= bn, + an <= bn + ) => + Bool -> + proxy bn -> + a -> + b +bvextendSpec signed p = constructUnarySpec (bvextendTerm signed p) (pevalBVExtendTerm signed p) + +divIntegralSpec :: (TermRewritingSpec a b, PEvalDivModIntegralTerm b) => a -> a -> a +divIntegralSpec = constructBinarySpec divIntegralTerm pevalDivIntegralTerm + +modIntegralSpec :: (TermRewritingSpec a b, PEvalDivModIntegralTerm b) => a -> a -> a +modIntegralSpec = constructBinarySpec modIntegralTerm pevalModIntegralTerm + +quotIntegralSpec :: (TermRewritingSpec a b, PEvalDivModIntegralTerm b) => a -> a -> a +quotIntegralSpec = constructBinarySpec quotIntegralTerm pevalQuotIntegralTerm + +remIntegralSpec :: (TermRewritingSpec a b, PEvalDivModIntegralTerm b) => a -> a -> a +remIntegralSpec = constructBinarySpec remIntegralTerm pevalRemIntegralTerm + +data BoolOnlySpec = BoolOnlySpec (Term Bool) (Term Bool) + +instance Show BoolOnlySpec where + show (BoolOnlySpec n r) = "BoolOnlySpec { no: " ++ pformat n ++ ", re: " ++ pformat r ++ " }" + +instance TermRewritingSpec BoolOnlySpec Bool where + norewriteVer (BoolOnlySpec n _) = n + rewriteVer (BoolOnlySpec _ r) = r + wrap = BoolOnlySpec + same s = eqTerm (norewriteVer s) (rewriteVer s) + +boolonly :: Int -> Gen BoolOnlySpec +boolonly 0 = + let s = + oneof $ + return . symSpec . (`withInfo` ("bool" :: T.Text)) + <$> ["a", "b", "c", "d", "e", "f", "g"] + r = oneof $ return . conSpec <$> [True, False] + in oneof [r, s] +boolonly n | n > 0 = do + v1 <- boolonly (n - 1) + v2 <- boolonly (n - 1) + v3 <- boolonly (n - 1) + oneof + [ return $ notSpec v1, + return $ andSpec v1 v2, + return $ orSpec v1 v2, + return $ eqvSpec v1 v2, + return $ iteSpec v1 v2 v3 + ] +boolonly _ = error "Should never be called" + +instance Arbitrary BoolOnlySpec where + arbitrary = sized boolonly + +data BoolWithLIASpec = BoolWithLIASpec (Term Bool) (Term Bool) + +instance Show BoolWithLIASpec where + show (BoolWithLIASpec n r) = "BoolWithLIASpec { no: " ++ pformat n ++ ", re: " ++ pformat r ++ " }" + +instance TermRewritingSpec BoolWithLIASpec Bool where + norewriteVer (BoolWithLIASpec n _) = n + rewriteVer (BoolWithLIASpec _ r) = r + wrap = BoolWithLIASpec + same s = eqTerm (norewriteVer s) (rewriteVer s) + +data LIAWithBoolSpec = LIAWithBoolSpec (Term Integer) (Term Integer) + +instance Show LIAWithBoolSpec where + show (LIAWithBoolSpec n r) = + "LIAWithBoolSpec { no: " ++ pformat n ++ ", re: " ++ pformat r ++ " }" + +instance TermRewritingSpec LIAWithBoolSpec Integer where + norewriteVer (LIAWithBoolSpec n _) = n + rewriteVer (LIAWithBoolSpec _ r) = r + wrap = LIAWithBoolSpec + same s = eqTerm (norewriteVer s) (rewriteVer s) + +boolWithLIA :: Int -> Gen BoolWithLIASpec +boolWithLIA 0 = + let s = + oneof $ + return . symSpec . (`withInfo` ("bool" :: T.Text)) + <$> ["a", "b", "c", "d", "e", "f", "g"] + r = oneof $ return . conSpec <$> [True, False] + in oneof [r, s] +boolWithLIA n | n > 0 = do + v1 <- boolWithLIA (n - 1) + v2 <- boolWithLIA (n - 1) + v3 <- boolWithLIA (n - 1) + v1i <- liaWithBool (n - 1) + v2i <- liaWithBool (n - 1) + frequency + [ (1, return $ notSpec v1), + (1, return $ andSpec v1 v2), + (1, return $ orSpec v1 v2), + (1, return $ eqvSpec v1 v2), + (5, return $ eqvSpec v1i v2i), + (5, return $ ltOrdSpec v1i v2i), + (5, return $ leOrdSpec v1i v2i), + (1, return $ iteSpec v1 v2 v3) + ] +boolWithLIA _ = error "Should never be called" + +liaWithBool :: Int -> Gen LIAWithBoolSpec +liaWithBool 0 = + let s = + oneof $ + return . symSpec . (`withInfo` ("int" :: T.Text)) + <$> ["a", "b", "c", "d", "e", "f", "g"] + r = conSpec <$> arbitrary + in oneof [r, s] +liaWithBool n | n > 0 = do + v1b <- boolWithLIA (n - 1) + v1i <- liaWithBool (n - 1) + v2i <- liaWithBool (n - 1) + oneof + [ return $ negNumSpec v1i, + return $ absNumSpec v1i, + return $ signumNumSpec v1i, + return $ addNumSpec v1i v2i, + return $ iteSpec v1b v1i v2i + ] +liaWithBool _ = error "Should never be called" + +instance Arbitrary BoolWithLIASpec where + arbitrary = sized boolWithLIA + +instance Arbitrary LIAWithBoolSpec where + arbitrary = sized liaWithBool + +data FixedSizedBVWithBoolSpec (bv :: Nat -> Type) (n :: Nat) = FixedSizedBVWithBoolSpec (Term (bv n)) (Term (bv n)) + +instance (SupportedPrim (bv n)) => Show (FixedSizedBVWithBoolSpec bv n) where + show (FixedSizedBVWithBoolSpec n r) = "FixedSizedBVWithBoolSpec { no: " ++ pformat n ++ ", re: " ++ pformat r ++ " }" + +instance (SupportedPrim (bv n)) => TermRewritingSpec (FixedSizedBVWithBoolSpec bv n) (bv n) where + norewriteVer (FixedSizedBVWithBoolSpec n _) = n + rewriteVer (FixedSizedBVWithBoolSpec _ r) = r + wrap = FixedSizedBVWithBoolSpec + same s = eqTerm (norewriteVer s) (rewriteVer s) + +data BoolWithFixedSizedBVSpec (bv :: Nat -> Type) (n :: Nat) = BoolWithFixedSizedBVSpec (Term Bool) (Term Bool) + +instance Show (BoolWithFixedSizedBVSpec bv n) where + show (BoolWithFixedSizedBVSpec n r) = + "BoolWithFixedSizedBVSpec { no: " ++ pformat n ++ ", re: " ++ pformat r ++ " }" + +instance TermRewritingSpec (BoolWithFixedSizedBVSpec bv n) Bool where + norewriteVer (BoolWithFixedSizedBVSpec n _) = n + rewriteVer (BoolWithFixedSizedBVSpec _ r) = r + wrap = BoolWithFixedSizedBVSpec + same s = eqTerm (norewriteVer s) (rewriteVer s) + +boolWithFSBV :: + forall p1 p2 bv n. + (SupportedBV bv n) => + p1 bv -> + p2 n -> + Int -> + Gen (BoolWithFixedSizedBVSpec bv n) +boolWithFSBV _ _ 0 = + let s = + oneof $ + return . symSpec . (`withInfo` ("bool" :: T.Text)) + <$> ["a", "b", "c", "d", "e", "f", "g"] + r = oneof $ return . conSpec <$> [True, False] + in oneof [r, s] +boolWithFSBV pbv pn n | n > 0 = do + v1 <- boolWithFSBV pbv pn (n - 1) + v2 <- boolWithFSBV pbv pn (n - 1) + v3 <- boolWithFSBV pbv pn (n - 1) + v1i <- fsbvWithBool pbv pn (n - 1) + v2i <- fsbvWithBool pbv pn (n - 1) + frequency + [ (1, return $ notSpec v1), + (1, return $ andSpec v1 v2), + (1, return $ orSpec v1 v2), + (1, return $ eqvSpec v1 v2), + (5, return $ eqvSpec v1i v2i), + (5, return $ ltOrdSpec v1i v2i), + (5, return $ leOrdSpec v1i v2i), + (1, return $ iteSpec v1 v2 v3) + ] +boolWithFSBV _ _ _ = error "Should never be called" + +fsbvWithBool :: + forall p1 p2 bv n. + (SupportedBV bv n) => + p1 bv -> + p2 n -> + Int -> + Gen (FixedSizedBVWithBoolSpec bv n) +fsbvWithBool _ _ 0 = + let s = + oneof $ + return . symSpec . (`withInfo` ("int" :: T.Text)) + <$> ["a", "b", "c", "d", "e", "f", "g"] + r = + conSpec + <$> oneof + [ return minBound, + return maxBound, + fromInteger <$> arbitrary + ] + in oneof [r, s] +fsbvWithBool pbv pn n | n > 0 = do + v1b <- boolWithFSBV pbv pn (n - 1) + v1i <- fsbvWithBool pbv pn (n - 1) + v2i <- fsbvWithBool pbv pn (n - 1) + oneof + [ return $ negNumSpec v1i, + return $ absNumSpec v1i, + return $ signumNumSpec v1i, + return $ addNumSpec v1i v2i, + return $ mulNumSpec v1i v2i, + return $ andBitsSpec v1i v2i, + return $ orBitsSpec v1i v2i, + return $ xorBitsSpec v1i v2i, + return $ complementBitsSpec v1i, + return $ shiftLeftSpec v1i v2i, + return $ rotateLeftSpec v1i v2i, + return $ shiftRightSpec v1i v2i, + return $ rotateRightSpec v1i v2i, + return $ iteSpec v1b v1i v2i + ] +fsbvWithBool _ _ _ = error "Should never be called" + +instance (SupportedBV bv n) => Arbitrary (BoolWithFixedSizedBVSpec bv n) where + arbitrary = sized (boolWithFSBV (Proxy @bv) (Proxy @n)) + +instance (SupportedBV bv n) => Arbitrary (FixedSizedBVWithBoolSpec bv n) where + arbitrary = sized (fsbvWithBool Proxy Proxy) + +data DifferentSizeBVSpec bv (n :: Nat) = DifferentSizeBVSpec (Term (bv n)) (Term (bv n)) + +instance (SupportedPrim (bv n)) => Show (DifferentSizeBVSpec bv n) where + show (DifferentSizeBVSpec n r) = "DSizeBVSpec { no: " ++ pformat n ++ ", re: " ++ pformat r ++ " }" + +instance (SupportedPrim (bv n)) => TermRewritingSpec (DifferentSizeBVSpec bv n) (bv n) where + norewriteVer (DifferentSizeBVSpec n _) = n + rewriteVer (DifferentSizeBVSpec _ r) = r + wrap = DifferentSizeBVSpec + same s = eqTerm (norewriteVer s) (rewriteVer s) + +type SupportedBV bv (n :: Nat) = + ( SupportedPrim (bv n), + Ord (bv n), + Num (bv n), + FiniteBits (bv n), + Integral (bv n), + Bounded (bv n), + SymShift (bv n), + SymRotate (bv n), + PEvalShiftTerm (bv n), + PEvalRotateTerm (bv n), + PEvalNumTerm (bv n), + PEvalOrdTerm (bv n), + PEvalBitwiseTerm (bv n), + PEvalBVTerm bv + ) + +dsbv1 :: + forall proxy bv. + ( SupportedBV bv 1, + SupportedBV bv 2, + SupportedBV bv 3, + SupportedBV bv 4, + Typeable bv, + SizedBV bv + ) => + proxy bv -> + Int -> + Gen (DifferentSizeBVSpec bv 1) +dsbv1 _ 0 = + let s = + oneof $ + return . symSpec . (`withInfo` ("bv1" :: T.Text)) + <$> ["a", "b", "c", "d", "e", "f", "g"] + r = conSpec . fromInteger <$> arbitrary + in oneof [r, s] +dsbv1 p depth | depth > 0 = do + v1 <- dsbv1 p (depth - 1) + v1' <- dsbv1 p (depth - 1) + v2 <- dsbv2 p (depth - 1) + v3 <- dsbv3 p (depth - 1) + v4 <- dsbv4 p (depth - 1) + oneof + [ return $ negNumSpec v1, + return $ absNumSpec v1, + return $ signumNumSpec v1, + return $ addNumSpec v1 v1', + return $ mulNumSpec v1 v1', + return $ andBitsSpec v1 v1', + return $ orBitsSpec v1 v1', + return $ xorBitsSpec v1 v1', + return $ complementBitsSpec v1, + return $ shiftLeftSpec v1 v1', + return $ rotateLeftSpec v1 v1', + return $ shiftRightSpec v1 v1', + return $ rotateRightSpec v1 v1', + return $ bvselectSpec (Proxy @0) (Proxy @1) v4, + return $ bvselectSpec (Proxy @1) (Proxy @1) v4, + return $ bvselectSpec (Proxy @2) (Proxy @1) v4, + return $ bvselectSpec (Proxy @3) (Proxy @1) v4, + return $ bvselectSpec (Proxy @0) (Proxy @1) v3, + return $ bvselectSpec (Proxy @1) (Proxy @1) v3, + return $ bvselectSpec (Proxy @2) (Proxy @1) v3, + return $ bvselectSpec (Proxy @0) (Proxy @1) v2, + return $ bvselectSpec (Proxy @1) (Proxy @1) v2, + return $ bvselectSpec (Proxy @0) (Proxy @1) v1 + ] +dsbv1 _ _ = error "Should never be called" + +dsbv2 :: + forall proxy bv. + ( SupportedBV bv 1, + SupportedBV bv 2, + SupportedBV bv 3, + SupportedBV bv 4, + Typeable bv, + SizedBV bv + ) => + proxy bv -> + Int -> + Gen (DifferentSizeBVSpec bv 2) +dsbv2 _ 0 = + let s = + oneof $ + return . symSpec . (`withInfo` ("bv2" :: T.Text)) + <$> ["a", "b", "c", "d", "e", "f", "g"] + r = conSpec . fromInteger <$> arbitrary + in oneof [r, s] +dsbv2 p depth | depth > 0 = do + v1 <- dsbv1 p (depth - 1) + v1' <- dsbv1 p (depth - 1) + v2 <- dsbv2 p (depth - 1) + v2' <- dsbv2 p (depth - 1) + v3 <- dsbv3 p (depth - 1) + v4 <- dsbv4 p (depth - 1) + oneof + [ return $ negNumSpec v2, + return $ absNumSpec v2, + return $ signumNumSpec v2, + return $ addNumSpec v2 v2', + return $ mulNumSpec v2 v2', + return $ andBitsSpec v2 v2', + return $ orBitsSpec v2 v2', + return $ xorBitsSpec v2 v2', + return $ complementBitsSpec v2, + return $ shiftLeftSpec v2 v2', + return $ rotateLeftSpec v2 v2', + return $ shiftRightSpec v2 v2', + return $ rotateRightSpec v2 v2', + return $ bvselectSpec (Proxy @0) (Proxy @2) v4, + return $ bvselectSpec (Proxy @1) (Proxy @2) v4, + return $ bvselectSpec (Proxy @2) (Proxy @2) v4, + return $ bvselectSpec (Proxy @0) (Proxy @2) v3, + return $ bvselectSpec (Proxy @1) (Proxy @2) v3, + return $ bvselectSpec (Proxy @0) (Proxy @2) v2, + return $ bvconcatSpec v1 v1', + return $ bvextendSpec False (Proxy @2) v1, + return $ bvextendSpec True (Proxy @2) v1 + ] +dsbv2 _ _ = error "Should never be called" + +dsbv3 :: + forall proxy bv. + ( SupportedBV bv 1, + SupportedBV bv 2, + SupportedBV bv 3, + SupportedBV bv 4, + Typeable bv, + SizedBV bv + ) => + proxy bv -> + Int -> + Gen (DifferentSizeBVSpec bv 3) +dsbv3 _ 0 = + let s = + oneof $ + return . symSpec . (`withInfo` ("bv3" :: T.Text)) + <$> ["a", "b", "c", "d", "e", "f", "g"] + r = conSpec . fromInteger <$> arbitrary + in oneof [r, s] +dsbv3 p depth | depth > 0 = do + v1 <- dsbv1 p (depth - 1) + v2 <- dsbv2 p (depth - 1) + v3 <- dsbv3 p (depth - 1) + v3' <- dsbv3 p (depth - 1) + v4 <- dsbv4 p (depth - 1) + oneof + [ return $ negNumSpec v3, + return $ absNumSpec v3, + return $ signumNumSpec v3, + return $ addNumSpec v3 v3', + return $ mulNumSpec v3 v3', + return $ andBitsSpec v3 v3', + return $ orBitsSpec v3 v3', + return $ xorBitsSpec v3 v3', + return $ complementBitsSpec v3, + return $ shiftLeftSpec v3 v3', + return $ rotateLeftSpec v3 v3', + return $ shiftRightSpec v3 v3', + return $ rotateRightSpec v3 v3', + return $ bvselectSpec (Proxy @0) (Proxy @3) v4, + return $ bvselectSpec (Proxy @1) (Proxy @3) v4, + return $ bvselectSpec (Proxy @0) (Proxy @3) v3, + return $ bvconcatSpec v1 v2, + return $ bvconcatSpec v2 v1, + return $ bvextendSpec False (Proxy @3) v1, + return $ bvextendSpec True (Proxy @3) v1, + return $ bvextendSpec False (Proxy @3) v2, + return $ bvextendSpec True (Proxy @3) v2 + ] +dsbv3 _ _ = error "Should never be called" + +dsbv4 :: + forall proxy bv. + ( SupportedBV bv 1, + SupportedBV bv 2, + SupportedBV bv 3, + SupportedBV bv 4, + Typeable bv, + SizedBV bv + ) => + proxy bv -> + Int -> + Gen (DifferentSizeBVSpec bv 4) +dsbv4 _ 0 = + let s = + oneof $ + return . symSpec . (`withInfo` ("bv4" :: T.Text)) + <$> ["a", "b", "c", "d", "e", "f", "g"] + r = conSpec . fromInteger <$> arbitrary + in oneof [r, s] +dsbv4 p depth | depth > 0 = do + v1 <- dsbv1 p (depth - 1) + v2 <- dsbv2 p (depth - 1) + v2' <- dsbv2 p (depth - 1) + v3 <- dsbv3 p (depth - 1) + v4 <- dsbv4 p (depth - 1) + v4' <- dsbv4 p (depth - 1) + oneof + [ return $ negNumSpec v4, + return $ absNumSpec v4, + return $ signumNumSpec v4, + return $ addNumSpec v4 v4', + return $ mulNumSpec v4 v4', + return $ andBitsSpec v4 v4', + return $ orBitsSpec v4 v4', + return $ xorBitsSpec v4 v4', + return $ complementBitsSpec v4, + return $ shiftLeftSpec v4 v4', + return $ rotateLeftSpec v4 v4', + return $ shiftRightSpec v4 v4', + return $ rotateRightSpec v4 v4', + return $ bvselectSpec (Proxy @0) (Proxy @4) v4, + return $ bvconcatSpec v1 v3, + return $ bvconcatSpec v2 v2', + return $ bvconcatSpec v3 v1, + return $ bvextendSpec False (Proxy @4) v1, + return $ bvextendSpec True (Proxy @4) v1, + return $ bvextendSpec False (Proxy @4) v2, + return $ bvextendSpec True (Proxy @4) v2, + return $ bvextendSpec False (Proxy @4) v3, + return $ bvextendSpec True (Proxy @4) v3 + ] +dsbv4 _ _ = error "Should never be called" + +instance + ( SupportedBV bv 1, + SupportedBV bv 2, + SupportedBV bv 3, + SupportedBV bv 4, + Typeable bv, + SizedBV bv + ) => + Arbitrary (DifferentSizeBVSpec bv 4) + where + arbitrary = sized (dsbv4 Proxy) + +data GeneralSpec s = GeneralSpec (Term s) (Term s) + +instance (SupportedPrim s) => Show (GeneralSpec s) where + show (GeneralSpec n r) = "GeneralSpec { no: " ++ pformat n ++ ", re: " ++ pformat r ++ " }" + +instance (SupportedPrim s) => TermRewritingSpec (GeneralSpec s) s where + norewriteVer (GeneralSpec n _) = n + rewriteVer (GeneralSpec _ r) = r + wrap = GeneralSpec + same s = eqTerm (norewriteVer s) (rewriteVer s) diff --git a/test/Grisette/Backend/TermRewritingTests.hs b/test/Grisette/Backend/TermRewritingTests.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/Backend/TermRewritingTests.hs @@ -0,0 +1,326 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} + +module Grisette.Backend.TermRewritingTests + ( termRewritingTests, + validateSpec, + ) +where + +import Data.Foldable (traverse_) +import qualified Data.SBV as SBV +import Grisette + ( GrisetteSMTConfig, + IntN, + SymBool (SymBool), + WordN, + precise, + solve, + ) +import Grisette.Backend.TermRewritingGen + ( BoolOnlySpec, + BoolWithLIASpec, + DifferentSizeBVSpec, + FixedSizedBVWithBoolSpec, + GeneralSpec, + LIAWithBoolSpec, + TermRewritingSpec + ( conSpec, + counterExample, + norewriteVer, + rewriteVer, + same, + symSpec + ), + absNumSpec, + addNumSpec, + andSpec, + divIntegralSpec, + eqvSpec, + iteSpec, + modIntegralSpec, + mulNumSpec, + negNumSpec, + notSpec, + orSpec, + quotIntegralSpec, + remIntegralSpec, + shiftRightSpec, + ) +import Grisette.Internal.SymPrim.Prim.Term + ( SupportedPrim, + pformat, + ) +import Test.Framework (Test, TestName, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.HUnit (Assertion, assertFailure) +import Test.QuickCheck (ioProperty, mapSize, withMaxSuccess) + +validateSpec :: (TermRewritingSpec a av, Show a, SupportedPrim av) => GrisetteSMTConfig n -> a -> Assertion +validateSpec config a = do + r <- solve config (SymBool $ counterExample a) + rs <- solve config (SymBool $ same a) + case (r, rs) of + (Left _, Right _) -> do + return () + (Left _, Left _) -> do + assertFailure $ "Bad rewriting with unsolvable formula: " ++ pformat (norewriteVer a) ++ " was rewritten to " ++ pformat (rewriteVer a) + (Right m, _) -> do + assertFailure $ "With model" ++ show m ++ "Bad rewriting: " ++ pformat (norewriteVer a) ++ " was rewritten to " ++ pformat (rewriteVer a) + +unboundedConfig = precise SBV.z3 + +divisionTest :: + forall a b. + (TermRewritingSpec a b, Show a, Enum b, Num b, SupportedPrim b) => + TestName -> + (a -> a -> a) -> + Test +divisionTest name f = + testGroup + name + [ testCase "on concrete" $ do + traverse_ + ( \(x :: b, y :: b) -> do + validateSpec @a unboundedConfig $ f (conSpec x) (conSpec y) + ) + [(i, j) | i <- [-3 .. 3], j <- [-3 .. 3]], + testCase "on single concrete" $ do + traverse_ + ( \x -> do + validateSpec @a unboundedConfig $ f (conSpec x) (symSpec "a") + validateSpec @a unboundedConfig $ f (symSpec "a") (conSpec x) + ) + [-3 .. 3] + ] + +termRewritingTests :: Test +termRewritingTests = + testGroup + "TermRewriting" + [ testGroup + "Bool only" + [ testProperty "Bool only random test" $ + mapSize (`min` 10) $ + ioProperty . \(x :: BoolOnlySpec) -> do + validateSpec unboundedConfig x, + testCase "Regression nested ite with (ite a (ite b c d) e) with b is true" $ do + validateSpec @BoolOnlySpec + unboundedConfig + ( iteSpec + (symSpec "a" :: BoolOnlySpec) + ( iteSpec + (orSpec (notSpec (andSpec (symSpec "b1") (symSpec "b2"))) (symSpec "b2") :: BoolOnlySpec) + (symSpec "c") + (symSpec "d") + ) + (symSpec "e") + ), + testCase "Regression for pevalImpliesTerm _ false should be false" $ do + validateSpec @BoolOnlySpec + unboundedConfig + ( iteSpec + (symSpec "fbool" :: BoolOnlySpec) + ( notSpec + ( orSpec + (orSpec (notSpec (andSpec (symSpec "gbool" :: BoolOnlySpec) (symSpec "fbool" :: BoolOnlySpec))) (symSpec "gbool" :: BoolOnlySpec)) + (orSpec (symSpec "abool" :: BoolOnlySpec) (notSpec (andSpec (symSpec "gbool" :: BoolOnlySpec) (symSpec "bbool" :: BoolOnlySpec)))) + ) + ) + (symSpec "xxx" :: BoolOnlySpec) + ) + ], + testGroup + "LIA" + [ testProperty "LIA random test" $ + mapSize (`min` 10) $ + ioProperty . \(x :: LIAWithBoolSpec) -> do + validateSpec unboundedConfig x, + testCase "Regression nested ite with (ite a b (ite c d e)) with c implies a" $ do + validateSpec @LIAWithBoolSpec + unboundedConfig + ( iteSpec + (notSpec (eqvSpec (symSpec "v" :: LIAWithBoolSpec) (conSpec 1 :: LIAWithBoolSpec) :: BoolWithLIASpec)) + (symSpec "b") + ( iteSpec + (eqvSpec (symSpec "v" :: LIAWithBoolSpec) (conSpec 2 :: LIAWithBoolSpec) :: BoolWithLIASpec) + (symSpec "d") + (symSpec "d") + ) + ) + ], + testGroup + "Different sized signed BV" + [ testProperty "Random test" $ + withMaxSuccess 1000 . mapSize (`min` 5) $ + ioProperty . \(x :: (DifferentSizeBVSpec IntN 4)) -> do + validateSpec unboundedConfig x + ], + testGroup + "Fixed sized signed BV" + [ testProperty "Random test on IntN 1" $ + withMaxSuccess 200 . mapSize (`min` 5) $ + ioProperty . \(x :: (FixedSizedBVWithBoolSpec IntN 1)) -> do + validateSpec unboundedConfig x, + testProperty "Random test on IntN 2" $ + withMaxSuccess 200 . mapSize (`min` 5) $ + ioProperty . \(x :: (FixedSizedBVWithBoolSpec IntN 2)) -> do + validateSpec unboundedConfig x, + testProperty "Random test on IntN 4" $ + withMaxSuccess 200 . mapSize (`min` 5) $ + ioProperty . \(x :: (FixedSizedBVWithBoolSpec IntN 4)) -> do + validateSpec unboundedConfig x, + testProperty "Random test on IntN 63" $ + withMaxSuccess 200 . mapSize (`min` 1) $ + ioProperty . \(x :: (FixedSizedBVWithBoolSpec IntN 63)) -> do + validateSpec unboundedConfig x, + testProperty "Random test on IntN 64" $ + withMaxSuccess 200 . mapSize (`min` 1) $ + ioProperty . \(x :: (FixedSizedBVWithBoolSpec IntN 64)) -> do + validateSpec unboundedConfig x, + testProperty "Random test on IntN 65" $ + withMaxSuccess 200 . mapSize (`min` 1) $ + ioProperty . \(x :: (FixedSizedBVWithBoolSpec IntN 65)) -> do + validateSpec unboundedConfig x, + testProperty "Random test on IntN 128" $ + withMaxSuccess 200 . mapSize (`min` 1) $ + ioProperty . \(x :: (FixedSizedBVWithBoolSpec IntN 128)) -> do + validateSpec unboundedConfig x + ], + testGroup + "Different sized unsigned BV" + [ testProperty "random test" $ + withMaxSuccess 1000 . mapSize (`min` 5) $ + ioProperty . \(x :: (DifferentSizeBVSpec WordN 4)) -> do + validateSpec unboundedConfig x + ], + testGroup + "Fixed sized unsigned BV" + [ testProperty "Random test on WordN 1" $ + withMaxSuccess 200 . mapSize (`min` 5) $ + ioProperty . \(x :: (FixedSizedBVWithBoolSpec WordN 1)) -> do + validateSpec unboundedConfig x, + testProperty "Random test on WordN 2" $ + withMaxSuccess 200 . mapSize (`min` 5) $ + ioProperty . \(x :: (FixedSizedBVWithBoolSpec WordN 2)) -> do + validateSpec unboundedConfig x, + testProperty "Random test on WordN 4" $ + withMaxSuccess 200 . mapSize (`min` 5) $ + ioProperty . \(x :: (FixedSizedBVWithBoolSpec WordN 4)) -> do + validateSpec unboundedConfig x, + testProperty "Random test on WordN 63" $ + withMaxSuccess 200 . mapSize (`min` 1) $ + ioProperty . \(x :: (FixedSizedBVWithBoolSpec WordN 63)) -> do + validateSpec unboundedConfig x, + testProperty "Random test on WordN 64" $ + withMaxSuccess 200 . mapSize (`min` 1) $ + ioProperty . \(x :: (FixedSizedBVWithBoolSpec WordN 64)) -> do + validateSpec unboundedConfig x, + testProperty "Random test on WordN 65" $ + withMaxSuccess 200 . mapSize (`min` 1) $ + ioProperty . \(x :: (FixedSizedBVWithBoolSpec WordN 65)) -> do + validateSpec unboundedConfig x, + testProperty "Random test on WordN 128" $ + withMaxSuccess 200 . mapSize (`min` 1) $ + ioProperty . \(x :: (FixedSizedBVWithBoolSpec WordN 128)) -> do + validateSpec unboundedConfig x + ], + testCase "Regression: shift twice and the sum of shift amount overflows" $ do + validateSpec @(FixedSizedBVWithBoolSpec IntN 4) + unboundedConfig + ( shiftRightSpec + (shiftRightSpec (symSpec "fint") (conSpec 0x5)) + (conSpec 0x5) + ), + testGroup + "Regression for abs on unsigned BV" + [ testCase "abs on negate" $ + validateSpec @(FixedSizedBVWithBoolSpec WordN 4) + unboundedConfig + (absNumSpec (negNumSpec (symSpec "a"))), + testCase "abs on times negate" $ + validateSpec @(FixedSizedBVWithBoolSpec WordN 4) + unboundedConfig + (absNumSpec (mulNumSpec (symSpec "a") (negNumSpec (symSpec "b")))) + ], + testGroup + "mulNumSpec on integer" + [ testCase "times on both concrete" $ do + traverse_ + (\(x, y) -> validateSpec @(GeneralSpec Integer) unboundedConfig $ mulNumSpec (conSpec x) (conSpec y)) + [(i, j) | i <- [-3 .. 3], j <- [-3 .. 3]], + testCase "times on single concrete" $ do + traverse_ + ( \x -> do + validateSpec @(GeneralSpec Integer) unboundedConfig $ mulNumSpec (conSpec x) (symSpec "a") + validateSpec @(GeneralSpec Integer) unboundedConfig $ mulNumSpec (symSpec "a") (conSpec x) + ) + [-3 .. 3], + testCase "Two times with two concrete combined" $ do + traverse_ + ( \(x, y) -> do + validateSpec @(GeneralSpec Integer) unboundedConfig $ mulNumSpec (conSpec x) $ mulNumSpec (conSpec y) (symSpec "a") + validateSpec @(GeneralSpec Integer) unboundedConfig $ mulNumSpec (conSpec x) $ mulNumSpec (symSpec "a") (conSpec y) + validateSpec @(GeneralSpec Integer) unboundedConfig $ mulNumSpec (mulNumSpec (conSpec x) (symSpec "a")) (conSpec y) + validateSpec @(GeneralSpec Integer) unboundedConfig $ mulNumSpec (mulNumSpec (symSpec "a") (conSpec x)) (conSpec y) + ) + [(i, j) | i <- [-3 .. 3], j <- [-3 .. 3]], + testCase "Two times with one concrete" $ do + traverse_ + ( \x -> do + validateSpec @(GeneralSpec Integer) unboundedConfig $ mulNumSpec (conSpec x) $ mulNumSpec (symSpec "b") (symSpec "a") + validateSpec @(GeneralSpec Integer) unboundedConfig $ mulNumSpec (symSpec "b") $ mulNumSpec (symSpec "a") (conSpec x) + validateSpec @(GeneralSpec Integer) unboundedConfig $ mulNumSpec (symSpec "b") $ mulNumSpec (conSpec x) (symSpec "a") + validateSpec @(GeneralSpec Integer) unboundedConfig $ mulNumSpec (mulNumSpec (conSpec x) (symSpec "a")) (symSpec "b") + validateSpec @(GeneralSpec Integer) unboundedConfig $ mulNumSpec (mulNumSpec (symSpec "a") (conSpec x)) (symSpec "b") + validateSpec @(GeneralSpec Integer) unboundedConfig $ mulNumSpec (mulNumSpec (symSpec "a") (symSpec "b")) (conSpec x) + ) + [-3 .. 3], + testCase "times and add with two concretes combined" $ do + traverse_ + ( \(x, y) -> do + validateSpec @(GeneralSpec Integer) unboundedConfig $ mulNumSpec (conSpec x) $ addNumSpec (conSpec y) (symSpec "a") + validateSpec @(GeneralSpec Integer) unboundedConfig $ mulNumSpec (conSpec x) $ addNumSpec (symSpec "a") (conSpec y) + validateSpec @(GeneralSpec Integer) unboundedConfig $ mulNumSpec (addNumSpec (conSpec x) (symSpec "a")) (conSpec y) + validateSpec @(GeneralSpec Integer) unboundedConfig $ mulNumSpec (addNumSpec (symSpec "a") (conSpec x)) (conSpec y) + validateSpec @(GeneralSpec Integer) unboundedConfig $ addNumSpec (conSpec x) $ mulNumSpec (conSpec y) (symSpec "a") + validateSpec @(GeneralSpec Integer) unboundedConfig $ addNumSpec (conSpec x) $ mulNumSpec (symSpec "a") (conSpec y) + validateSpec @(GeneralSpec Integer) unboundedConfig $ addNumSpec (mulNumSpec (conSpec x) (symSpec "a")) (conSpec y) + validateSpec @(GeneralSpec Integer) unboundedConfig $ addNumSpec (mulNumSpec (symSpec "a") (conSpec x)) (conSpec y) + ) + [(i, j) | i <- [-3 .. 3], j <- [-3 .. 3]], + testCase "times concrete with negNumSpec symbolic" $ do + traverse_ + ( \x -> do + validateSpec @(GeneralSpec Integer) unboundedConfig $ mulNumSpec (conSpec x) (negNumSpec $ symSpec "a") + validateSpec @(GeneralSpec Integer) unboundedConfig $ mulNumSpec (negNumSpec $ symSpec "a") (conSpec x) + ) + [-3 .. 3] + ], + testGroup + "divisions on integer" + [ divisionTest @(GeneralSpec Integer) "div" divIntegralSpec, + divisionTest @(GeneralSpec Integer) "mod" modIntegralSpec, + divisionTest @(GeneralSpec Integer) "quot" quotIntegralSpec, + divisionTest @(GeneralSpec Integer) "rem" remIntegralSpec + ], + testGroup + "divisions on signed bv" + [ divisionTest @(GeneralSpec (IntN 4)) "div" divIntegralSpec, + divisionTest @(GeneralSpec (IntN 4)) "mod" modIntegralSpec, + divisionTest @(GeneralSpec (IntN 4)) "quot" quotIntegralSpec, + divisionTest @(GeneralSpec (IntN 4)) "rem" remIntegralSpec + ], + testGroup + "divisions on unsigned bv" + [ divisionTest @(GeneralSpec (WordN 4)) "div" divIntegralSpec, + divisionTest @(GeneralSpec (WordN 4)) "mod" modIntegralSpec, + divisionTest @(GeneralSpec (WordN 4)) "quot" quotIntegralSpec, + divisionTest @(GeneralSpec (WordN 4)) "rem" remIntegralSpec + ] + ] diff --git a/test/Grisette/Core/Control/ExceptionTests.hs b/test/Grisette/Core/Control/ExceptionTests.hs --- a/test/Grisette/Core/Control/ExceptionTests.hs +++ b/test/Grisette/Core/Control/ExceptionTests.hs @@ -7,42 +7,28 @@ ( ArrayException (IndexOutOfBounds, UndefinedElement), ) import Control.Monad.Except (ExceptT (ExceptT)) -import Grisette.Core.Control.Exception +import Grisette ( AssertionError (AssertionError), - VerificationConditions (AssertionViolation, AssumptionViolation), - ) -import Grisette.Core.Control.Monad.UnionM (UnionM) -import Grisette.Core.Data.Class.Error - ( TransformError (transformError), - symAssert, - ) -import Grisette.Core.Data.Class.EvaluateSym - ( EvaluateSym (evaluateSym), - ) -import Grisette.Core.Data.Class.ExtractSymbolics - ( ExtractSymbolics (extractSymbolics), - ) -import Grisette.Core.Data.Class.LogicalOp (LogicalOp (symNot)) -import Grisette.Core.Data.Class.Mergeable - ( Mergeable (rootStrategy), + EvaluateSym (evaluateSym), + ExtractSymbolics (extractSymbolics), + LogicalOp (symNot), + Mergeable (rootStrategy), MergingStrategy (SimpleStrategy), - ) -import Grisette.Core.Data.Class.ModelOps - ( ModelOps (emptyModel), + ModelOps (emptyModel), + SEq ((.==)), + SOrd (symCompare, (.<), (.<=), (.>), (.>=)), + SimpleMergeable (mrgIte), + Solvable (con), SymbolSetOps (emptySet), - ) -import Grisette.Core.Data.Class.SEq (SEq ((.==))) -import Grisette.Core.Data.Class.SOrd - ( SOrd (symCompare, (.<), (.<=), (.>), (.>=)), - ) -import Grisette.Core.Data.Class.SimpleMergeable - ( SimpleMergeable (mrgIte), + ToCon (toCon), + ToSym (toSym), + TransformError (transformError), + UnionM, + VerificationConditions (AssertionViolation, AssumptionViolation), mrgIf, mrgSingle, + symAssert, ) -import Grisette.Core.Data.Class.Solvable (Solvable (con)) -import Grisette.Core.Data.Class.ToCon (ToCon (toCon)) -import Grisette.Core.Data.Class.ToSym (ToSym (toSym)) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit ((@?=)) diff --git a/test/Grisette/Core/Control/Monad/UnionMTests.hs b/test/Grisette/Core/Control/Monad/UnionMTests.hs --- a/test/Grisette/Core/Control/Monad/UnionMTests.hs +++ b/test/Grisette/Core/Control/Monad/UnionMTests.hs @@ -1,832 +1,343 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Grisette.Core.Control.Monad.UnionMTests (unionMTests) where - -import qualified Data.ByteString as B -import qualified Data.HashMap.Lazy as ML -import Grisette.Core.BuiltinUnionWrappers (mrgLeft, mrgRight) -import Grisette.Core.Control.Monad.UnionM - ( UnionM, - isMerged, - underlyingUnion, - unionSize, - ) -import Grisette.Core.Data.Class.EvaluateSym - ( EvaluateSym (evaluateSym), - ) -import Grisette.Core.Data.Class.ExtractSymbolics - ( ExtractSymbolics (extractSymbolics), - ) -import Grisette.Core.Data.Class.Function (Function ((#))) -import Grisette.Core.Data.Class.GenSym - ( ListSpec (ListSpec), - choose, - genSym, - genSymSimple, - ) -import Grisette.Core.Data.Class.ITEOp (ITEOp (symIte)) -import Grisette.Core.Data.Class.LogicalOp - ( LogicalOp (symImplies, symNot, symXor, (.&&), (.||)), - ) -import Grisette.Core.Data.Class.ModelOps - ( ModelOps (emptyModel), - ModelRep (buildModel), - SymbolSetRep (buildSymbolSet), - ) -import Grisette.Core.Data.Class.SEq (SEq ((.==))) -import Grisette.Core.Data.Class.SOrd - ( SOrd (symCompare, (.<), (.<=), (.>), (.>=)), - ) -import Grisette.Core.Data.Class.SimpleMergeable - ( SimpleMergeable (mrgIte), - UnionLike (single, unionIf), - UnionPrjOp (ifView, leftMost, singleView, toGuardedList), - merge, - mrgIf, - mrgIte1, - mrgSingle, - (.#), - pattern If, - pattern Single, - ) -import Grisette.Core.Data.Class.Solvable (Solvable (con, conView, isym, ssym)) -import Grisette.Core.Data.Class.SubstituteSym (SubstituteSym (substituteSym)) -import Grisette.Core.Data.Class.ToCon (ToCon (toCon)) -import Grisette.Core.Data.Class.ToSym (ToSym (toSym)) -import Grisette.Core.Data.Union (Union (UnionIf, UnionSingle)) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term (TypedSymbol) -import Grisette.IR.SymPrim.Data.Prim.Model - ( ModelValuePair ((::=)), - ) -import Grisette.IR.SymPrim.Data.SymPrim (SymBool) -import Grisette.TestUtil.SymbolicAssertion ((@?=~)) -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (assertFailure, (@?=)) - -unionMTests :: Test -unionMTests = - testGroup - "UnionM" - [ testCase "Mergeable" $ - do - let r = - ( mrgIf - "a" - ( mrgSingle - ( mrgIf - "b" - (mrgSingle $ Left "c") - (mrgSingle $ Right "d") - ) - ) - ( mrgSingle - ( mrgIf - "e" - (mrgSingle $ Left "f") - (mrgSingle $ Right "g") - ) - ) :: - UnionM (UnionM (Either SymBool SymBool)) - ) - isMerged r @?= True - underlyingUnion (underlyingUnion <$> r) - @?= UnionSingle - ( UnionIf - (Left $ symIte "a" "c" "f") - True - (symIte "a" "b" "e") - (UnionSingle $ Left $ symIte "a" "c" "f") - (UnionSingle $ Right $ symIte "a" "d" "g") - ), - testCase "SimpleMergeable" $ do - let l :: UnionM (Either SymBool SymBool) = - mrgIf "b" (mrgSingle $ Left "c") (mrgSingle $ Right "d") - let r = mrgIf "e" (mrgSingle $ Left "f") (mrgSingle $ Right "g") - let res = mrgIte "a" l r - let ref = - UnionIf - (Left $ symIte "a" "c" "f") - True - (symIte "a" "b" "e") - (UnionSingle $ Left $ symIte "a" "c" "f") - (UnionSingle $ Right $ symIte "a" "d" "g") - isMerged res @?= True - underlyingUnion res @?= ref, - testCase "SimpleMergeable1" $ do - let l :: UnionM SymBool = mrgIf "b" (mrgSingle "c") (mrgSingle "d") - let r :: UnionM SymBool = mrgIf "e" (mrgSingle "f") (mrgSingle "g") - let res = mrgIte1 "a" l r - isMerged res @?= True - underlyingUnion res - @?= UnionSingle - ( symIte - "a" - (symIte "b" "c" "d") - (symIte "e" "f" "g") - ), - testGroup - "Functor" - [ testCase "fmap should work but would strip mergeable knowledge" $ do - let x :: UnionM Integer = - (+ 1) <$> mrgIf "a" (mrgSingle 1) (mrgSingle 2) - x @?= unionIf "a" (return 2) (return 3) - ], - testGroup - "Applicative" - [ testCase "pure should work but won't give us mergeable knowledge" $ - (pure 1 :: UnionM Integer) @?= single 1, - testCase "<*> should work but won't give us mergeable knowledge" $ do - let f :: UnionM (Integer -> Integer) = - mrgIf "a" (mrgSingle id) (mrgSingle (+ 1)) - let v :: UnionM Integer = mrgIf "b" (mrgSingle 1) (mrgSingle 3) - f - <*> v - @?= unionIf - "a" - (unionIf "b" (single 1) (single 3)) - (unionIf "b" (single 2) (single 4)) - ], - testGroup - "Monad" - [ testCase "return should work but won't give us mergeable knowledge" $ - (pure 1 :: UnionM Integer) @?= single 1, - testCase ">>= should work and keeps mergeable knowledge" $ do - let v :: UnionM Integer = mrgIf "a" (mrgSingle 0) (mrgSingle 1) - let f :: Integer -> UnionM Integer = \i -> - mrgIf "b" (mrgSingle $ i + 1) (mrgSingle $ i + 3) - (v >>= f) - @?= mrgIf - "a" - (mrgIf "b" (mrgSingle 1) (mrgSingle 3)) - (mrgIf "b" (mrgSingle 2) (mrgSingle 4)) - ], - testGroup - "UnionOp" - [ testCase "single" $ do - let r1 :: UnionM SymBool = single "a" - isMerged r1 @?= False - underlyingUnion r1 @?= UnionSingle "a", - testGroup - "unionIf" - [ testCase "unionIf should work when no merged" $ do - let r1 :: UnionM SymBool = unionIf "a" (single "b") (single "c") - isMerged r1 @?= False - underlyingUnion r1 - @?= UnionIf "b" False "a" (UnionSingle "b") (UnionSingle "c"), - testCase - "unionIf should propagate and merge the results when some branch merged" - $ do - let r1 :: UnionM SymBool = - unionIf "a" (mrgSingle "b") (single "c") - isMerged r1 @?= True - underlyingUnion r1 @?= UnionSingle (symIte "a" "b" "c") - let r2 :: UnionM SymBool = - unionIf "a" (single "b") (mrgSingle "c") - isMerged r2 @?= True - underlyingUnion r2 @?= UnionSingle (symIte "a" "b" "c") - let r3 :: UnionM SymBool = - unionIf "a" (mrgSingle "b") (mrgSingle "c") - isMerged r3 @?= True - underlyingUnion r3 @?= UnionSingle (symIte "a" "b" "c") - ], - testCase "singleView should work" $ do - singleView (single "a" :: UnionM SymBool) @?= Just "a" - singleView (mrgSingle "a" :: UnionM SymBool) @?= Just "a" - singleView - ( unionIf "a" (single $ Left "b") (single $ Right "c") :: - UnionM (Either SymBool SymBool) - ) - @?= Nothing - case (single "a" :: UnionM SymBool) of - Single r -> r @?= "a" - _ -> assertFailure "Single match failed" - case (mrgSingle "a" :: UnionM SymBool) of - Single r -> r @?= "a" - _ -> assertFailure "Single match failed" - case ( unionIf "a" (single $ Left "b") (single $ Right "c") :: - UnionM (Either SymBool SymBool) - ) of - Single _ -> assertFailure "Single match failed" - _ -> return (), - testCase "ifView should work" $ do - let r1 :: UnionM (Either SymBool SymBool) = - unionIf "a" (single $ Left "b") (single $ Right "c") - let r2 :: UnionM (Either SymBool SymBool) = - mrgIf "a" (mrgSingle $ Left "b") (mrgSingle $ Right "c") - ifView r1 @?= Just ("a", single $ Left "b", single $ Right "c") - ifView r2 - @?= Just ("a", mrgSingle $ Left "b", mrgSingle $ Right "c") - ifView (single "a" :: UnionM SymBool) @?= Nothing - case r1 of - If c l r -> do - c @?= "a" - l @?= single (Left "b") - r @?= single (Right "c") - _ -> assertFailure "Single match failed" - case r2 of - If c l r -> do - c @?= "a" - l @?= mrgSingle (Left "b") - r @?= mrgSingle (Right "c") - _ -> assertFailure "Single match failed" - case single "a" :: UnionM SymBool of - If {} -> assertFailure "Single match failed" - _ -> return (), - testCase "leftMost should work" $ do - leftMost (single "a" :: UnionM SymBool) @?= "a" - leftMost (mrgSingle "a" :: UnionM SymBool) @?= "a" - let r1 :: UnionM (Either SymBool SymBool) = - unionIf "a" (single $ Left "b") (single $ Right "c") - let r2 :: UnionM (Either SymBool SymBool) = - mrgIf "a" (mrgSingle $ Left "b") (mrgSingle $ Right "c") - leftMost r1 @?= Left "b" - leftMost r2 @?= Left "b", - testCase "toGuardedList should work" $ do - let actual = - toGuardedList - ( mrgIf "a" (single 1) (mrgIf "b" (single 2) (single 3)) :: - UnionM Integer - ) - let expected = - [ ("a", 1), - (symNot "a" .&& "b", 2), - (symNot "a" .&& symNot "b", 3) - ] - actual @?=~ expected - ], - testGroup - "MonadUnion" - [ testCase "merge should work" $ do - let r1 :: UnionM SymBool = - merge (unionIf "a" (single "b") (single "c")) - isMerged r1 @?= True - underlyingUnion r1 @?= UnionSingle (symIte "a" "b" "c"), - testCase "mrgSingle should work" $ do - let r1 :: UnionM SymBool = mrgSingle "a" - isMerged r1 @?= True - underlyingUnion r1 @?= UnionSingle "a", - testGroup - "mrgIf should work" - [ testCase "mrgIf should perform lazy evaluation" $ do - (mrgIf (con True) (mrgSingle "a") undefined :: UnionM SymBool) - @?= mrgSingle "a" - (mrgIf (con False) undefined (mrgSingle "a") :: UnionM SymBool) - @?= mrgSingle "a", - testCase "mrgIf should work" $ - (mrgIf "a" (single "b") (single "c") :: UnionM SymBool) - @?= merge (unionIf "a" (single "b") (single "c")) - ] - ], - let a :: SymBool = "a" - b :: SymBool = "b" - c :: SymBool = "c" - d :: SymBool = "d" - e :: SymBool = "e" - f :: SymBool = "f" - g1 :: UnionM (Either SymBool SymBool) = - mrgIf a (mrgSingle $ Left b) (mrgSingle $ Right c) - g2 :: UnionM (Either SymBool SymBool) = - mrgIf d (mrgSingle $ Left e) (mrgSingle $ Right f) - in testGroup - "SEq" - [ testCase "Single/Single" $ - (mrgSingle a :: UnionM SymBool) - .== mrgSingle b - @?= (a .== b), - testCase "If/Single" $ do - g1 - .== mrgSingle (Left d) - @?= symIte a (b .== d) (con False) - g1 - .== mrgSingle (Right d) - @?= symIte a (con False) (c .== d), - testCase "Single/If" $ do - mrgSingle (Left d) - .== g1 - @?= symIte a (d .== b) (con False) - mrgSingle (Right d) - .== g1 - @?= symIte a (con False) (d .== c), - testCase "If/If" $ - g1 - .== g2 - @?= symIte - a - (symIte d (b .== e) (con False)) - (symIte d (con False) (c .== f)) - ], - let a :: SymBool = "a" - b :: SymBool = "b" - c :: SymBool = "c" - d :: SymBool = "d" - e :: SymBool = "e" - f :: SymBool = "f" - - g1 :: UnionM (Either SymBool SymBool) = - mrgIf a (mrgSingle $ Left b) (mrgSingle $ Right c) - g2 :: UnionM (Either SymBool SymBool) = - mrgIf d (mrgSingle $ Left e) (mrgSingle $ Right f) - in testGroup - "SOrd" - [ testCase "Single/Single" $ do - (mrgSingle a :: UnionM SymBool) - .<= mrgSingle b - @?= (a .<= b :: SymBool) - (mrgSingle a :: UnionM SymBool) - .< mrgSingle b - @?= (a .< b :: SymBool) - (mrgSingle a :: UnionM SymBool) - .>= mrgSingle b - @?= (a .>= b :: SymBool) - (mrgSingle a :: UnionM SymBool) - .> mrgSingle b - @?= (a .> b :: SymBool) - (mrgSingle a :: UnionM SymBool) - `symCompare` mrgSingle b - @?= (a `symCompare` b :: UnionM Ordering), - testCase "If/Single" $ do - g1 - .<= mrgSingle (Left d) - @?= symIte a (b .<= d) (con False) - g1 - .< mrgSingle (Left d) - @?= symIte a (b .< d) (con False) - g1 - .>= mrgSingle (Left d) - @?= symIte a (b .>= d) (con True) - g1 - .> mrgSingle (Left d) - @?= symIte a (b .> d) (con True) - - g1 - `symCompare` mrgSingle (Left d) - @?= ( mrgIf a (b `symCompare` d) (mrgSingle GT) :: - UnionM Ordering - ) - - g1 - .<= mrgSingle (Right d) - @?= symIte a (con True) (c .<= d) - g1 - .< mrgSingle (Right d) - @?= symIte a (con True) (c .< d) - g1 - .>= mrgSingle (Right d) - @?= symIte a (con False) (c .>= d) - g1 - .> mrgSingle (Right d) - @?= symIte a (con False) (c .> d) - - g1 - `symCompare` mrgSingle (Right d) - @?= ( mrgIf a (mrgSingle LT) (c `symCompare` d) :: - UnionM Ordering - ), - testCase "Single/If" $ do - mrgSingle (Left d) - .<= g1 - @?= symIte a (d .<= b) (con True) - mrgSingle (Left d) - .< g1 - @?= symIte a (d .< b) (con True) - mrgSingle (Left d) - .>= g1 - @?= symIte a (d .>= b) (con False) - mrgSingle (Left d) - .> g1 - @?= symIte a (d .> b) (con False) - - mrgSingle (Left d) - `symCompare` g1 - @?= ( mrgIf a (d `symCompare` b) (mrgSingle LT) :: - UnionM Ordering - ) - - mrgSingle (Right d) - .<= g1 - @?= symIte a (con False) (d .<= c) - mrgSingle (Right d) - .< g1 - @?= symIte a (con False) (d .< c) - mrgSingle (Right d) - .>= g1 - @?= symIte a (con True) (d .>= c) - mrgSingle (Right d) - .> g1 - @?= symIte a (con True) (d .> c) - - mrgSingle (Right d) - `symCompare` g1 - @?= ( mrgIf a (mrgSingle GT) (d `symCompare` c) :: - UnionM Ordering - ), - testCase "If/If" $ do - g1 - .<= g2 - @?= symIte - a - (symIte d (b .<= e) (con True)) - (symIte d (con False) (c .<= f)) - g1 - .< g2 - @?= symIte - a - (symIte d (b .< e) (con True)) - (symIte d (con False) (c .< f)) - g1 - .>= g2 - @?= symIte - a - (symIte d (b .>= e) (con False)) - (symIte d (con True) (c .>= f)) - g1 - .> g2 - @?= symIte - a - (symIte d (b .> e) (con False)) - (symIte d (con True) (c .> f)) - g1 - `symCompare` g2 - @?= ( mrgIf - a - (mrgIf d (b `symCompare` e) (mrgSingle LT)) - (mrgIf d (mrgSingle GT) (c `symCompare` f)) :: - UnionM Ordering - ) - ], - testGroup - "ToSym" - [ testCase "From single" $ - (toSym True :: UnionM SymBool) @?= mrgSingle (con True), - testCase "From UnionMBase" $ - (toSym (mrgSingle True :: UnionM Bool) :: UnionM SymBool) - @?= mrgSingle (con True) - ], - testGroup - "ToCon" - [ testCase "To single" $ do - (toCon (mrgSingle (con True) :: UnionM SymBool) :: Maybe Bool) - @?= Just True - (toCon (mrgSingle "a" :: UnionM SymBool) :: Maybe Bool) @?= Nothing - ( toCon - ( mrgIf "a" (mrgLeft $ con False) (mrgRight $ con True) :: - UnionM (Either SymBool SymBool) - ) :: - Maybe (Either Bool Bool) - ) - @?= Nothing, - testCase "To UnionMBase" $ do - ( toCon (mrgSingle (con True) :: UnionM SymBool) :: - Maybe (UnionM Bool) - ) - @?= Just (mrgSingle True) - (toCon (mrgSingle "a" :: UnionM SymBool) :: Maybe (UnionM Bool)) - @?= Nothing - ( toCon - ( mrgIf "a" (mrgLeft $ con False) (mrgRight $ con True) :: - UnionM (Either SymBool SymBool) - ) :: - Maybe (UnionM (Either Bool Bool)) - ) - @?= Just (mrgIf "a" (mrgLeft False) (mrgRight True)) - ( toCon - ( mrgIf "a" (mrgLeft "b") (mrgRight $ con True) :: - UnionM (Either SymBool SymBool) - ) :: - Maybe (UnionM (Either Bool Bool)) - ) - @?= Nothing - ], - testCase "Evaluate" $ do - let model = emptyModel - let model1 = buildModel ("a" ::= True, "b" ::= False, "c" ::= True) - evaluateSym False model (mrgSingle "a") - @?= (mrgSingle "a" :: UnionM SymBool) - evaluateSym True model (mrgSingle "a") - @?= (mrgSingle $ con False :: UnionM SymBool) - evaluateSym False model1 (mrgSingle "a") - @?= (mrgSingle $ con True :: UnionM SymBool) - evaluateSym True model1 (mrgSingle "a") - @?= (mrgSingle $ con True :: UnionM SymBool) - evaluateSym - False - model1 - ( mrgIf - "a" - (mrgSingle $ Left "d") - (mrgSingle $ Right "e") - ) - @?= (mrgSingle $ Left "d" :: UnionM (Either SymBool SymBool)) - evaluateSym - True - model1 - ( mrgIf - "a" - (mrgSingle $ Left "d") - (mrgSingle $ Right "e") - ) - @?= (mrgSingle $ Left $ con False :: UnionM (Either SymBool SymBool)) - evaluateSym - False - model1 - ( mrgIf - "d" - (mrgSingle $ Left "a") - (mrgSingle $ Right "b") - ) - @?= ( mrgIf - "d" - (mrgSingle $ Left $ con True) - (mrgSingle $ Right $ con False) :: - UnionM (Either SymBool SymBool) - ) - evaluateSym - True - model1 - ( mrgIf - "d" - (mrgSingle $ Left "a") - (mrgSingle $ Right "b") - ) - @?= (mrgSingle $ Right $ con False :: UnionM (Either SymBool SymBool)) - evaluateSym - False - model1 - ( mrgIf - "a" - (mrgSingle $ Left "b") - (mrgSingle $ Right "c") - ) - @?= ( mrgSingle $ Left $ con False :: - UnionM - (Either SymBool SymBool) - ), - testCase "SubstituteSym" $ do - let asym = "a" :: TypedSymbol Bool - let a = "a" - let b = "b" - let c = "c" - substituteSym - asym - b - (mrgSingle $ Left a :: UnionM (Either SymBool SymBool)) - @?= mrgSingle (Left b) - substituteSym - asym - b - (mrgSingle $ Left c :: UnionM (Either SymBool SymBool)) - @?= mrgSingle (Left c) - substituteSym - asym - b - (mrgSingle $ Right a :: UnionM (Either SymBool SymBool)) - @?= mrgSingle (Right b) - substituteSym - asym - b - (mrgSingle $ Right c :: UnionM (Either SymBool SymBool)) - @?= mrgSingle (Right c) - substituteSym - asym - b - ( mrgIf a (mrgSingle $ Left a) (mrgSingle $ Right c) :: - UnionM (Either SymBool SymBool) - ) - @?= mrgIf b (mrgSingle $ Left b) (mrgSingle $ Right c) - substituteSym - asym - b - ( mrgIf c (mrgSingle $ Left c) (mrgSingle $ Right a) :: - UnionM (Either SymBool SymBool) - ) - @?= mrgIf c (mrgSingle $ Left c) (mrgSingle $ Right b), - testCase "ExtractSymbolic" $ do - extractSymbolics (mrgSingle "a" :: UnionM SymBool) - @?= buildSymbolSet ("a" :: TypedSymbol Bool) - extractSymbolics - ( mrgIf "a" (mrgSingle $ Left "b") (mrgSingle $ Right "c") :: - UnionM (Either SymBool SymBool) - ) - @?= buildSymbolSet - ( "a" :: TypedSymbol Bool, - "b" :: TypedSymbol Bool, - "c" :: TypedSymbol Bool - ), - testGroup - "Num" - [ testCase "fromInteger" $ (1 :: UnionM Integer) @?= mrgSingle 1, - testCase "negate" $ - negate (mrgIf "a" (mrgSingle 1) (mrgSingle 2) :: UnionM Integer) - @?= mrgIf "a" (mrgSingle $ -1) (mrgSingle $ -2), - testCase "plus" $ - (mrgIf "a" (mrgSingle 0) (mrgSingle 1) :: UnionM Integer) - + mrgIf "b" (mrgSingle 1) (mrgSingle 3) - @?= mrgIf - "a" - (mrgIf "b" (mrgSingle 1) (mrgSingle 3)) - (mrgIf "b" (mrgSingle 2) (mrgSingle 4)), - testCase "minus" $ - (mrgIf "a" (mrgSingle 0) (mrgSingle 1) :: UnionM Integer) - - mrgIf "b" (mrgSingle $ -3) (mrgSingle $ -1) - @?= mrgIf - "a" - (mrgIf (symNot "b") (mrgSingle 1) (mrgSingle 3)) - (mrgIf (symNot "b") (mrgSingle 2) (mrgSingle 4)), - testCase "times" $ - (mrgIf "a" (mrgSingle 1) (mrgSingle 2) :: UnionM Integer) - * mrgIf "b" (mrgSingle 3) (mrgSingle 4) - @?= mrgIf - "a" - (mrgIf "b" (mrgSingle 3) (mrgSingle 4)) - (mrgIf "b" (mrgSingle 6) (mrgSingle 8)), - testCase "abs" $ - abs (mrgIf "a" (mrgSingle $ -1) (mrgSingle 2) :: UnionM Integer) - @?= mrgIf "a" (mrgSingle 1) (mrgSingle 2), - testCase "signum" $ - signum (mrgIf "a" (mrgSingle $ -1) (mrgSingle 2) :: UnionM Integer) - @?= mrgIf "a" (mrgSingle $ -1) (mrgSingle 1) - ], - testGroup - "symIteOp" - [ testCase "symIte" $ - symIte "a" (mrgSingle "b") (mrgSingle "c") - @?= (mrgSingle (symIte "a" "b" "c") :: UnionM SymBool) - ], - let l = mrgIf "a" (mrgSingle False) (mrgSingle True) - r = mrgIf "b" (mrgSingle False) (mrgSingle True) - in testGroup - "LogicalOp" - [ testCase ".||" $ - l - .|| r - @?= ( mrgIf - ("a" .&& "b") - (mrgSingle False) - (mrgSingle True) :: - UnionM Bool - ), - testCase ".&&" $ - l - .&& r - @?= ( mrgIf - ("a" .|| "b") - (mrgSingle False) - (mrgSingle True) :: - UnionM Bool - ), - testCase "symNot" $ - symNot l - @?= mrgIf (symNot "a") (mrgSingle False) (mrgSingle True), - testCase "symXor" $ - l - `symXor` r - @?= ( mrgIf - (symIte "a" "b" (symNot "b")) - (mrgSingle False) - (mrgSingle True) :: - UnionM Bool - ), - testCase "symImplies" $ - l - `symImplies` r - @?= ( mrgIf - (symNot "a" .&& "b") - (mrgSingle False) - (mrgSingle True) :: - UnionM Bool - ) - ], - testCase "PrimWrapper" $ do - con True @?= (mrgSingle $ con True :: UnionM SymBool) - ssym "a" @?= (mrgSingle "a" :: UnionM SymBool) - isym "a" 0 @?= (mrgSingle $ isym "a" 0 :: UnionM SymBool) - conView (mrgSingle $ con True :: UnionM SymBool) @?= Just True - conView (mrgSingle "a" :: UnionM SymBool) @?= Nothing - conView - ( mrgIf - "a" - (mrgSingle $ con False) - (mrgSingle $ con True) :: - UnionM SymBool - ) - @?= Nothing, - testGroup - "Function class" - [ testCase "Applying function in UnionMBase" $ do - let func = - mrgIf "a" (mrgSingle (+ 1)) (mrgSingle (+ 2)) :: - UnionM (Integer -> Integer) - func # (1 :: Integer) @?= mrgIf "a" (mrgSingle 2) (mrgSingle 3), - testCase "Helper for applying on UnionMBase" $ do - let func (x :: Integer) = - mrgIf "a" (mrgSingle $ x + 1) (mrgSingle $ x + 3) - (func .# (mrgIf "b" (mrgSingle 0) (mrgSingle 1) :: UnionM Integer)) - @?= ( mrgIf - "b" - (mrgIf "a" (mrgSingle 1) (mrgSingle 3)) - (mrgIf "a" (mrgSingle 2) (mrgSingle 4)) :: - UnionM Integer - ) - ], - testCase "IsString" $ ("x" :: UnionM B.ByteString) @?= mrgSingle "x", - testGroup - "GenSym" - [ testCase "GenSym with spec" $ do - (genSym (ListSpec 1 3 ()) "a" :: UnionM (UnionM [SymBool])) - @?= mrgSingle - ( mrgIf - (isym "a" 3) - (mrgSingle [isym "a" 2]) - ( mrgIf - (isym "a" 4) - (mrgSingle [isym "a" 1, isym "a" 2]) - (mrgSingle [isym "a" 0, isym "a" 1, isym "a" 2]) - ) - ) - (genSymSimple (ListSpec 1 3 ()) "a" :: UnionM [SymBool]) - @?= mrgIf - (isym "a" 3) - (mrgSingle [isym "a" 2]) - ( mrgIf - (isym "a" 4) - (mrgSingle [isym "a" 1, isym "a" 2]) - (mrgSingle [isym "a" 0, isym "a" 1, isym "a" 2]) - ), - testCase "GenSym with same shape" $ - ( genSym - ( mrgIf - "a" - (mrgSingle ["x"]) - (mrgSingle ["y", "z"]) :: - UnionM [SymBool] - ) - "a" :: - UnionM [SymBool] - ) - @?= mrgIf - (isym "a" 0) - (mrgSingle [isym "a" 1]) - (mrgSingle [isym "a" 2, isym "a" 3]) - ], - testGroup - "Concrete Key HashMaps" - [ testCase "Concrete Key HashMap should work" $ do - mrgIte - "a" - ( ML.fromList - [ (1, mrgSingle $ Just 1), - (2, mrgSingle $ Just 2) - ] :: - ML.HashMap Integer (UnionM (Maybe Integer)) - ) - (ML.fromList [(1, mrgSingle $ Just 2), (3, mrgSingle $ Just 3)]) - @?= ML.fromList - [ (1, mrgIf "a" (mrgSingle $ Just 1) (mrgSingle $ Just 2)), - ( 2, - mrgIf - (symNot "a") - (mrgSingle Nothing) - (mrgSingle $ Just 2) - ), - (3, mrgIf "a" (mrgSingle Nothing) (mrgSingle $ Just 3)) - ] - mrgIf - "a" - ( mrgSingle $ - ML.fromList - [ (1, mrgSingle $ Just 1), - (2, mrgSingle $ Just 2) - ] :: - UnionM (ML.HashMap Integer (UnionM (Maybe Integer))) - ) - ( mrgSingle - ( ML.fromList - [ (1, mrgSingle $ Just 2), - (3, mrgSingle $ Just 3) - ] - ) - ) - @?= mrgSingle - ( ML.fromList - [ (1, mrgIf "a" (mrgSingle $ Just 1) (mrgSingle $ Just 2)), - ( 2, - mrgIf - (symNot "a") - (mrgSingle Nothing) - (mrgSingle $ Just 2) - ), - (3, mrgIf "a" (mrgSingle Nothing) (mrgSingle $ Just 3)) - ] - ) - ], - testCase - "unionSize" - $ do - unionSize (single 1 :: UnionM Integer) @?= 1 - unionSize (mrgIf (ssym "a") (single 1) (single 2) :: UnionM Integer) - @?= 2 - unionSize (choose [1, 2, 3, 4, 5, 6, 7] "a" :: UnionM Integer) @?= 7 +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Use <$>" #-} + +module Grisette.Core.Control.Monad.UnionMTests (unionMTests) where + +import Control.Monad.Except (ExceptT) +import qualified Data.Text as T +import Grisette + ( EvaluateSym (evaluateSym), + ExtractSymbolics (extractSymbolics), + Function ((#)), + GPretty (gpretty), + ITEOp (symIte), + LogicalOp ((.&&)), + Mergeable (rootStrategy), + ModelOps (emptyModel), + ModelRep (buildModel), + ModelValuePair ((::=)), + PlainUnion (ifView, singleView), + SEq ((.==)), + SOrd ((.<=)), + SimpleMergeable (mrgIte), + Solvable (con, conView, isym, ssym), + SubstituteSym (substituteSym), + SymBool, + SymInteger, + SymbolSetRep (buildSymbolSet), + ToCon (toCon), + ToSym (toSym), + TryMerge (tryMergeWithStrategy), + TypedSymbol, + UnionMergeable1 (mrgIfPropagatedStrategy, mrgIfWithStrategy), + mrgIf, + mrgIte1, + mrgSingle, + tryMerge, + ) +import Grisette.Internal.Core.Control.Monad.UnionM + ( UnionM (UAny, UMrg), + isMerged, + liftToMonadUnion, + liftUnionM, + underlyingUnion, + unionMBinOp, + unionMUnaryOp, + unionSize, + ) +import Grisette.Internal.Core.Data.Union (Union (UnionSingle), ifWithLeftMost) +import Grisette.TestUtil.PrettyPrint (compactRenderedAs, renderedAs) +import Grisette.TestUtil.SymbolicAssertion ((.@?=)) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@?=)) + +unionM1 :: UnionM (Either SymBool SymInteger) +unionM1 = mrgIfPropagatedStrategy "u1c" (return $ Left "u1a") (return $ Right "u1b") + +unionM2 :: UnionM (Either SymBool SymInteger) +unionM2 = mrgIfPropagatedStrategy "u2c" (return $ Left "u2a") (return $ Right "u2b") + +unionM12 :: UnionM (Either SymBool SymInteger) +unionM12 = mrgIfPropagatedStrategy "u12c" unionM1 unionM2 + +union12Merged :: Union (Either SymBool SymInteger) +union12Merged = + ifWithLeftMost + True + (symIte "u12c" "u1c" "u2c") + (UnionSingle (Left (symIte "u12c" "u1a" "u2a"))) + (UnionSingle (Right (symIte "u12c" "u1b" "u2b"))) + +unionM12Merged :: UnionM (Either SymBool SymInteger) +unionM12Merged = UMrg rootStrategy union12Merged + +unionMSimple1 :: UnionM SymInteger +unionMSimple1 = mrgIfPropagatedStrategy "u1c" (return "u1a") (return "u1b") + +unionMSimple1Plus1 :: UnionM SymInteger +unionMSimple1Plus1 = + mrgIfPropagatedStrategy + "u1c" + (return $ "u1a" + 1) + (return $ "u1b" + 1) + +unionMSimple2 :: UnionM SymInteger +unionMSimple2 = mrgIfPropagatedStrategy "u2c" (return "u2a") (return "u2b") + +unionMSimple12Merged :: UnionM SymInteger +unionMSimple12Merged = + UMrg + rootStrategy + ( UnionSingle + (symIte "u12c" (symIte "u1c" "u1a" "u1b") (symIte "u2c" "u2a" "u2b")) + ) + +unionMTests :: Test +unionMTests = + testGroup + "UnionM" + [ testCase "underlyingUnion" $ + underlyingUnion unionM12Merged @?= union12Merged, + testCase "isMerged" $ do + isMerged unionM12 @?= False + isMerged unionM12Merged @?= True, + testCase "liftUnionM & liftToMonadUnion" $ do + let expected = + mrgSingle (symIte "u1c" "u1a" "u1b") :: ExceptT () UnionM SymInteger + liftUnionM unionMSimple1 @?= expected + liftToMonadUnion unionMSimple1 @?= expected, + testCase "unionSize" $ + unionSize unionM12Merged @?= 2, + testCase "unaryOp" $ + unionMUnaryOp (+ 1) unionMSimple1 .@?= unionMSimple1Plus1, + testCase "binOp" $ do + let actual = unionMBinOp (+) unionMSimple1 unionMSimple2 + let expected = + mrgSingle (symIte "u1c" "u1a" "u1b" + symIte "u2c" "u2a" "u2b") + actual .@?= expected, + testCase "Mergeable & TryMerge" $ + tryMergeWithStrategy rootStrategy unionM12 @?= unionM12Merged, + testCase "SimpleMerge" $ + mrgIte "u12c" unionM1 unionM2 @?= unionM12Merged, + testCase "UnionMergeable1" $ do + let actual = mrgIfWithStrategy rootStrategy "u12c" unionM1 unionM2 + actual @?= unionM12Merged, + testCase "SimpleMergeable1" $ + mrgIte1 "u12c" unionMSimple1 unionMSimple2 @?= unionMSimple12Merged, + testGroup + "PlainUnion" + [ testGroup + "SingleView" + [ testCase "is single" $ do + let actual = singleView (tryMerge unionMSimple1) + let expected = Just (symIte "u1c" "u1a" "u1b") + actual @?= expected, + testCase "is not single" $ + singleView unionMSimple1 @?= Nothing + ], + testGroup + "IfView" + [ testCase "is single" $ do + let actual = ifView (tryMerge unionMSimple1) + let expected = Nothing + actual @?= expected, + testCase "is not single (unmerged)" $ do + let actual = ifView unionMSimple1 + let expected = Just ("u1c", return "u1a", return "u1b") + actual @?= expected, + testCase "is not single (merged)" $ do + let actual = ifView (tryMerge unionM1) + let expected = + Just ("u1c", mrgSingle $ Left "u1a", mrgSingle $ Right "u1b") + actual @?= expected + ] + ], + testGroup + "Show" + [ testCase "Merged" $ do + let expected = + "{If (ite u12c u1c u2c) (Left (ite u12c u1a u2a)) " + ++ "(Right (ite u12c u1b u2b))}" + show unionM12Merged @?= expected, + testCase "Not merged" $ do + let expected = "" + show unionMSimple1 @?= expected + ], + testGroup + "GPretty" + [ testCase "Merged" $ do + gpretty unionM12Merged + `renderedAs` ( "{If (ite u12c u1c u2c) (Left (ite u12c u1a u2a)) " + <> "(Right (ite u12c u1b u2b))}" + ) + gpretty unionM12Merged + `compactRenderedAs` ( T.intercalate + "\n" + [ "{ If", + " ...", + " ( Left", + " ...", + " )", + " ( Right", + " ...", + " )", + "}" + ] + ), + testCase "Not merged" $ do + gpretty unionM1 `renderedAs` "" + ], + testGroup + "Functor" + [ testCase "fmap should work" $ do + (+ 1) <$> unionMSimple1 @?= unionMSimple1Plus1 + ], + testGroup + "Applicative" + [ testCase "pure should work" $ + (pure 1 :: UnionM Int) @?= UAny (UnionSingle 1), + testCase "<*> should work" $ + pure (+ 1) <*> unionMSimple1 @?= unionMSimple1Plus1 + ], + testGroup + "Monad" + [ testCase "return should work" $ + (return 1 :: UnionM Int) @?= UAny (UnionSingle 1), + testCase ">>= should work" $ + (unionMSimple1 >>= (\i -> return (i + 1))) @?= unionMSimple1Plus1, + testCase ">>= should propagate merge strategy" $ do + let actual = unionMSimple1 >>= (\i -> mrgSingle (i + 1)) + let expected = mrgSingle (symIte "u1c" ("u1a" + 1) ("u1b" + 1)) + actual @?= expected + ], + testCase "SEq" $ do + let actual = unionM1 .== unionM2 + let expected = + (("u1c" :: SymBool) .== "u2c") + .&& ( symIte + "u1c" + (("u1a" :: SymBool) .== "u2a") + (("u1b" :: SymInteger) .== "u2b") + ) + actual .@?= expected, + testCase "SOrd" $ do + let actual = unionM1 .<= unionM2 + let expected = + symIte + (("u1c" :: SymBool) .== "u2c") + ( symIte + "u1c" + (("u1a" :: SymBool) .<= "u2a") + (("u1b" :: SymInteger) .<= "u2b") + ) + "u1c" + actual .@?= expected, + testCase "ToSym a (UnionM b)" $ do + let actual = toSym True :: UnionM SymBool + let expected = mrgSingle (con True) + actual @?= expected, + testCase "ToSym (UnionM a) (UnionM b)" $ do + let actual = toSym (mrgSingle True :: UnionM Bool) :: UnionM SymBool + let expected = mrgSingle (con True) + actual @?= expected, + testCase "ToSym (UnionM Integer) SymInteger" $ do + let actual = toSym (mrgIf "a" 1 2 :: UnionM Integer) + let expected = symIte "a" 1 2 :: SymInteger + actual @?= expected, + testGroup + "ToCon (UnionM a) b" + [ testCase "Const" $ do + let actual = mrgSingle (con True) :: UnionM SymBool + let expected = Just True :: Maybe Bool + toCon actual @?= expected, + testCase "Not const" $ do + let actual = mrgSingle "a" :: UnionM SymBool + let expected = Nothing :: Maybe Bool + toCon actual @?= expected + ], + testGroup + "ToCon (UnionM a) (UnionM b)" + [ testCase "Const" $ do + let actual = mrgSingle (con True) :: UnionM SymBool + let expected = Just (mrgSingle True) :: Maybe (UnionM Bool) + toCon actual @?= expected, + testCase "Not const" $ do + let actual = mrgSingle "a" :: UnionM SymBool + let expected = Nothing :: Maybe (UnionM Bool) + toCon actual @?= expected + ], + testGroup "EvaluateSym" $ do + let model = buildModel ("a" ::= True, "b" ::= False, "c" ::= True) + [ testCase "EmptyModel with no fill default" $ do + let actual = evaluateSym False emptyModel (return "a") + let expected = mrgSingle "a" :: UnionM SymBool + actual @?= expected, + testCase "EmptyModel with filling default" $ do + let actual = evaluateSym True emptyModel (return "a") + let expected = mrgSingle $ con False :: UnionM SymBool + actual @?= expected, + testCase "non-empty model, simple test" $ do + let actual = evaluateSym False model (return "a") + let expected = mrgSingle $ con True :: UnionM SymBool + actual @?= expected, + testCase "non-empty model, complex test" $ do + let actual = + evaluateSym + False + model + ( mrgIf + "d" + (mrgIf "a" (mrgSingle $ Left "b") (mrgSingle $ Right "e")) + (mrgSingle $ Right "f") + ) :: + UnionM (Either SymBool SymBool) + let expected = + mrgIf "d" (mrgSingle $ Left (con False)) (mrgSingle $ Right "f") + actual .@?= expected + ], + testCase "SubstituteSym" $ do + let actual = + substituteSym + ("a" :: TypedSymbol Bool) + "b" + ( mrgIf "a" (return $ Left "a") (return $ Right "c") :: + UnionM (Either SymBool SymBool) + ) + let expected = mrgIf "b" (return $ Left "b") (return $ Right "c") + actual @?= expected, + testCase "ExtractSymbolics" $ do + let actual = extractSymbolics unionM1 + let expected = + buildSymbolSet + ( "u1c" :: TypedSymbol Bool, + "u1a" :: TypedSymbol Bool, + "u1b" :: TypedSymbol Integer + ) + actual @?= expected, + testGroup + "Solvable" + [ testCase "con" $ (con True :: UnionM SymBool) @?= mrgSingle (con True), + testCase "sym" $ (ssym "a" :: UnionM SymBool) @?= mrgSingle (ssym "a"), + testCase "isym" $ + (isym "a" 1 :: UnionM SymBool) @?= mrgSingle (isym "a" 1), + testGroup + "conView" + [ testCase "is concrete" $ do + let value = + mrgIfPropagatedStrategy + "a" + (return $ con True) + (return $ con True) + conView (value :: UnionM SymBool) @?= Just True, + testCase "not concrete" $ + conView (ssym "a" :: UnionM SymBool) @?= Nothing + ] + ], + testCase "Function" $ do + let f = mrgSingle (+ 1) :: UnionM (SymInteger -> SymInteger) + f # 1 @?= 2 ] diff --git a/test/Grisette/Core/Control/Monad/UnionTests.hs b/test/Grisette/Core/Control/Monad/UnionTests.hs --- a/test/Grisette/Core/Control/Monad/UnionTests.hs +++ b/test/Grisette/Core/Control/Monad/UnionTests.hs @@ -8,21 +8,21 @@ module Grisette.Core.Control.Monad.UnionTests (unionTests) where import GHC.Generics (Generic) -import Grisette.Core.Data.Class.ITEOp (ITEOp (symIte)) -import Grisette.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.&&), (.||))) -import Grisette.Core.Data.Class.Mergeable - ( Mergeable (rootStrategy), +import Grisette + ( ITEOp (symIte), + LogicalOp (symNot, (.&&), (.||)), + Mergeable (rootStrategy), MergingStrategy (SortedStrategy), + Solvable (con), + SymInteger, wrapStrategy, ) -import Grisette.Core.Data.Class.Solvable (Solvable (con)) -import Grisette.Core.Data.Union +import Grisette.Internal.Core.Data.Union ( Union (UnionIf, UnionSingle), fullReconstruct, ifWithLeftMost, ifWithStrategy, ) -import Grisette.IR.SymPrim.Data.SymPrim (SymInteger) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit ((@?=)) diff --git a/test/Grisette/Core/Data/BVTests.hs b/test/Grisette/Core/Data/BVTests.hs --- a/test/Grisette/Core/Data/BVTests.hs +++ b/test/Grisette/Core/Data/BVTests.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BinaryLiterals #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -44,20 +45,28 @@ import Data.Typeable (Typeable, typeRep) import Data.Word (Word8) import GHC.Stack (HasCallStack) -import Grisette.Core.Data.BV (IntN (IntN), WordN (unWordN)) -import Grisette.Core.Data.Class.BitVector - ( SizedBV +import Grisette + ( BV (bv), + SizedBV ( sizedBVConcat, sizedBVExt, sizedBVSelect, sizedBVSext, sizedBVZext ), + SomeIntN, + SomeWordN, + pattern SomeIntN, + pattern SomeWordN, ) +import Grisette.Internal.SymPrim.BV + ( IntN (IntN), + WordN (unWordN), + ) import Test.Framework (Test, TestName, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.HUnit (Assertion, assertFailure, (@=?)) +import Test.HUnit (Assertion, assertFailure, (@=?), (@?=)) import Test.QuickCheck (Arbitrary, Property, ioProperty) unaryConform :: forall a b c d. (Show c, Eq c, HasCallStack) => (a -> b) -> (d -> c) -> (a -> c) -> (b -> d) -> a -> Property @@ -326,10 +335,10 @@ testProperty "toInteger" $ unaryConform @ref @typ fromIntegral id toInteger toInteger ] -bvTests :: Test -bvTests = +sizedBVTests :: Test +sizedBVTests = testGroup - "BV" + "sizedBV" [ testGroup "WordN 8 conform to Word8 for Bits instances" [ testProperty "(.&.)" $ \x y -> ioProperty $ wordBinConform (.&.) (.&.) x y, @@ -481,3 +490,34 @@ ioProperty $ shiftL x maxBound @=? 0 ] ] + +someWordNTests :: Test +someWordNTests = + testGroup + "SomeWordN" + [ testGroup + "BV" + [ testGroup + "bv" + [ testCase "bv 12 21" $ + (bv 12 21 :: SomeWordN) @?= SomeWordN (0x015 :: WordN 12) + ] + ] + ] + +someIntNTests :: Test +someIntNTests = + testGroup + "SomeIntN" + [ testGroup + "BV" + [ testGroup + "bv" + [ testCase "bv 12 21" $ + (bv 12 21 :: SomeIntN) @?= SomeIntN (0x015 :: IntN 12) + ] + ] + ] + +bvTests :: Test +bvTests = testGroup "BV" [sizedBVTests, someWordNTests, someIntNTests] diff --git a/test/Grisette/Core/Data/Class/BoolTests.hs b/test/Grisette/Core/Data/Class/BoolTests.hs --- a/test/Grisette/Core/Data/Class/BoolTests.hs +++ b/test/Grisette/Core/Data/Class/BoolTests.hs @@ -1,6 +1,6 @@ module Grisette.Core.Data.Class.BoolTests (boolTests) where -import Grisette.Core.Data.Class.LogicalOp +import Grisette ( LogicalOp (symImplies, symNot, symXor, (.&&), (.||)), ) import Test.Framework (Test, testGroup) diff --git a/test/Grisette/Core/Data/Class/EvaluateSymTests.hs b/test/Grisette/Core/Data/Class/EvaluateSymTests.hs --- a/test/Grisette/Core/Data/Class/EvaluateSymTests.hs +++ b/test/Grisette/Core/Data/Class/EvaluateSymTests.hs @@ -18,20 +18,19 @@ import Data.Int (Int16, Int32, Int64, Int8) import Data.Word (Word16, Word32, Word64, Word8) import GHC.Stack (HasCallStack) -import Grisette (TypedSymbol (IndexedSymbol)) -import Grisette.Core.Data.Class.EvaluateSym (EvaluateSym (evaluateSym)) -import Grisette.Core.Data.Class.ITEOp (ITEOp (symIte)) -import Grisette.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.&&), (.||))) -import Grisette.Core.Data.Class.ModelOps - ( ModelOps (emptyModel), +import Grisette + ( EvaluateSym (evaluateSym), + ITEOp (symIte), + LogicalOp (symNot, (.&&), (.||)), + ModelOps (emptyModel), ModelRep (buildModel), - ) -import Grisette.Core.Data.Class.SEq (SEq ((.==))) -import Grisette.Core.Data.Class.Solvable (Solvable (con, isym, ssym)) -import Grisette.IR.SymPrim.Data.Prim.Model - ( ModelValuePair ((::=)), + ModelValuePair ((::=)), + SEq ((.==)), + Solvable (con, isym, ssym), + SymBool, + Symbol (IndexedSymbol), + TypedSymbol (TypedSymbol), ) -import Grisette.IR.SymPrim.Data.SymPrim (SymBool) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.Framework.Providers.QuickCheck2 (testProperty) @@ -106,7 +105,7 @@ let model = buildModel ( "a" ::= True, - IndexedSymbol "a" 1 ::= False, + TypedSymbol (IndexedSymbol "a" 1) ::= False, "b" ::= False, "c" ::= True ) diff --git a/test/Grisette/Core/Data/Class/ExtractSymbolicsTests.hs b/test/Grisette/Core/Data/Class/ExtractSymbolicsTests.hs --- a/test/Grisette/Core/Data/Class/ExtractSymbolicsTests.hs +++ b/test/Grisette/Core/Data/Class/ExtractSymbolicsTests.hs @@ -23,16 +23,15 @@ import GHC.Generics (Generic) import GHC.Stack (HasCallStack) import Generics.Deriving (Default (Default)) -import Grisette.Core.Data.Class.ExtractSymbolics +import Grisette ( ExtractSymbolics (extractSymbolics), - ) -import Grisette.Core.Data.Class.ITEOp (ITEOp (symIte)) -import Grisette.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.&&), (.||))) -import Grisette.Core.Data.Class.ModelOps - ( SymbolSetOps (emptySet), + ITEOp (symIte), + LogicalOp (symNot, (.&&), (.||)), + SEq ((.==)), + SymBool, + SymbolSetOps (emptySet), SymbolSetRep (buildSymbolSet), ) -import Grisette.Core.Data.Class.SEq (SEq ((.==))) import Grisette.Core.Data.Class.TestValues ( isymBool, isymbolBool, @@ -40,7 +39,6 @@ ssymbolBool, symTrue, ) -import Grisette.IR.SymPrim.Data.SymPrim (SymBool) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.Framework.Providers.QuickCheck2 (testProperty) diff --git a/test/Grisette/Core/Data/Class/GPrettyTests.hs b/test/Grisette/Core/Data/Class/GPrettyTests.hs --- a/test/Grisette/Core/Data/Class/GPrettyTests.hs +++ b/test/Grisette/Core/Data/Class/GPrettyTests.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} module Grisette.Core.Data.Class.GPrettyTests (gprettyTests) where @@ -13,15 +14,15 @@ import GHC.Generics (Generic) import GHC.Stack (HasCallStack) import Generics.Deriving (Default (Default)) -import Grisette.Core.Data.BV - ( IntN, - SomeIntN (SomeIntN), - SomeWordN (SomeWordN), +import Grisette + ( GPretty (gpretty), + IntN, + LogicalOp ((.&&)), + SymBool, WordN, + pattern SomeIntN, + pattern SomeWordN, ) -import Grisette.Core.Data.Class.GPretty (GPretty (gpretty)) -import Grisette.Core.Data.Class.LogicalOp (LogicalOp ((.&&))) -import Grisette.IR.SymPrim.Data.SymPrim (SymBool) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.Framework.Providers.QuickCheck2 (testProperty) diff --git a/test/Grisette/Core/Data/Class/GenSymTests.hs b/test/Grisette/Core/Data/Class/GenSymTests.hs --- a/test/Grisette/Core/Data/Class/GenSymTests.hs +++ b/test/Grisette/Core/Data/Class/GenSymTests.hs @@ -3,36 +3,39 @@ module Grisette.Core.Data.Class.GenSymTests (genSymTests) where +import Control.Monad (replicateM) import Control.Monad.Except (ExceptT (ExceptT)) import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) -import Grisette.Core.Control.Monad.UnionM (UnionM) -import Grisette.Core.Data.Class.GenSym +import qualified Data.Text as T +import Grisette ( EnumGenBound (EnumGenBound), EnumGenUpperBound (EnumGenUpperBound), Fresh, FreshT, GenSymSimple (simpleFresh), + ITEOp (symIte), ListSpec (ListSpec), + MonadFresh (localIdentifier), SimpleListSpec (SimpleListSpec), + SymBool, choose, chooseFresh, chooseSimple, chooseSimpleFresh, chooseUnion, chooseUnionFresh, + freshString, genSym, genSymSimple, liftFresh, + mrgIf, + mrgSingle, runFresh, runFreshT, - ) -import Grisette.Core.Data.Class.ITEOp (ITEOp (symIte)) -import Grisette.Core.Data.Class.SimpleMergeable - ( mrgIf, - mrgSingle, + withInfo, ) import Grisette.Core.Data.Class.TestValues (conBool, isymBool, ssymBool) -import Grisette.IR.SymPrim.Data.SymPrim (SymBool) +import Grisette.Internal.Core.Control.Monad.UnionM (UnionM) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit ((@?=)) @@ -1261,5 +1264,23 @@ (isymBool "a" 2, isymBool "a" 3) ) actual @?= expected - ] + ], + testCase "freshString" $ do + runFresh (replicateM 2 $ freshString "a") "b" @?= ["b@0[a]", "b@1[a]"], + testCase "localIdentifier" $ do + let computation = do + a <- simpleFresh () + (b1, b2) <- localIdentifier (`withInfo` ("b" :: T.Text)) $ do + b1 <- simpleFresh () + b2 <- simpleFresh () + return (b1, b2) + c <- simpleFresh () + return [a, b1, b2, c :: SymBool] + let actual = runFresh computation "c" + actual + @?= [ isymBool "c" 0, + isymBool (withInfo "c" ("b" :: T.Text)) 0, + isymBool (withInfo "c" ("b" :: T.Text)) 1, + isymBool "c" 1 + ] ] diff --git a/test/Grisette/Core/Data/Class/MergeableTests.hs b/test/Grisette/Core/Data/Class/MergeableTests.hs --- a/test/Grisette/Core/Data/Class/MergeableTests.hs +++ b/test/Grisette/Core/Data/Class/MergeableTests.hs @@ -27,23 +27,21 @@ import Data.Int (Int16, Int32, Int64, Int8) import Data.Word (Word16, Word32, Word64, Word8) import GHC.Stack (HasCallStack) -import Grisette.Core.Control.Monad.UnionM (UnionM) -import Grisette.Core.Data.Class.ITEOp (ITEOp (symIte)) -import Grisette.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.&&), (.||))) -import Grisette.Core.Data.Class.Mergeable +import Grisette ( DynamicSortedIdx (DynamicSortedIdx), + ITEOp (symIte), + LogicalOp (symNot, (.&&), (.||)), Mergeable (rootStrategy), MergingStrategy (NoStrategy, SimpleStrategy), + Solvable (con, ssym), StrategyList (StrategyList), + SymBool, + UnionM, buildStrategyList, - resolveStrategy, - ) -import Grisette.Core.Data.Class.SimpleMergeable - ( mrgIf, + mrgIf, mrgSingle, + resolveStrategy, ) -import Grisette.Core.Data.Class.Solvable (Solvable (con, ssym)) -import Grisette.IR.SymPrim.Data.SymPrim (SymBool) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.Framework.Providers.QuickCheck2 (testProperty) diff --git a/test/Grisette/Core/Data/Class/PlainUnionTests.hs b/test/Grisette/Core/Data/Class/PlainUnionTests.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/Core/Data/Class/PlainUnionTests.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Grisette.Core.Data.Class.PlainUnionTests (plainUnionTests) where + +import Grisette + ( ITEOp (symIte), + LogicalOp ((.&&)), + Solvable (con), + SymBool, + UnionM, + UnionMergeable1 (mrgIfPropagatedStrategy), + mrgIf, + mrgSingle, + onUnion, + simpleMerge, + (.#), + pattern If, + pattern Single, + ) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@?=)) + +plainUnionTests :: Test +plainUnionTests = + testGroup + "PlainUnion" + [ testCase "simpleMerge" $ do + simpleMerge + ( mrgIfPropagatedStrategy "a" (return "b") (return "c") :: + UnionM SymBool + ) + @?= symIte "a" "b" "c", + testCase "(.#)" $ do + let symAll = foldl (.&&) (con True) + symAll + .# ( mrgIfPropagatedStrategy + "cond" + (return ["a"]) + (return ["b", "c"]) :: + UnionM [SymBool] + ) + @?= symIte "cond" "a" ("b" .&& "c"), + testCase "onUnion" $ do + let symAll = foldl (.&&) (con True) + let symAllU = onUnion symAll + symAllU + ( mrgIfPropagatedStrategy "cond" (return ["a"]) (return ["b", "c"]) :: + UnionM [SymBool] + ) + @?= symIte "cond" "a" ("b" .&& "c"), + testGroup + "Single and If pattern" + [ testCase "Unmerged" $ + case mrgIfPropagatedStrategy "a" (return "b") (return "c") :: + UnionM SymBool of + Single _ -> fail "Expected If" + If c l r -> do + c @?= "a" + l @?= return "b" + r @?= return "c" + _ -> fail "Should not happen", + testCase "Merged" $ + case mrgIf "a" (return "b") (return "c") :: UnionM SymBool of + If {} -> fail "Expected Single" + Single v -> v @?= symIte "a" "b" "c" + _ -> fail "Should not happen", + testCase "Construct single" $ + (Single "a" :: UnionM SymBool) @?= mrgSingle "a", + testCase "Construct If" $ do + let actual = If "a" (return "b") (return "c") :: UnionM SymBool + let expected = mrgIf "a" (return "b") (return "c") + actual @?= expected + ] + ] diff --git a/test/Grisette/Core/Data/Class/SEqTests.hs b/test/Grisette/Core/Data/Class/SEqTests.hs --- a/test/Grisette/Core/Data/Class/SEqTests.hs +++ b/test/Grisette/Core/Data/Class/SEqTests.hs @@ -23,12 +23,17 @@ import Data.Word (Word16, Word32, Word64, Word8) import GHC.Stack (HasCallStack) import Generics.Deriving (Default (Default), Generic) -import Grisette.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.&&))) -import Grisette.Core.Data.Class.SEq (SEq ((./=), (.==))) -import Grisette.Core.Data.Class.Solvable (Solvable (con)) -import Grisette.Core.Data.Class.TestValues (conBool, ssymBool) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool (pevalEqvTerm) -import Grisette.IR.SymPrim.Data.SymPrim (SymBool (SymBool)) +import Grisette + ( LogicalOp (symNot, (.&&)), + SEq ((./=), (.==)), + Solvable (con), + SymBool (SymBool), + ) +import Grisette.Core.Data.Class.TestValues + ( conBool, + ssymBool, + ) +import Grisette.Internal.SymPrim.Prim.Term (pevalEqTerm) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.Framework.Providers.QuickCheck2 (testProperty) @@ -76,7 +81,7 @@ SymBool termb = ssymBool "b" ssymBool "a" .== ssymBool "b" - @=? SymBool (pevalEqvTerm terma termb) + @=? SymBool (pevalEqTerm terma termb) ], testProperty "Bool" (ioProperty . concreteSEqOkProp @Bool), testProperty "Integer" (ioProperty . concreteSEqOkProp @Integer), diff --git a/test/Grisette/Core/Data/Class/SOrdTests.hs b/test/Grisette/Core/Data/Class/SOrdTests.hs --- a/test/Grisette/Core/Data/Class/SOrdTests.hs +++ b/test/Grisette/Core/Data/Class/SOrdTests.hs @@ -21,19 +21,26 @@ import Data.Int (Int16, Int32, Int64, Int8) import Data.Word (Word16, Word32, Word64, Word8) import GHC.Stack (HasCallStack) -import Grisette.Core.Control.Monad.UnionM (UnionM) -import Grisette.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.&&), (.||))) -import Grisette.Core.Data.Class.SEq (SEq ((.==))) -import Grisette.Core.Data.Class.SOrd - ( SOrd (symCompare, (.<), (.<=), (.>), (.>=)), - ) -import Grisette.Core.Data.Class.SimpleMergeable - ( mrgIf, +import Grisette + ( ITEOp (symIte), + LogicalOp (symNot, (.&&), (.||)), + SEq ((.==)), + SOrd (symCompare, (.<), (.<=), (.>), (.>=)), + UnionM, + mrgIf, + mrgMax, + mrgMin, mrgSingle, + symMax, + symMin, ) -import Grisette.Core.Data.Class.TestValues (conBool, ssymBool) -import Grisette.IR.SymPrim.Data.SymPrim (SymBool) +import Grisette.Core.Data.Class.TestValues + ( conBool, + ssymBool, + ) import Grisette.Lib.Control.Monad (mrgReturn) +import Grisette.SymPrim (SymBool, SymInteger) +import Grisette.TestUtil.SymbolicAssertion ((.@?=)) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.Framework.Providers.QuickCheck2 (testProperty) @@ -1379,5 +1386,23 @@ traverse_ concreteOrdOkProp [(x, y) | x <- bytestrings, y <- bytestrings] - ] + ], + testCase "symMax" $ do + symMax (1 :: SymInteger) 2 @?= 2 + let [a, b] = ["a", "b"] :: [SymInteger] + symMax a b .@?= symIte (a .>= b) a b, + testCase "symMin" $ do + symMin (1 :: SymInteger) 2 @?= 1 + let [a, b] = ["a", "b"] :: [SymInteger] + symMin a b .@?= symIte (a .>= b) b a, + testCase "mrgMax" $ do + mrgMax [1] [0, 3] @?= (mrgReturn [1] :: UnionM [SymInteger]) + let [a, b, c] = ["a", "b", "c"] :: [SymInteger] + (mrgMax [a] [b, c] :: UnionM [SymInteger]) + .@?= (mrgIf (a .<= b) (return [b, c]) (return [a])), + testCase "mrgMin" $ do + mrgMin [1] [0, 3] @?= (mrgReturn [0, 3] :: UnionM [SymInteger]) + let [a, b, c] = ["a", "b", "c"] :: [SymInteger] + (mrgMin [a] [b, c] :: UnionM [SymInteger]) + .@?= (mrgIf (b .< a) (return [b, c]) (return [a])) ] diff --git a/test/Grisette/Core/Data/Class/SafeDivisionTests.hs b/test/Grisette/Core/Data/Class/SafeDivisionTests.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/Core/Data/Class/SafeDivisionTests.hs @@ -0,0 +1,278 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Grisette.Core.Data.Class.SafeDivisionTests (safeDivisionTests) where + +import Control.DeepSeq (NFData, force) +import Control.Exception (ArithException, catch) +import Control.Monad.Except (ExceptT, runExceptT) +import Data.Bifunctor (Bifunctor (bimap)) +import Data.Data (Typeable, typeRep) +import Data.Proxy (Proxy (Proxy)) +import GHC.IO (evaluate) +import GHC.Int (Int16, Int32, Int64, Int8) +import GHC.Word (Word16, Word32, Word64, Word8) +import Grisette + ( BV (bv), + BitwidthMismatch (BitwidthMismatch), + IntN, + Mergeable, + SafeDivision (safeDiv, safeDivMod, safeMod, safeQuot, safeQuotRem, safeRem), + SomeIntN, + SomeWordN, + UnionM, + WordN, + mrgPure, + pattern SomeIntN, + pattern SomeWordN, + ) +import Grisette.Internal.Core.Control.Monad.UnionM (isMerged) +import Grisette.Lib.Control.Monad.Except (mrgThrowError) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.HUnit (assertBool, (@?=)) +import Test.QuickCheck (Arbitrary, ioProperty) + +matches :: + (NFData r, Eq r', Show r', Mergeable r', Mergeable e, Eq e, Show e) => + (t -> t') -> + (r -> r') -> + (ArithException -> e) -> + (t' -> t' -> ExceptT e UnionM r') -> + (t -> t -> r) -> + t -> + t -> + IO () +matches wrapInput wrapOutput wrapError f fref x y = do + rref <- + (mrgPure . wrapOutput <$> evaluate (force (fref x y))) + `catch` \(e :: ArithException) -> return $ mrgThrowError $ wrapError e + let r = f (wrapInput x) (wrapInput y) + assertBool "Is merged" $ isMerged $ runExceptT r + r @?= rref + +generalOpTestBase :: + ( NFData r, + Arbitrary t, + Show t, + Eq r', + Show r', + Eq r, + Num t, + Mergeable r', + Mergeable e, + Show e, + Eq e + ) => + (t -> t') -> + (r -> r') -> + (ArithException -> e) -> + String -> + (t' -> t' -> ExceptT e UnionM r') -> + (t -> t -> r) -> + Test +generalOpTestBase wrapInput wrapOutput wrapError name f fref = + testGroup + name + [ testProperty "random" $ \x y -> + ioProperty $ matches wrapInput wrapOutput wrapError f fref x y, + testCase "divided by zero" $ + matches wrapInput wrapOutput wrapError f fref 1 0 + ] + +generalOpTest :: + (NFData r, Arbitrary t, Show t, Eq r, Show r, Eq r, Num t, Mergeable r) => + String -> + (t -> t -> ExceptT ArithException UnionM r) -> + (t -> t -> r) -> + Test +generalOpTest = generalOpTestBase id id id + +opBoundedTestBase :: + ( NFData r, + Arbitrary t, + Show t, + Show r', + Eq r', + Num t, + Bounded t, + Mergeable r', + Mergeable e, + Show e, + Eq e + ) => + (t -> t') -> + (r -> r') -> + (ArithException -> e) -> + String -> + (t' -> t' -> ExceptT e UnionM r') -> + (t -> t -> r) -> + Test +opBoundedTestBase wrapInput wrapOutput wrapError name f fref = + testGroup + name + [ testProperty "random" $ \x y -> + ioProperty $ matches wrapInput wrapOutput wrapError f fref x y, + testCase "divided by zero" $ + matches wrapInput wrapOutput wrapError f fref 1 0, + testCase "minBound/-1" $ + matches wrapInput wrapOutput wrapError f fref minBound (-1) + ] + +opBoundedTest :: + ( NFData r, + Arbitrary t, + Show t, + Show r, + Eq r, + Num t, + Bounded t, + Mergeable r + ) => + String -> + (t -> t -> ExceptT ArithException UnionM r) -> + (t -> t -> r) -> + Test +opBoundedTest = opBoundedTestBase id id id + +type OpTestFunc t = + forall r. + (Eq r, Show r, Eq r, NFData r, Mergeable r) => + String -> + (t -> t -> ExceptT ArithException UnionM r) -> + (t -> t -> r) -> + Test + +testType :: + forall t. + ( NFData t, + Show t, + SafeDivision ArithException t (ExceptT ArithException UnionM), + Mergeable t, + Integral t, + Typeable t + ) => + OpTestFunc t -> + Proxy t -> + Test +testType testFunc p = + testGroup + (show $ typeRep p) + [ testFunc "div" safeDiv (div @t), + testFunc "mod" safeMod (mod @t), + testFunc "divMod" safeDivMod (divMod @t), + testFunc "quot" safeQuot (quot @t), + testFunc "rem" safeRem (rem @t), + testFunc "quotRem" safeQuotRem (quotRem @t) + ] + +-- type SomeOpTestFunc t t' = +-- forall r r'. +-- (Eq r, Show r, Eq r, NFData r, Mergeable r) => +-- String -> +-- (t' -> t' -> ExceptT ArithException UnionM r') -> +-- (t -> t -> r) -> +-- Test +-- +-- testSomeType :: +-- forall t t'. +-- ( NFData t, +-- Show t, +-- SafeDivision ArithException t' (ExceptT ArithException UnionM), +-- Mergeable t, +-- Integral t, +-- Typeable t' +-- ) => +-- SomeDivTestFunc t t' -> +-- SomeDivTestFunc t t' -> +-- Proxy t -> +-- Proxy t' -> +-- Test +-- testSomeType divQuotTest modRemTest _ p = +-- testGroup +-- (show $ typeRep p) +-- [ divQuotTest "div" safeDiv (div @t), +-- modRemTest "mod" safeMod (mod @t), +-- divQuotTest "divMod" safeDivMod (divMod @t), +-- divQuotTest "quot" safeQuot (quot @t), +-- modRemTest "rem" safeRem (rem @t), +-- modRemTest "quotRem" safeQuotRem (quotRem @t) +-- ] + +safeDivisionTests :: Test +safeDivisionTests = + testGroup + "SafeDivision" + [ testType generalOpTest (Proxy :: Proxy Integer), + testType opBoundedTest (Proxy :: Proxy Int8), + testType opBoundedTest (Proxy :: Proxy Int16), + testType opBoundedTest (Proxy :: Proxy Int32), + testType opBoundedTest (Proxy :: Proxy Int64), + testType opBoundedTest (Proxy :: Proxy Int), + testType opBoundedTest (Proxy :: Proxy (IntN 8)), + testType opBoundedTest (Proxy :: Proxy Word), + testType opBoundedTest (Proxy :: Proxy Word8), + testType opBoundedTest (Proxy :: Proxy Word16), + testType opBoundedTest (Proxy :: Proxy Word32), + testType opBoundedTest (Proxy :: Proxy Word64), + testType opBoundedTest (Proxy :: Proxy (WordN 8)), + testGroup "SomeWordN" $ do + let singleOutputTest = + opBoundedTestBase + SomeWordN + SomeWordN + (\e -> Right e :: Either BitwidthMismatch ArithException) + let doubleOutputTest = + opBoundedTestBase + SomeWordN + (bimap SomeWordN SomeWordN) + (\e -> Right e :: Either BitwidthMismatch ArithException) + [ singleOutputTest "div" safeDiv (div @(WordN 8)), + singleOutputTest "mod" safeMod (mod @(WordN 8)), + doubleOutputTest "divMod" safeDivMod (divMod @(WordN 8)), + singleOutputTest "quot" safeQuot (quot @(WordN 8)), + singleOutputTest "rem" safeRem (rem @(WordN 8)), + doubleOutputTest "quotRem" safeQuotRem (quotRem @(WordN 8)), + testCase "Bitwidth mismatch" $ do + let actual = + safeDiv (bv 10 2) (bv 11 3) :: + ExceptT + (Either BitwidthMismatch ArithException) + UnionM + SomeWordN + let expected = mrgThrowError $ Left BitwidthMismatch + actual @?= expected + ], + testGroup "SomeIntN" $ do + let singleOutputTest = + opBoundedTestBase + SomeIntN + SomeIntN + (\e -> Right e :: Either BitwidthMismatch ArithException) + let doubleOutputTest = + opBoundedTestBase + SomeIntN + (bimap SomeIntN SomeIntN) + (\e -> Right e :: Either BitwidthMismatch ArithException) + [ singleOutputTest "div" safeDiv (div @(IntN 8)), + singleOutputTest "mod" safeMod (mod @(IntN 8)), + doubleOutputTest "divMod" safeDivMod (divMod @(IntN 8)), + singleOutputTest "quot" safeQuot (quot @(IntN 8)), + singleOutputTest "rem" safeRem (rem @(IntN 8)), + doubleOutputTest "quotRem" safeQuotRem (quotRem @(IntN 8)), + testCase "Bitwidth mismatch" $ do + let actual = + safeDiv (bv 10 2) (bv 11 3) :: + ExceptT + (Either BitwidthMismatch ArithException) + UnionM + SomeIntN + let expected = mrgThrowError $ Left BitwidthMismatch + actual @?= expected + ] + ] diff --git a/test/Grisette/Core/Data/Class/SafeLinearArithTests.hs b/test/Grisette/Core/Data/Class/SafeLinearArithTests.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/Core/Data/Class/SafeLinearArithTests.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Grisette.Core.Data.Class.SafeLinearArithTests + ( safeLinearArithTests, + ) +where + +import Control.Exception (ArithException (Overflow, Underflow)) +import Control.Monad.Except (ExceptT, MonadError) +import Data.Data (Proxy (Proxy), Typeable, typeRep) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Word (Word16, Word32, Word64, Word8) +import Grisette + ( BV (bv), + BitwidthMismatch (BitwidthMismatch), + IntN, + Mergeable, + SafeLinearArith (safeAdd, safeNeg, safeSub), + SomeIntN, + SomeWordN, + TryMerge, + UnionM, + WordN, + mrgSingle, + pattern SomeIntN, + pattern SomeWordN, + ) +import Grisette.Lib.Control.Monad.Except (mrgModifyError, mrgThrowError) +import Grisette.Lib.Data.Functor (mrgFmap) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.HUnit ((@?=)) +import Test.QuickCheck (Arbitrary, ioProperty) + +binSafeOp :: + forall a m. + ( Integral a, + Bounded a, + MonadError ArithException m, + TryMerge m, + Mergeable a + ) => + (Integer -> Integer -> Integer) -> + a -> + a -> + m a +binSafeOp op l r + | result > fromIntegral (maxBound :: a) = + mrgThrowError Overflow + | result < fromIntegral (minBound :: a) = + mrgThrowError Underflow + | otherwise = mrgSingle $ fromIntegral result + where + result = op (fromIntegral l) (fromIntegral r) + +unarySafeOp :: + forall a m. + ( Integral a, + Bounded a, + MonadError ArithException m, + TryMerge m, + Mergeable a + ) => + (Integer -> Integer) -> + a -> + m a +unarySafeOp op l + | result > fromIntegral (maxBound :: a) = + mrgThrowError Overflow + | result < fromIntegral (minBound :: a) = + mrgThrowError Underflow + | otherwise = mrgSingle $ fromIntegral result + where + result = op (fromIntegral l) + +safeLinearArithTest :: + forall a b e. + ( SafeLinearArith e b (ExceptT e UnionM), + Integral a, + Bounded a, + Arbitrary a, + Show a, + Show b, + Eq b, + Eq e, + Show e, + Typeable a, + Mergeable a, + Mergeable e + ) => + (a -> b) -> + (ArithException -> e) -> + Test +safeLinearArithTest wrap transformError = + testGroup + (show $ typeRep (Proxy @a)) + [ testProperty "safeAdd" $ \(l :: a) (r :: a) -> ioProperty $ do + let actual = safeAdd (wrap l) (wrap r) + let expected = mrgModifyError transformError $ binSafeOp (+) l r + actual @?= (mrgFmap wrap expected :: ExceptT e UnionM b), + testProperty "safeSub" $ \(l :: a) (r :: a) -> ioProperty $ do + let actual = safeSub (wrap l) (wrap r) + let expected = mrgModifyError transformError $ binSafeOp (-) l r + actual @?= (mrgFmap wrap expected :: ExceptT e UnionM b), + testProperty "safeNeg" $ \(l :: a) -> ioProperty $ do + let actual = safeNeg (wrap l) :: ExceptT e UnionM b + let expected = mrgModifyError transformError $ unarySafeOp negate l + actual @?= mrgFmap wrap expected + ] + +safeLinearArithTestSimple :: + forall a. + ( SafeLinearArith ArithException a (ExceptT ArithException UnionM), + Integral a, + Bounded a, + Arbitrary a, + Show a, + Show a, + Typeable a + ) => + Test +safeLinearArithTestSimple = safeLinearArithTest @a @a id id + +safeLinearArithTests :: Test +safeLinearArithTests = + testGroup + "SafeLinearArith" + [ safeLinearArithTestSimple @Int, + safeLinearArithTestSimple @Int8, + safeLinearArithTestSimple @Int16, + safeLinearArithTestSimple @Int32, + safeLinearArithTestSimple @Int64, + safeLinearArithTestSimple @(IntN 1), + safeLinearArithTestSimple @(IntN 2), + safeLinearArithTestSimple @(IntN 3), + safeLinearArithTestSimple @(IntN 128), + safeLinearArithTest @(IntN 2) + @SomeIntN + @(Either BitwidthMismatch ArithException) + SomeIntN + Right, + safeLinearArithTest @(IntN 128) + @SomeIntN + @(Either BitwidthMismatch ArithException) + SomeIntN + Right, + testCase "SomeIntN different bit width" $ do + let l = bv 2 1 :: SomeIntN + let r = bv 3 1 :: SomeIntN + let actual = + safeAdd l r :: + ExceptT (Either BitwidthMismatch ArithException) UnionM SomeIntN + let expected = mrgThrowError $ Left BitwidthMismatch + actual @?= expected, + safeLinearArithTestSimple @Word, + safeLinearArithTestSimple @Word8, + safeLinearArithTestSimple @Word16, + safeLinearArithTestSimple @Word32, + safeLinearArithTestSimple @Word64, + safeLinearArithTestSimple @(WordN 1), + safeLinearArithTestSimple @(WordN 2), + safeLinearArithTestSimple @(WordN 3), + safeLinearArithTestSimple @(WordN 128), + safeLinearArithTest @(WordN 2) + @SomeWordN + @(Either BitwidthMismatch ArithException) + SomeWordN + Right, + safeLinearArithTest @(WordN 128) + @SomeWordN + @(Either BitwidthMismatch ArithException) + SomeWordN + Right, + testCase "SomeWordN different bit width" $ do + let l = bv 2 1 :: SomeWordN + let r = bv 3 1 :: SomeWordN + let actual = + safeAdd l r :: + ExceptT + (Either BitwidthMismatch ArithException) + UnionM + SomeWordN + let expected = mrgThrowError $ Left BitwidthMismatch + actual @?= expected + ] diff --git a/test/Grisette/Core/Data/Class/SafeSymRotateTests.hs b/test/Grisette/Core/Data/Class/SafeSymRotateTests.hs --- a/test/Grisette/Core/Data/Class/SafeSymRotateTests.hs +++ b/test/Grisette/Core/Data/Class/SafeSymRotateTests.hs @@ -15,15 +15,17 @@ import Data.Int (Int16, Int32, Int64, Int8) import Data.Typeable (Proxy (Proxy), Typeable) import Data.Word (Word16, Word32, Word64, Word8) -import Grisette.Core.Control.Monad.UnionM (UnionM) -import Grisette.Core.Data.BV (IntN, WordN) -import Grisette.Core.Data.Class.Mergeable (Mergeable) -import Grisette.Core.Data.Class.SafeSymRotate - ( SafeSymRotate (safeSymRotateL, safeSymRotateR), +import Grisette + ( IntN, + Mergeable, + SafeSymRotate (safeSymRotateL, safeSymRotateR), + Solvable (con), + SymIntN, + SymWordN, + UnionM, + WordN, ) -import Grisette.Core.Data.Class.Solvable (Solvable (con)) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term (LinkedRep) -import Grisette.IR.SymPrim.Data.SymPrim (SymIntN, SymWordN) +import Grisette.Internal.SymPrim.Prim.Term (LinkedRep) import Grisette.Lib.Control.Monad (mrgReturn) import Grisette.Lib.Control.Monad.Except (mrgThrowError) import Test.Framework (Test, testGroup) @@ -34,7 +36,7 @@ import Test.QuickCheck.Gen (chooseInt) import Test.QuickCheck.Property (forAll) -type EM a = ExceptT ArithException UnionM a +type EM = ExceptT ArithException UnionM overflowError :: (Mergeable a) => EM a overflowError = mrgThrowError Overflow @@ -45,7 +47,7 @@ Show a, Num a, Eq a, - SafeSymRotate ArithException a, + SafeSymRotate ArithException a EM, FiniteBits a, Bounded a, Typeable a, @@ -75,7 +77,7 @@ Show a, Num a, Eq a, - SafeSymRotate ArithException a, + SafeSymRotate ArithException a EM, FiniteBits a, Bounded a, Typeable a, @@ -101,7 +103,7 @@ Show s, Num s, Eq s, - SafeSymRotate ArithException s, + SafeSymRotate ArithException s EM, FiniteBits c, FiniteBits s, Bounded c, @@ -134,7 +136,7 @@ Show s, Num s, Eq s, - SafeSymRotate ArithException s, + SafeSymRotate ArithException s EM, FiniteBits c, FiniteBits s, Bounded c, diff --git a/test/Grisette/Core/Data/Class/SafeSymShiftTests.hs b/test/Grisette/Core/Data/Class/SafeSymShiftTests.hs --- a/test/Grisette/Core/Data/Class/SafeSymShiftTests.hs +++ b/test/Grisette/Core/Data/Class/SafeSymShiftTests.hs @@ -12,20 +12,22 @@ import Data.Int (Int16, Int32, Int64, Int8) import Data.Typeable (Proxy (Proxy), Typeable) import Data.Word (Word16, Word32, Word64, Word8) -import Grisette.Core.Control.Monad.UnionM (UnionM) -import Grisette.Core.Data.BV (IntN, WordN) -import Grisette.Core.Data.Class.Mergeable (Mergeable) -import Grisette.Core.Data.Class.SafeSymShift - ( SafeSymShift +import Grisette + ( IntN, + Mergeable, + SafeSymShift ( safeSymShiftL, safeSymShiftR, safeSymStrictShiftL, safeSymStrictShiftR ), + Solvable (con), + SymIntN, + SymWordN, + UnionM, + WordN, ) -import Grisette.Core.Data.Class.Solvable (Solvable (con)) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term (LinkedRep) -import Grisette.IR.SymPrim.Data.SymPrim (SymIntN, SymWordN) +import Grisette.Internal.SymPrim.Prim.Term (LinkedRep) import Grisette.Lib.Control.Monad (mrgReturn) import Grisette.Lib.Control.Monad.Except (mrgThrowError) import Test.Framework (Test, testGroup) @@ -36,7 +38,7 @@ import Test.QuickCheck.Gen (chooseInt) import Test.QuickCheck.Property (forAll) -type EM a = ExceptT ArithException UnionM a +type EM = ExceptT ArithException UnionM overflowError :: (Mergeable a) => EM a overflowError = mrgThrowError Overflow @@ -47,7 +49,7 @@ Show a, Num a, Eq a, - SafeSymShift ArithException a, + SafeSymShift ArithException a EM, FiniteBits a, Bounded a, Typeable a, @@ -90,7 +92,7 @@ Show a, Num a, Eq a, - SafeSymShift ArithException a, + SafeSymShift ArithException a EM, FiniteBits a, Bounded a, Typeable a, @@ -118,7 +120,7 @@ Show s, Num s, Eq s, - SafeSymShift ArithException s, + SafeSymShift ArithException s EM, FiniteBits c, FiniteBits s, Bounded c, @@ -164,7 +166,7 @@ Show s, Num s, Eq s, - SafeSymShift ArithException s, + SafeSymShift ArithException s EM, FiniteBits c, FiniteBits s, Bounded c, diff --git a/test/Grisette/Core/Data/Class/SimpleMergeableTests.hs b/test/Grisette/Core/Data/Class/SimpleMergeableTests.hs --- a/test/Grisette/Core/Data/Class/SimpleMergeableTests.hs +++ b/test/Grisette/Core/Data/Class/SimpleMergeableTests.hs @@ -26,21 +26,18 @@ import qualified Data.Monoid as Monoid import GHC.Generics (Generic) import Generics.Deriving (Default (Default)) -import Grisette.Core.Control.Monad.UnionM (UnionM, (.#)) -import Grisette.Core.Data.Class.ITEOp (ITEOp (symIte)) -import Grisette.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.&&), (.||))) -import Grisette.Core.Data.Class.Mergeable (Mergeable) -import Grisette.Core.Data.Class.SimpleMergeable - ( SimpleMergeable (mrgIte), - UnionLike (unionIf), +import Grisette + ( ITEOp (symIte), + LogicalOp (symNot, (.&&), (.||)), + Mergeable, + SimpleMergeable (mrgIte), + SymBool, + UnionM, mrgIf, mrgIte1, mrgSingle, - onUnion, - simpleMerge, ) import Grisette.Core.Data.Class.TestValues (conBool, ssymBool) -import Grisette.IR.SymPrim.Data.SymPrim (SymBool) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit ((@?=)) @@ -652,27 +649,5 @@ @?= mrgSingle (symIte (ssymBool "c") (ssymBool "a") (ssymBool "b")) runIdentityT i3u1 @?= mrgSingle (symIte (ssymBool "c") (ssymBool "a") (ssymBool "b")) - ], - testGroup - "Combinators" - [ testCase "simpleMerge" $ do - simpleMerge - (unionIf "a" (return "b") (return "c") :: UnionM SymBool) - @?= symIte (ssymBool "a") (ssymBool "b") (ssymBool "c"), - testCase "onUnion" $ do - let symAll = foldl (.&&) (conBool True) - let symAllU = onUnion symAll - symAllU - ( unionIf "cond" (return ["a"]) (return ["b", "c"]) :: - UnionM [SymBool] - ) - @?= symIte "cond" "a" ("b" .&& "c"), - testCase "(.#)" $ do - let symAll = foldl (.&&) (conBool True) - symAll - .# ( unionIf "cond" (return ["a"]) (return ["b", "c"]) :: - UnionM [SymBool] - ) - @?= symIte "cond" "a" ("b" .&& "c") ] ] diff --git a/test/Grisette/Core/Data/Class/SubstituteSymTests.hs b/test/Grisette/Core/Data/Class/SubstituteSymTests.hs --- a/test/Grisette/Core/Data/Class/SubstituteSymTests.hs +++ b/test/Grisette/Core/Data/Class/SubstituteSymTests.hs @@ -19,10 +19,8 @@ import Data.Int (Int16, Int32, Int64, Int8) import Data.Word (Word16, Word32, Word64, Word8) import GHC.Stack (HasCallStack) -import Grisette.Core.Data.Class.LogicalOp (LogicalOp ((.||))) -import Grisette.Core.Data.Class.SubstituteSym (SubstituteSym (substituteSym)) +import Grisette (LogicalOp ((.||)), SubstituteSym (substituteSym), SymBool) import Grisette.Core.Data.Class.TestValues (ssymBool, ssymbolBool) -import Grisette.IR.SymPrim.Data.SymPrim (SymBool) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.Framework.Providers.QuickCheck2 (testProperty) diff --git a/test/Grisette/Core/Data/Class/SymRotateTests.hs b/test/Grisette/Core/Data/Class/SymRotateTests.hs --- a/test/Grisette/Core/Data/Class/SymRotateTests.hs +++ b/test/Grisette/Core/Data/Class/SymRotateTests.hs @@ -7,10 +7,15 @@ import Data.Data (Proxy (Proxy), Typeable, typeRep) import Data.Int (Int16, Int32, Int64, Int8) import Data.Word (Word16, Word32, Word64, Word8) -import Grisette (IntN, LinkedRep, Solvable, SymIntN, SymWordN) -import Grisette.Core.Data.BV (WordN) -import Grisette.Core.Data.Class.Solvable (Solvable (con)) -import Grisette.Core.Data.Class.SymRotate (SymRotate (symRotate)) +import Grisette + ( IntN, + LinkedRep, + Solvable (con), + SymIntN, + SymRotate (symRotate, symRotateNegated), + SymWordN, + WordN, + ) import Test.Framework (Test, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.HUnit (Assertion, (@?=)) @@ -29,6 +34,19 @@ (fromIntegral s :: Integer) `mod` fromIntegral (finiteBitSize a) ) +concreteRotateNegatedIsCorrect :: + (SymRotate a, Show a, Integral a, FiniteBits a) => + a -> + a -> + Assertion +concreteRotateNegatedIsCorrect a s = + symRotateNegated a s + @?= rotate + a + ( fromIntegral $ + (-fromIntegral s :: Integer) `mod` fromIntegral (finiteBitSize a) + ) + concreteUnsignedTypeSymRotateTests :: forall proxy a. ( Arbitrary a, @@ -52,8 +70,14 @@ forAll (chooseInt (0, finiteBitSize x)) $ \(s :: Int) -> ioProperty $ concreteRotateIsCorrect x (fromIntegral s), + testProperty "symRotateNegated" $ \(x :: a) -> + forAll (chooseInt (0, finiteBitSize x)) $ + \(s :: Int) -> + ioProperty $ concreteRotateNegatedIsCorrect x (fromIntegral s), testProperty "symRotate max" $ \(x :: a) -> - ioProperty $ concreteRotateIsCorrect x maxBound + ioProperty $ concreteRotateIsCorrect x maxBound, + testProperty "symRotateNegated max" $ \(x :: a) -> + ioProperty $ concreteRotateNegatedIsCorrect x maxBound ] ] @@ -80,10 +104,18 @@ forAll (chooseInt (-finiteBitSize x, finiteBitSize x)) $ \(s :: Int) -> ioProperty $ concreteRotateIsCorrect x (fromIntegral s), + testProperty "symRotateNegated" $ \(x :: a) -> + forAll (chooseInt (-finiteBitSize x, finiteBitSize x)) $ + \(s :: Int) -> + ioProperty $ concreteRotateNegatedIsCorrect x (fromIntegral s), testProperty "symRotate max" $ \(x :: a) -> ioProperty $ concreteRotateIsCorrect x maxBound, + testProperty "symRotateNegated max" $ \(x :: a) -> + ioProperty $ concreteRotateNegatedIsCorrect x maxBound, testProperty "symRotate min" $ \(x :: a) -> - ioProperty $ concreteRotateIsCorrect x minBound + ioProperty $ concreteRotateIsCorrect x minBound, + testProperty "symRotateNegated min" $ \(x :: a) -> + ioProperty $ concreteRotateNegatedIsCorrect x minBound ] ] @@ -138,6 +170,7 @@ concreteUnsignedTypeSymRotateTests (Proxy :: Proxy Word), concreteUnsignedTypeSymRotateTests (Proxy :: Proxy (WordN 1)), concreteUnsignedTypeSymRotateTests (Proxy :: Proxy (WordN 2)), + concreteUnsignedTypeSymRotateTests (Proxy :: Proxy (WordN 3)), concreteUnsignedTypeSymRotateTests (Proxy :: Proxy (WordN 63)), concreteUnsignedTypeSymRotateTests (Proxy :: Proxy (WordN 64)), concreteUnsignedTypeSymRotateTests (Proxy :: Proxy (WordN 65)), @@ -149,18 +182,21 @@ concreteSignedTypeSymRotateTests (Proxy :: Proxy Int), concreteSignedTypeSymRotateTests (Proxy :: Proxy (IntN 1)), concreteSignedTypeSymRotateTests (Proxy :: Proxy (IntN 2)), + concreteSignedTypeSymRotateTests (Proxy :: Proxy (IntN 3)), concreteSignedTypeSymRotateTests (Proxy :: Proxy (IntN 63)), concreteSignedTypeSymRotateTests (Proxy :: Proxy (IntN 64)), concreteSignedTypeSymRotateTests (Proxy :: Proxy (IntN 65)), concreteSignedTypeSymRotateTests (Proxy :: Proxy (IntN 128)), symbolicTypeSymRotateTests (Proxy :: Proxy (SymWordN 1)), symbolicTypeSymRotateTests (Proxy :: Proxy (SymWordN 2)), + symbolicTypeSymRotateTests (Proxy :: Proxy (SymWordN 3)), symbolicTypeSymRotateTests (Proxy :: Proxy (SymWordN 63)), symbolicTypeSymRotateTests (Proxy :: Proxy (SymWordN 64)), symbolicTypeSymRotateTests (Proxy :: Proxy (SymWordN 65)), symbolicTypeSymRotateTests (Proxy :: Proxy (SymWordN 128)), symbolicTypeSymRotateTests (Proxy :: Proxy (SymIntN 1)), symbolicTypeSymRotateTests (Proxy :: Proxy (SymIntN 2)), + symbolicTypeSymRotateTests (Proxy :: Proxy (SymIntN 3)), symbolicTypeSymRotateTests (Proxy :: Proxy (SymIntN 63)), symbolicTypeSymRotateTests (Proxy :: Proxy (SymIntN 64)), symbolicTypeSymRotateTests (Proxy :: Proxy (SymIntN 65)), diff --git a/test/Grisette/Core/Data/Class/SymShiftTests.hs b/test/Grisette/Core/Data/Class/SymShiftTests.hs --- a/test/Grisette/Core/Data/Class/SymShiftTests.hs +++ b/test/Grisette/Core/Data/Class/SymShiftTests.hs @@ -7,10 +7,15 @@ import Data.Data (Proxy (Proxy), Typeable, typeRep) import Data.Int (Int16, Int32, Int64, Int8) import Data.Word (Word16, Word32, Word64, Word8) -import Grisette (IntN, LinkedRep, Solvable, SymIntN, SymWordN) -import Grisette.Core.Data.BV (WordN) -import Grisette.Core.Data.Class.Solvable (Solvable (con)) -import Grisette.Core.Data.Class.SymShift (SymShift (symShift)) +import Grisette + ( IntN, + LinkedRep, + Solvable (con), + SymIntN, + SymShift (symShift, symShiftNegated), + SymWordN, + WordN, + ) import Test.Framework (Test, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.HUnit ((@?=)) @@ -40,8 +45,15 @@ \(s :: Int) -> ioProperty $ symShift x (fromIntegral s) @?= shift x s, + testProperty "symShiftNegated" $ \(x :: a) -> + forAll (chooseInt (0, finiteBitSize x)) $ + \(s :: Int) -> + ioProperty $ + symShiftNegated x (fromIntegral s) @?= shift x (-s), testProperty "symShift max" $ \(x :: a) -> - ioProperty $ symShift x maxBound @?= 0 + ioProperty $ symShift x maxBound @?= 0, + testProperty "symShiftNegated max" $ \(x :: a) -> + ioProperty $ symShiftNegated x maxBound @?= 0 ] ] @@ -69,21 +81,31 @@ \(s :: Int) -> ioProperty $ do symShift x (fromIntegral s) @?= shift x (fromIntegral (fromIntegral s :: a)), + testProperty "symShiftNegated" $ \(x :: a) -> + forAll (chooseInt (-finiteBitSize x, finiteBitSize x)) $ + \(s :: Int) -> ioProperty $ do + symShiftNegated x (fromIntegral s) + @?= shift x (-fromIntegral (fromIntegral s :: a)), testProperty "symShift max" $ \(x :: a) -> ioProperty $ do case finiteBitSize x of 1 -> symShift x maxBound @?= x 2 -> symShift x maxBound @?= shift x 1 _ -> symShift x maxBound @?= 0, + testProperty "symShiftNegated max" $ \(x :: a) -> + ioProperty $ do + case finiteBitSize x of + 1 -> symShiftNegated x maxBound @?= x + 2 -> symShiftNegated x maxBound @?= shift x (-1) + _ -> symShiftNegated x maxBound @?= if x >= 0 then 0 else -1, testProperty "symShift min" $ \(x :: a) -> ioProperty $ do case finiteBitSize x of - 1 -> - symShift x minBound @?= shift x (-1) - 2 -> - symShift x minBound @?= shift x (-2) - _ -> - symShift x minBound @?= if x >= 0 then 0 else -1 + 1 -> symShift x minBound @?= shift x (-1) + 2 -> symShift x minBound @?= shift x (-2) + _ -> symShift x minBound @?= if x >= 0 then 0 else -1, + testProperty "symShiftNegated min" $ \(x :: a) -> + ioProperty $ symShiftNegated x minBound @?= 0 ] ] @@ -116,14 +138,28 @@ ioProperty $ symShift (con x :: s) (fromIntegral s) @?= con (symShift x (fromIntegral s)), + testProperty "concrete/concrete symShiftNegated" $ \(x :: c) -> + forAll (chooseInt (-finiteBitSize x, finiteBitSize x)) $ + \(s :: Int) -> + ioProperty $ + symShiftNegated (con x :: s) (fromIntegral s) + @?= con (symShiftNegated x (fromIntegral s)), testProperty "symShift max" $ \(x :: c) -> ioProperty $ symShift (con x :: s) (con maxBound) @?= con (symShift x maxBound), + testProperty "symShiftNegated max" $ \(x :: c) -> + ioProperty $ + symShiftNegated (con x :: s) (con maxBound) + @?= con (symShiftNegated x maxBound), testProperty "symShift min" $ \(x :: c) -> ioProperty $ do symShift (con x :: s) (con minBound) - @?= con (symShift x minBound) + @?= con (symShift x minBound), + testProperty "symShiftNegated min" $ \(x :: c) -> + ioProperty $ do + symShiftNegated (con x :: s) (con minBound) + @?= con (symShiftNegated x minBound) ] ] @@ -138,6 +174,7 @@ concreteUnsignedTypeSymShiftTests (Proxy :: Proxy Word), concreteUnsignedTypeSymShiftTests (Proxy :: Proxy (WordN 1)), concreteUnsignedTypeSymShiftTests (Proxy :: Proxy (WordN 2)), + concreteUnsignedTypeSymShiftTests (Proxy :: Proxy (WordN 3)), concreteUnsignedTypeSymShiftTests (Proxy :: Proxy (WordN 63)), concreteUnsignedTypeSymShiftTests (Proxy :: Proxy (WordN 64)), concreteUnsignedTypeSymShiftTests (Proxy :: Proxy (WordN 65)), @@ -149,18 +186,21 @@ concreteSignedTypeSymShiftTests (Proxy :: Proxy Int), concreteSignedTypeSymShiftTests (Proxy :: Proxy (IntN 1)), concreteSignedTypeSymShiftTests (Proxy :: Proxy (IntN 2)), + concreteSignedTypeSymShiftTests (Proxy :: Proxy (IntN 3)), concreteSignedTypeSymShiftTests (Proxy :: Proxy (IntN 63)), concreteSignedTypeSymShiftTests (Proxy :: Proxy (IntN 64)), concreteSignedTypeSymShiftTests (Proxy :: Proxy (IntN 65)), concreteSignedTypeSymShiftTests (Proxy :: Proxy (IntN 128)), symbolicTypeSymShiftTests (Proxy :: Proxy (SymWordN 1)), symbolicTypeSymShiftTests (Proxy :: Proxy (SymWordN 2)), + symbolicTypeSymShiftTests (Proxy :: Proxy (SymWordN 3)), symbolicTypeSymShiftTests (Proxy :: Proxy (SymWordN 63)), symbolicTypeSymShiftTests (Proxy :: Proxy (SymWordN 64)), symbolicTypeSymShiftTests (Proxy :: Proxy (SymWordN 65)), symbolicTypeSymShiftTests (Proxy :: Proxy (SymWordN 128)), symbolicTypeSymShiftTests (Proxy :: Proxy (SymIntN 1)), symbolicTypeSymShiftTests (Proxy :: Proxy (SymIntN 2)), + symbolicTypeSymShiftTests (Proxy :: Proxy (SymIntN 3)), symbolicTypeSymShiftTests (Proxy :: Proxy (SymIntN 63)), symbolicTypeSymShiftTests (Proxy :: Proxy (SymIntN 64)), symbolicTypeSymShiftTests (Proxy :: Proxy (SymIntN 65)), diff --git a/test/Grisette/Core/Data/Class/TestValues.hs b/test/Grisette/Core/Data/Class/TestValues.hs --- a/test/Grisette/Core/Data/Class/TestValues.hs +++ b/test/Grisette/Core/Data/Class/TestValues.hs @@ -9,13 +9,13 @@ ) where -import qualified Data.Text as T import Grisette - ( Solvable (isym), - TypedSymbol (IndexedSymbol, SimpleSymbol), + ( Identifier, + Solvable (con, isym, ssym), + SymBool, + Symbol (IndexedSymbol, SimpleSymbol), + TypedSymbol (TypedSymbol), ) -import Grisette.Core.Data.Class.Solvable (Solvable (con, ssym)) -import Grisette.IR.SymPrim.Data.SymPrim (SymBool) conBool :: Bool -> SymBool conBool = con @@ -26,14 +26,14 @@ symFalse :: SymBool symFalse = conBool False -ssymBool :: T.Text -> SymBool +ssymBool :: Identifier -> SymBool ssymBool = ssym -isymBool :: T.Text -> Int -> SymBool +isymBool :: Identifier -> Int -> SymBool isymBool = isym -ssymbolBool :: T.Text -> TypedSymbol Bool -ssymbolBool = SimpleSymbol +ssymbolBool :: Identifier -> TypedSymbol Bool +ssymbolBool = TypedSymbol . SimpleSymbol -isymbolBool :: T.Text -> Int -> TypedSymbol Bool -isymbolBool = IndexedSymbol +isymbolBool :: Identifier -> Int -> TypedSymbol Bool +isymbolBool i idx = TypedSymbol $ IndexedSymbol i idx diff --git a/test/Grisette/Core/Data/Class/ToConTests.hs b/test/Grisette/Core/Data/Class/ToConTests.hs --- a/test/Grisette/Core/Data/Class/ToConTests.hs +++ b/test/Grisette/Core/Data/Class/ToConTests.hs @@ -18,9 +18,13 @@ import Data.Int (Int16, Int32, Int64, Int8) import Data.Word (Word16, Word32, Word64, Word8) import GHC.Stack (HasCallStack) -import Grisette.Core.Data.Class.ITEOp (ITEOp (symIte)) -import Grisette.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.&&), (.||))) -import Grisette.Core.Data.Class.SEq (SEq ((.==))) +import Grisette + ( ITEOp (symIte), + LogicalOp (symNot, (.&&), (.||)), + SEq ((.==)), + SymBool, + ToCon (toCon), + ) import Grisette.Core.Data.Class.TestValues ( conBool, isymBool, @@ -28,8 +32,6 @@ symFalse, symTrue, ) -import Grisette.Core.Data.Class.ToCon (ToCon (toCon)) -import Grisette.IR.SymPrim.Data.SymPrim (SymBool) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.Framework.Providers.QuickCheck2 (testProperty) diff --git a/test/Grisette/Core/Data/Class/ToSymTests.hs b/test/Grisette/Core/Data/Class/ToSymTests.hs --- a/test/Grisette/Core/Data/Class/ToSymTests.hs +++ b/test/Grisette/Core/Data/Class/ToSymTests.hs @@ -21,12 +21,14 @@ import Data.Int (Int16, Int32, Int64, Int8) import Data.Word (Word16, Word32, Word64, Word8) import GHC.Stack (HasCallStack) -import Grisette.Core.Data.Class.ITEOp (ITEOp (symIte)) -import Grisette.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.&&), (.||))) -import Grisette.Core.Data.Class.SEq (SEq ((.==))) -import Grisette.Core.Data.Class.Solvable (Solvable (con, isym, ssym)) -import Grisette.Core.Data.Class.ToSym (ToSym (toSym)) -import Grisette.IR.SymPrim.Data.SymPrim (SymBool) +import Grisette + ( ITEOp (symIte), + LogicalOp (symNot, (.&&), (.||)), + SEq ((.==)), + Solvable (con, isym, ssym), + SymBool, + ToSym (toSym), + ) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.Framework.Providers.QuickCheck2 (testProperty) diff --git a/test/Grisette/Core/Data/Class/TryMergeTests.hs b/test/Grisette/Core/Data/Class/TryMergeTests.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/Core/Data/Class/TryMergeTests.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} + +module Grisette.Core.Data.Class.TryMergeTests (tryMergeTests) where + +import Control.Monad.Cont (ContT (ContT, runContT)) +import Control.Monad.Except (ExceptT (ExceptT)) +import Control.Monad.Identity (IdentityT (IdentityT)) +import qualified Control.Monad.RWS.Lazy as RWSTLazy +import qualified Control.Monad.RWS.Strict as RWSTStrict +import Control.Monad.Reader (ReaderT (ReaderT, runReaderT)) +import qualified Control.Monad.State.Lazy as StateLazy +import qualified Control.Monad.State.Strict as StateStrict +import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import Grisette + ( ITEOp (symIte), + Mergeable (rootStrategy), + TryMerge, + UnionMergeable1 (mrgIfPropagatedStrategy), + mrgSingle, + tryMerge, + ) +import Grisette.Internal.Core.Control.Monad.UnionM (UnionM (UMrg)) +import Grisette.Internal.Core.Data.Union (Union (UnionSingle)) +import Grisette.Internal.SymPrim.SymInteger (SymInteger) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@?=)) + +data TryMergeInstanceTest where + TryMergeInstanceTest :: + forall u a. + (TryMerge u, Mergeable a, Show (u a), Eq (u a)) => + { testName :: String, + testUnmerged :: u a, + testMerged :: u a + } -> + TryMergeInstanceTest + +unmergedUnion :: UnionM SymInteger +unmergedUnion = + mrgIfPropagatedStrategy + "a" + (return "b") + (return "c") + +tryMergeTests :: Test +tryMergeTests = + testGroup + "TryMerge" + [ testCase "mrgSingle" $ do + let actual = mrgSingle 1 :: UnionM Integer + actual @?= (UMrg rootStrategy (UnionSingle 1)), + testCase "mrgSingle" $ do + let actual = mrgSingle 1 :: UnionM Integer + actual @?= (UMrg rootStrategy (UnionSingle 1)), + testCase "tryMerge" $ do + let actual = tryMerge $ return 1 :: UnionM Integer + actual @?= (UMrg rootStrategy (UnionSingle 1)), + testGroup "Instances" $ do + test <- + [ TryMergeInstanceTest + { testName = "MaybeT", + testUnmerged = MaybeT $ Just <$> unmergedUnion, + testMerged = MaybeT (mrgSingle $ Just $ symIte "a" "b" "c") + }, + TryMergeInstanceTest + { testName = "ExceptT", + testUnmerged = + ExceptT $ Right <$> unmergedUnion :: + ExceptT SymInteger UnionM SymInteger, + testMerged = ExceptT (mrgSingle $ Right $ symIte "a" "b" "c") + }, + TryMergeInstanceTest + { testName = "ReaderT", + testUnmerged = + runReaderT (ReaderT $ \r -> (r +) <$> unmergedUnion) "x", + testMerged = mrgSingle (symIte "a" ("x" + "b") ("x" + "c")) + }, + TryMergeInstanceTest + { testName = "Lazy StateT", + testUnmerged = + StateLazy.runStateT + (StateLazy.StateT $ \s -> (,s) <$> unmergedUnion) + "x" :: + UnionM (SymInteger, SymInteger), + testMerged = mrgSingle (symIte "a" "b" "c", "x") + }, + TryMergeInstanceTest + { testName = "Strict StateT", + testUnmerged = + StateStrict.runStateT + (StateStrict.StateT $ \s -> (,s) <$> unmergedUnion) + "x" :: + UnionM (SymInteger, SymInteger), + testMerged = mrgSingle (symIte "a" "b" "c", "x") + }, + TryMergeInstanceTest + { testName = "Lazy WriterT", + testUnmerged = + WriterLazy.runWriterT + ( WriterLazy.WriterT $ + (\x -> (x, x + 1)) <$> unmergedUnion + ) :: + UnionM (SymInteger, SymInteger), + testMerged = + mrgSingle (symIte "a" "b" "c", symIte "a" ("b" + 1) ("c" + 1)) + }, + TryMergeInstanceTest + { testName = "Strict WriterT", + testUnmerged = + WriterStrict.runWriterT + ( WriterStrict.WriterT $ + (\x -> (x, x + 1)) <$> unmergedUnion + ) :: + UnionM (SymInteger, SymInteger), + testMerged = + mrgSingle (symIte "a" "b" "c", symIte "a" ("b" + 1) ("c" + 1)) + }, + TryMergeInstanceTest + { testName = "Lazy RWST", + testUnmerged = + RWSTLazy.runRWST + ( RWSTLazy.RWST $ + \r s -> (,s,r) <$> unmergedUnion + ) + "r" + "s" :: + UnionM (SymInteger, SymInteger, SymInteger), + testMerged = mrgSingle (symIte "a" "b" "c", "s", "r") + }, + TryMergeInstanceTest + { testName = "Strict RWST", + testUnmerged = + RWSTStrict.runRWST + ( RWSTStrict.RWST $ + \r s -> (,s,r) <$> unmergedUnion + ) + "r" + "s" :: + UnionM (SymInteger, SymInteger, SymInteger), + testMerged = mrgSingle (symIte "a" "b" "c", "s", "r") + }, + TryMergeInstanceTest + { testName = "IdentityT", + testUnmerged = IdentityT unmergedUnion, + testMerged = IdentityT $ mrgSingle $ symIte "a" "b" "c" + }, + TryMergeInstanceTest + { testName = "ContT", + testUnmerged = + runContT + (ContT $ \c -> unmergedUnion >>= c) + (\x -> mrgSingle $ x + 1), + testMerged = mrgSingle $ symIte "a" ("b" + 1) ("c" + 1) + } + ] + case test of + TryMergeInstanceTest name unmerged merged -> + [ testCase name $ do + let actual = tryMerge unmerged + actual @?= merged + ] + ] diff --git a/test/Grisette/Core/Data/Class/UnionLikeTests.hs b/test/Grisette/Core/Data/Class/UnionLikeTests.hs deleted file mode 100644 --- a/test/Grisette/Core/Data/Class/UnionLikeTests.hs +++ /dev/null @@ -1,298 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Grisette.Core.Data.Class.UnionLikeTests (unionLikeTests) where - -import Control.Monad.Except (ExceptT (ExceptT)) -import Control.Monad.Identity (IdentityT (IdentityT, runIdentityT)) -import Control.Monad.Reader (ReaderT (ReaderT, runReaderT)) -import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) -import qualified Control.Monad.Trans.State.Lazy as StateLazy -import qualified Control.Monad.Trans.State.Strict as StateStrict -import qualified Control.Monad.Trans.Writer.Lazy as WriterLazy -import qualified Control.Monad.Trans.Writer.Strict as WriterStrict -import Grisette.Core.Control.Monad.UnionM (UnionM) -import Grisette.Core.Data.Class.ITEOp (ITEOp (symIte)) -import Grisette.Core.Data.Class.LogicalOp (LogicalOp (symNot)) -import Grisette.Core.Data.Class.SimpleMergeable - ( UnionLike (single, unionIf), - merge, - mrgIf, - mrgSingle, - simpleMerge, - ) -import Grisette.Core.Data.Class.Solvable (Solvable (ssym)) -import Grisette.IR.SymPrim.Data.SymPrim (SymBool) -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit ((@?=)) - -unionLikeTests :: Test -unionLikeTests = - testGroup - "UnionLike" - [ testCase "simpleMerge" $ - simpleMerge - ( unionIf - (ssym "a") - (single $ ssym "b") - (single $ ssym "c") :: - UnionM SymBool - ) - @?= symIte (ssym "a") (ssym "b") (ssym "c"), - testGroup - "UnionLike" - [ testGroup - "MaybeT" - [ testCase "merge" $ do - merge - ( MaybeT - ( unionIf - (ssym "a") - (single $ Just $ ssym "b") - (single $ Just $ ssym "c") :: - UnionM (Maybe SymBool) - ) - ) - @?= MaybeT - (mrgSingle $ Just $ symIte (ssym "a") (ssym "b") (ssym "c")), - testCase "mrgSingle" $ do - (mrgSingle 1 :: MaybeT UnionM Integer) - @?= MaybeT (mrgSingle $ Just 1), - testCase "mrgIf" $ - do - mrgIf (ssym "a") (mrgSingle $ ssym "b") (mrgSingle $ ssym "c") - @?= MaybeT - ( mrgSingle $ - Just $ - symIte (ssym "a") (ssym "b") (ssym "c") :: - UnionM (Maybe SymBool) - ) - ], - testGroup - "ExceptT" - [ testCase "merge" $ do - merge - ( ExceptT - ( unionIf - (ssym "a") - (single $ Left $ ssym "b") - (single $ Left $ ssym "c") :: - UnionM (Either SymBool SymBool) - ) - ) - @?= ExceptT - (mrgSingle $ Left $ symIte (ssym "a") (ssym "b") (ssym "c")), - testCase "mrgSingle" $ do - (mrgSingle 1 :: ExceptT SymBool UnionM Integer) - @?= ExceptT (mrgSingle $ Right 1), - testCase "mrgIf" $ - do - mrgIf (ssym "a") (mrgSingle $ ssym "b") (mrgSingle $ ssym "c") - @?= ExceptT - ( mrgSingle $ - Right $ - symIte (ssym "a") (ssym "b") (ssym "c") :: - UnionM (Either SymBool SymBool) - ) - ], - testGroup - "StateT" - [ testGroup - "Lazy" - [ testCase "merge" $ do - let s :: StateLazy.StateT SymBool UnionM SymBool = - merge $ StateLazy.StateT $ \(x :: SymBool) -> - unionIf - (ssym "a") - (single (x, symNot x)) - (single (symNot x, x)) - StateLazy.runStateT s (ssym "b") - @?= mrgSingle - ( symIte (ssym "a") (ssym "b") (symNot $ ssym "b"), - symIte (ssym "a") (symNot $ ssym "b") (ssym "b") - ), - testCase "mrgSingle" $ do - let s :: StateLazy.StateT SymBool UnionM SymBool = - mrgSingle (ssym "x") - StateLazy.runStateT s (ssym "b") - @?= mrgSingle (ssym "x", ssym "b"), - testCase "mrgIf" $ do - let s :: StateLazy.StateT SymBool UnionM SymBool = - mrgIf - (ssym "a") - ( StateLazy.StateT $ \(x :: SymBool) -> - single (x, symNot x) - ) - ( StateLazy.StateT $ \(x :: SymBool) -> - single (symNot x, x) - ) - StateLazy.runStateT s (ssym "b") - @?= mrgSingle - ( symIte (ssym "a") (ssym "b") (symNot $ ssym "b"), - symIte (ssym "a") (symNot $ ssym "b") (ssym "b") - ) - ], - testGroup - "Strict" - [ testCase "merge" $ do - let s :: StateStrict.StateT SymBool UnionM SymBool = - merge $ StateStrict.StateT $ \(x :: SymBool) -> - unionIf - (ssym "a") - (single (x, symNot x)) - (single (symNot x, x)) - StateStrict.runStateT s (ssym "b") - @?= mrgSingle - ( symIte (ssym "a") (ssym "b") (symNot $ ssym "b"), - symIte (ssym "a") (symNot $ ssym "b") (ssym "b") - ), - testCase "mrgSingle" $ do - let s :: StateStrict.StateT SymBool UnionM SymBool = - mrgSingle (ssym "x") - StateStrict.runStateT s (ssym "b") - @?= mrgSingle (ssym "x", ssym "b"), - testCase "mrgIf" $ do - let s :: StateStrict.StateT SymBool UnionM SymBool = - mrgIf - (ssym "a") - ( StateStrict.StateT $ \(x :: SymBool) -> - single (x, symNot x) - ) - ( StateStrict.StateT $ \(x :: SymBool) -> - single (symNot x, x) - ) - StateStrict.runStateT s (ssym "b") - @?= mrgSingle - ( symIte (ssym "a") (ssym "b") (symNot $ ssym "b"), - symIte (ssym "a") (symNot $ ssym "b") (ssym "b") - ) - ] - ], - testGroup - "WriterT" - [ testGroup - "Lazy" - [ testCase "merge" $ do - let s :: WriterLazy.WriterT [SymBool] UnionM SymBool = - merge $ - WriterLazy.WriterT $ - unionIf - (ssym "a") - (single (ssym "b", [ssym "c"])) - (single (ssym "d", [ssym "e"])) - WriterLazy.runWriterT s - @?= mrgSingle - ( symIte (ssym "a") (ssym "b") (ssym "d"), - [symIte (ssym "a") (ssym "c") (ssym "e")] - ), - testCase "mrgSingle" $ do - let s :: WriterLazy.WriterT [SymBool] UnionM SymBool = - mrgSingle (ssym "x") - WriterLazy.runWriterT s @?= mrgSingle (ssym "x", []), - testCase "mrgIf" $ do - let s :: WriterLazy.WriterT [SymBool] UnionM SymBool = - mrgIf - (ssym "a") - (WriterLazy.WriterT $ single (ssym "b", [ssym "c"])) - (WriterLazy.WriterT $ single (ssym "d", [ssym "e"])) - WriterLazy.runWriterT s - @?= mrgSingle - ( symIte (ssym "a") (ssym "b") (ssym "d"), - [symIte (ssym "a") (ssym "c") (ssym "e")] - ) - ], - testGroup - "Strict" - [ testCase "merge" $ do - let s :: WriterStrict.WriterT [SymBool] UnionM SymBool = - merge $ - WriterStrict.WriterT $ - unionIf - (ssym "a") - (single (ssym "b", [ssym "c"])) - (single (ssym "d", [ssym "e"])) - WriterStrict.runWriterT s - @?= mrgSingle - ( symIte (ssym "a") (ssym "b") (ssym "d"), - [symIte (ssym "a") (ssym "c") (ssym "e")] - ), - testCase "mrgSingle" $ do - let s :: WriterStrict.WriterT [SymBool] UnionM SymBool = - mrgSingle (ssym "x") - WriterStrict.runWriterT s @?= mrgSingle (ssym "x", []), - testCase "mrgIf" $ do - let s :: WriterStrict.WriterT [SymBool] UnionM SymBool = - mrgIf - (ssym "a") - ( WriterStrict.WriterT $ - single (ssym "b", [ssym "c"]) - ) - ( WriterStrict.WriterT $ - single (ssym "d", [ssym "e"]) - ) - WriterStrict.runWriterT s - @?= mrgSingle - ( symIte (ssym "a") (ssym "b") (ssym "d"), - [symIte (ssym "a") (ssym "c") (ssym "e")] - ) - ] - ], - testGroup - "ReaderT" - [ testCase "merge" $ - do - let s :: ReaderT SymBool UnionM SymBool = - merge $ ReaderT $ \(x :: SymBool) -> - unionIf (ssym "a") (single x) (single $ symNot x) - runReaderT s (ssym "b") - @?= mrgSingle - (symIte (ssym "a") (ssym "b") (symNot $ ssym "b")), - testCase - "mrgSingle" - $ do - let s :: ReaderT SymBool UnionM SymBool = mrgSingle (ssym "x") - runReaderT s (ssym "b") @?= mrgSingle (ssym "x"), - testCase - "mrgIf" - $ do - let s :: ReaderT SymBool UnionM SymBool = - mrgIf - (ssym "a") - (ReaderT $ \(x :: SymBool) -> single x) - (ReaderT $ \(x :: SymBool) -> single $ symNot x) - runReaderT s (ssym "b") - @?= mrgSingle - (symIte (ssym "a") (ssym "b") (symNot $ ssym "b")) - ], - testGroup - "IdentityT" - [ testCase "merge" $ - do - let s :: IdentityT UnionM SymBool = - merge $ - IdentityT $ - unionIf - (ssym "a") - (single $ ssym "b") - (single $ ssym "c") - runIdentityT s - @?= mrgSingle (symIte (ssym "a") (ssym "b") (ssym "c")), - testCase - "mrgSingle" - $ do - let s :: IdentityT UnionM SymBool = mrgSingle (ssym "x") - runIdentityT s @?= mrgSingle (ssym "x"), - testCase - "mrgIf" - $ do - let s :: IdentityT UnionM SymBool = - mrgIf - (ssym "a") - (IdentityT $ single (ssym "b")) - (IdentityT $ single (ssym "c")) - runIdentityT s - @?= mrgSingle (symIte (ssym "a") (ssym "b") (ssym "c")) - ] - ] - ] diff --git a/test/Grisette/Core/Data/SomeBVTests.hs b/test/Grisette/Core/Data/SomeBVTests.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/Core/Data/SomeBVTests.hs @@ -0,0 +1,382 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Grisette.Core.Data.SomeBVTests (someBVTests) where + +import Control.DeepSeq (NFData, force) +import Control.Exception (ArithException (Overflow), catch, evaluate) +import Control.Monad.Except (ExceptT) +import Data.Bits (FiniteBits (finiteBitSize)) +import Data.Proxy (Proxy (Proxy)) +import Grisette + ( BV (bv, bvConcat, bvExt, bvSelect, bvSext, bvZext), + ITEOp (symIte), + LogicalOp (symNot), + Mergeable (rootStrategy), + SafeLinearArith (safeAdd, safeSub), + Solvable (isym, ssym), + genSym, + genSymSimple, + mrgIf, + mrgSingle, + ) +import Grisette.Internal.Core.Control.Monad.UnionM (UnionM (UMrg)) +import Grisette.Internal.Core.Data.Union (Union (UnionSingle), ifWithLeftMost) +import Grisette.Internal.SymPrim.BV (BitwidthMismatch (BitwidthMismatch), IntN) +import Grisette.Internal.SymPrim.SomeBV + ( SomeBV (SomeBV), + SomeIntN, + SomeSymIntN, + SomeWordN, + arbitraryBV, + binSomeBV, + binSomeBVR1, + binSomeBVR2, + binSomeBVSafe, + binSomeBVSafeR1, + conBV, + conBVView, + isymBV, + ssymBV, + unarySomeBV, + unarySomeBVR1, + pattern ConBV, + pattern SomeIntN, + ) +import Grisette.Internal.SymPrim.SymBV (SymIntN) +import Grisette.Lib.Control.Monad.Except (mrgThrowError) +import Grisette.Lib.Data.Functor (mrgFmap) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.HUnit ((@?=)) +import Test.QuickCheck (forAll, ioProperty) + +testFuncMatch :: + (Eq r, Show r) => + (SomeIntN -> SomeIntN -> r) -> + SomeIntN -> + SomeIntN -> + r -> + Test +testFuncMatch f a b r = testCase "bit width match" $ do + let actual = f a b + let expected = r + actual @?= expected + +testFuncMisMatch :: + (NFData r, Show r, Eq r) => + (SomeIntN -> SomeIntN -> r) -> + SomeIntN -> + SomeIntN -> + r -> + Test +testFuncMisMatch f a b r = testCase "bit width mismatch" $ do + actual <- + evaluate (force $ f a b) + `catch` \(_ :: BitwidthMismatch) -> return r + let expected = r + actual @?= expected + +testSafeFuncMatchException :: + (Eq r, Show r, Mergeable r) => + ( SomeIntN -> + SomeIntN -> + ExceptT (Either BitwidthMismatch ArithException) UnionM r + ) -> + SomeIntN -> + SomeIntN -> + ArithException -> + Test +testSafeFuncMatchException f a b e = testCase "bit width match" $ do + let actual = f a b + let expected = mrgThrowError (Right e) + actual @?= expected + +testSafeFuncMatch :: + (Eq r, Show r, Mergeable r) => + ( SomeIntN -> + SomeIntN -> + ExceptT (Either BitwidthMismatch ArithException) UnionM r + ) -> + SomeIntN -> + SomeIntN -> + r -> + Test +testSafeFuncMatch f a b r = testCase "bit width match" $ do + let actual = f a b + let expected = mrgSingle r + actual @?= expected + +testSafeFuncMisMatch :: + (Eq r, Show r, Mergeable r) => + ( SomeIntN -> + SomeIntN -> + ExceptT (Either BitwidthMismatch ArithException) UnionM r + ) -> + SomeIntN -> + SomeIntN -> + Test +testSafeFuncMisMatch f a b = testCase "bit width mismatch" $ do + let actual = f a b + let expected = mrgThrowError (Left BitwidthMismatch) + actual @?= expected + +someBVTests :: Test +someBVTests = + testGroup + "SomeBV" + [ testGroup + "Helpers" + [ testCase "conBV" $ do + let actual = conBV (bv 4 5) + let expected = bv 4 5 :: SomeSymIntN + actual @?= expected, + testGroup + "conBVView" + [ testCase "is concrete" $ do + let value = bv 4 5 :: SomeSymIntN + let actual = conBVView value + let expected = Just (bv 4 5) + actual @?= expected + case value of + ConBV v -> v @?= bv 4 5 + _ -> fail "is concrete", + testCase "is not concrete" $ do + let value = ssymBV 4 "a" :: SomeSymIntN + let actual = conBVView value + let expected = Nothing + actual @?= expected + case value of + ConBV _ -> fail "is not concrete" + _ -> return () + ], + testCase "ssymBV" $ ssymBV 4 "a" @?= SomeBV (ssym "a" :: SymIntN 4), + testCase "isymBV" $ + isymBV 4 "a" 1 @?= SomeBV (isym "a" 1 :: SymIntN 4), + testCase "unarySomeBV" $ do + let actual = + unarySomeBV @IntN @SomeIntN + (SomeIntN . negate) + (bv 4 5 :: SomeIntN) + let expected = bv 4 (-5) + actual @?= expected, + testCase "unarySomeBVR1" $ do + let actual = unarySomeBVR1 (negate) (bv 4 5 :: SomeIntN) + let expected = bv 4 (-5) + actual @?= expected, + testGroup + "binSomeBV" + [ testFuncMatch @SomeIntN + (binSomeBV (\l r -> SomeIntN $ l + r)) + (bv 4 5) + (bv 4 2) + (bv 4 7), + testFuncMisMatch @SomeIntN + (binSomeBV (\l r -> SomeIntN $ l + r)) + (bv 4 5) + (bv 5 4) + (bv 3 0) + ], + testGroup + "binSomeBVR1" + [ testFuncMatch (binSomeBVR1 (+)) (bv 4 5) (bv 4 2) (bv 4 7), + testFuncMisMatch (binSomeBVR1 (+)) (bv 4 5) (bv 5 4) (bv 3 0) + ], + testGroup + "binSomeBVR2" + [ testFuncMatch + (binSomeBVR2 (\l r -> (l + r, l - r))) + (bv 4 5) + (bv 4 2) + (bv 4 7, bv 4 3), + testFuncMisMatch + (binSomeBVR2 (\l r -> (l + r, l - r))) + (bv 4 5) + (bv 5 4) + (bv 3 0, bv 6 1) + ], + testGroup "binSomeBVSafe" $ do + let func l r = mrgFmap SomeIntN $ safeAdd l r + [ testSafeFuncMatch @SomeIntN + (binSomeBVSafe func) + (bv 4 5) + (bv 4 2) + (bv 4 7), + testSafeFuncMatchException @SomeIntN + (binSomeBVSafe func) + (bv 4 5) + (bv 4 5) + Overflow, + testSafeFuncMisMatch @SomeIntN + (binSomeBVSafe func) + (bv 4 5) + (bv 5 4) + ], + testGroup + "binSomeBVSafeR1" + [ testSafeFuncMatch + (binSomeBVSafeR1 safeAdd) + (bv 4 5) + (bv 4 2) + (bv 4 7), + testSafeFuncMatchException + (binSomeBVSafeR1 safeAdd) + (bv 4 5) + (bv 4 5) + Overflow, + testSafeFuncMisMatch (binSomeBVSafeR1 safeAdd) (bv 4 5) (bv 5 4) + ], + testGroup "binSomeBVSafeR2" $ do + let func l r = do + a <- safeAdd l r + b <- safeSub l r + mrgSingle (a, b) + [ testSafeFuncMatch + func + (bv 4 5) + (bv 4 2) + (bv 4 7, bv 4 3), + testSafeFuncMatchException + func + (bv 4 5) + (bv 4 5) + Overflow, + testSafeFuncMisMatch func (bv 4 5) (bv 5 4) + ] + ], + testGroup + "BV" + [ testCase "bvConcat" $ do + bvConcat (bv 8 0x14 :: SomeIntN) (bv 4 2) @?= bv 12 0x142, + testCase "bvZext" $ do + bvZext 8 (bv 4 0x8 :: SomeIntN) @?= bv 8 0x08, + testCase "bvSext" $ do + bvSext 8 (bv 4 0x8 :: SomeIntN) @?= bv 8 0xF8, + testCase "bvExt" $ do + bvExt 8 (bv 4 0x8 :: SomeIntN) @?= bv 8 0xF8 + bvExt 8 (bv 4 0x8 :: SomeWordN) @?= bv 8 0x08, + testCase "bvSelect" $ do + bvSelect 1 4 (bv 8 0x17 :: SomeIntN) @?= bv 4 0xB, + testCase "bv" $ bv 8 0x14 @?= (SomeIntN (0x14 :: IntN 8)) + ], + testGroup + "Mergeable" + [ testGroup "SomeIntN" $ do + (name, l, r, merged) <- + [ ( "same bitwidth", + bv 4 3, + bv 4 5, + ifWithLeftMost + True + "cond" + (UnionSingle $ bv 4 3) + (UnionSingle $ bv 4 5) + ), + ( "same bitwidth, should invert", + bv 4 5, + bv 4 2, + ifWithLeftMost + True + (symNot "cond") + (UnionSingle $ bv 4 2) + (UnionSingle $ bv 4 5) + ), + ( "different bitwidth", + bv 4 5, + bv 5 4, + ifWithLeftMost + True + "cond" + (UnionSingle $ bv 4 5) + (UnionSingle $ bv 5 4) + ), + ( "different bitwidth, should invert", + bv 5 4, + bv 4 5, + ifWithLeftMost + True + (symNot "cond") + (UnionSingle $ bv 4 5) + (UnionSingle $ bv 5 4) + ) + ] + return $ testCase name $ do + let actual = + mrgIf "cond" (return l) (return r) :: UnionM SomeIntN + let expected = UMrg rootStrategy merged + actual @?= expected, + testGroup "SomeSymIntN" $ do + (name, l, r, merged) <- + [ ( "same bitwidth", + ssymBV 4 "a", + ssymBV 4 "b", + (UnionSingle $ symIte "cond" (ssymBV 4 "a") (ssymBV 4 "b")) + ), + ( "different bitwidth", + ssymBV 4 "a", + ssymBV 5 "b", + ifWithLeftMost + True + "cond" + (UnionSingle $ ssymBV 4 "a") + (UnionSingle $ ssymBV 5 "b") + ), + ( "different bitwidth, should invert", + ssymBV 5 "b", + ssymBV 4 "a", + ifWithLeftMost + True + (symNot "cond") + (UnionSingle $ ssymBV 4 "a") + (UnionSingle $ ssymBV 5 "b") + ) + ] + return $ testCase name $ do + let actual = + mrgIf "cond" (return l) (return r) :: UnionM SomeSymIntN + let expected = UMrg rootStrategy merged + actual @?= expected + ], + testGroup + "GenSym" + [ testCase "Proxy n" $ do + let actual = genSym (Proxy :: Proxy 4) "a" :: UnionM SomeSymIntN + let expected = mrgSingle $ isymBV 4 "a" 0 + actual @?= expected, + testCase "SomeBV" $ do + let actual = + genSym (bv 4 1 :: SomeSymIntN) "a" :: UnionM SomeSymIntN + let expected = mrgSingle $ isymBV 4 "a" 0 + actual @?= expected, + testCase "Int" $ do + let actual = + genSym (4 :: Int) "a" :: UnionM SomeSymIntN + let expected = mrgSingle $ isymBV 4 "a" 0 + actual @?= expected + ], + testGroup + "GenSymSimple" + [ testCase "Proxy n" $ do + let actual = genSymSimple (Proxy :: Proxy 4) "a" :: SomeSymIntN + let expected = isymBV 4 "a" 0 + actual @?= expected, + testCase "SomeBV" $ do + let actual = + genSymSimple (bv 4 1 :: SomeSymIntN) "a" :: SomeSymIntN + let expected = isymBV 4 "a" 0 + actual @?= expected, + testCase "Int" $ do + let actual = genSymSimple (4 :: Int) "a" :: SomeSymIntN + let expected = isymBV 4 "a" 0 + actual @?= expected + ], + testProperty "arbitraryBV" $ + forAll (arbitraryBV 4) $ + \(bv :: SomeIntN) -> ioProperty $ finiteBitSize bv @?= 4 + ] diff --git a/test/Grisette/IR/SymPrim/Data/Prim/BVTests.hs b/test/Grisette/IR/SymPrim/Data/Prim/BVTests.hs deleted file mode 100644 --- a/test/Grisette/IR/SymPrim/Data/Prim/BVTests.hs +++ /dev/null @@ -1,122 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - -module Grisette.IR.SymPrim.Data.Prim.BVTests (bvTests) where - -import Data.Proxy (Proxy (Proxy)) -import Grisette.Core.Data.BV (IntN, WordN) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors - ( bvconcatTerm, - bvextendTerm, - bvselectTerm, - conTerm, - ssymTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term (Term) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.BV - ( pevalBVConcatTerm, - pevalBVExtendTerm, - pevalBVSelectTerm, - ) -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit ((@=?)) - -bvTests :: Test -bvTests = - testGroup - "BV" - [ testGroup - "pevalBVSelectTerm" - [ testCase "On concrete" $ do - pevalBVSelectTerm - (Proxy @0) - (Proxy @1) - (conTerm 6 :: Term (WordN 4)) - @=? conTerm 0 - pevalBVSelectTerm - (Proxy @1) - (Proxy @1) - (conTerm 6 :: Term (WordN 4)) - @=? conTerm 1 - pevalBVSelectTerm - (Proxy @2) - (Proxy @1) - (conTerm 6 :: Term (WordN 4)) - @=? conTerm 1 - pevalBVSelectTerm - (Proxy @3) - (Proxy @1) - (conTerm 6 :: Term (WordN 4)) - @=? conTerm 0 - pevalBVSelectTerm - (Proxy @0) - (Proxy @2) - (conTerm 6 :: Term (WordN 4)) - @=? conTerm 2 - pevalBVSelectTerm - (Proxy @1) - (Proxy @2) - (conTerm 6 :: Term (WordN 4)) - @=? conTerm 3 - pevalBVSelectTerm - (Proxy @2) - (Proxy @2) - (conTerm 6 :: Term (WordN 4)) - @=? conTerm 1 - pevalBVSelectTerm - (Proxy @0) - (Proxy @3) - (conTerm 6 :: Term (WordN 4)) - @=? conTerm 6 - pevalBVSelectTerm - (Proxy @1) - (Proxy @3) - (conTerm 6 :: Term (WordN 4)) - @=? conTerm 3 - pevalBVSelectTerm - (Proxy @0) - (Proxy @4) - (conTerm 6 :: Term (WordN 4)) - @=? conTerm 6, - testCase "On symbolic" $ do - pevalBVSelectTerm - (Proxy @2) - (Proxy @1) - (ssymTerm "a" :: Term (WordN 4)) - @=? bvselectTerm (Proxy @2) (Proxy @1) (ssymTerm "a" :: Term (WordN 4)) - ], - testGroup - "Extension" - [ testCase "On concrete" $ do - pevalBVExtendTerm True (Proxy @6) (conTerm 15 :: Term (WordN 4)) - @=? (conTerm 63 :: Term (WordN 6)) - pevalBVExtendTerm False (Proxy @6) (conTerm 15 :: Term (WordN 4)) - @=? (conTerm 15 :: Term (WordN 6)) - pevalBVExtendTerm True (Proxy @6) (conTerm 15 :: Term (IntN 4)) - @=? (conTerm 63 :: Term (IntN 6)) - pevalBVExtendTerm False (Proxy @6) (conTerm 15 :: Term (IntN 4)) - @=? (conTerm 15 :: Term (IntN 6)), - testCase "On symbolic" $ do - pevalBVExtendTerm True (Proxy @6) (ssymTerm "a" :: Term (WordN 4)) - @=? bvextendTerm True (Proxy @6) (ssymTerm "a" :: Term (WordN 4)) - pevalBVExtendTerm False (Proxy @6) (ssymTerm "a" :: Term (WordN 4)) - @=? bvextendTerm False (Proxy @6) (ssymTerm "a" :: Term (WordN 4)) - ], - testGroup - "Concat" - [ testCase "On concrete" $ do - pevalBVConcatTerm (conTerm 3 :: Term (WordN 4)) (conTerm 5 :: Term (WordN 3)) - @=? conTerm 29 - pevalBVConcatTerm (conTerm 3 :: Term (IntN 4)) (conTerm 5 :: Term (IntN 3)) - @=? conTerm 29, - testCase "On symbolic" $ do - pevalBVConcatTerm (ssymTerm "a" :: Term (WordN 4)) (ssymTerm "b" :: Term (WordN 3)) - @=? bvconcatTerm - (ssymTerm "a" :: Term (WordN 4)) - (ssymTerm "b" :: Term (WordN 3)) - ] - ] diff --git a/test/Grisette/IR/SymPrim/Data/Prim/BitsTests.hs b/test/Grisette/IR/SymPrim/Data/Prim/BitsTests.hs deleted file mode 100644 --- a/test/Grisette/IR/SymPrim/Data/Prim/BitsTests.hs +++ /dev/null @@ -1,312 +0,0 @@ -{-# LANGUAGE BinaryLiterals #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - -module Grisette.IR.SymPrim.Data.Prim.BitsTests (bitsTests) where - -import Data.Bits (Bits (rotateL, rotateR), FiniteBits) -import Grisette.Core.Data.BV (IntN, WordN) -import Grisette.Core.Data.Class.SymRotate (SymRotate) -import Grisette.IR.SymPrim (SupportedPrim) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors - ( andBitsTerm, - complementBitsTerm, - conTerm, - orBitsTerm, - rotateLeftTerm, - rotateRightTerm, - shiftLeftTerm, - shiftRightTerm, - ssymTerm, - xorBitsTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term (Term) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bits - ( pevalAndBitsTerm, - pevalComplementBitsTerm, - pevalOrBitsTerm, - pevalRotateLeftTerm, - pevalRotateRightTerm, - pevalShiftLeftTerm, - pevalShiftRightTerm, - pevalXorBitsTerm, - ) -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.HUnit ((@=?)) -import Test.QuickCheck (Property, discard, ioProperty) - -bitsTests :: Test -bitsTests = - testGroup - "Bits" - [ testGroup - "AndBits" - [ testCase "On both concrete" $ do - pevalAndBitsTerm - (conTerm 3 :: Term (WordN 4)) - (conTerm 5) - @=? conTerm 1, - testCase "On zeroBits" $ do - pevalAndBitsTerm - (conTerm 0 :: Term (WordN 4)) - (ssymTerm "a") - @=? conTerm 0 - pevalAndBitsTerm - (ssymTerm "a") - (conTerm 0 :: Term (WordN 4)) - @=? conTerm 0, - testCase "On all one bits" $ do - pevalAndBitsTerm - (conTerm 15 :: Term (WordN 4)) - (ssymTerm "a") - @=? ssymTerm "a" - pevalAndBitsTerm - (ssymTerm "a") - (conTerm 15 :: Term (WordN 4)) - @=? ssymTerm "a", - testCase "On symbolic" $ do - pevalAndBitsTerm - (ssymTerm "a" :: Term (WordN 4)) - (ssymTerm "b") - @=? andBitsTerm - (ssymTerm "a" :: Term (WordN 4)) - (ssymTerm "b" :: Term (WordN 4)) - ], - testGroup - "OrBits" - [ testCase "On both concrete" $ do - pevalOrBitsTerm - (conTerm 3 :: Term (WordN 4)) - (conTerm 5) - @=? conTerm 7, - testCase "On zeroBits" $ do - pevalOrBitsTerm - (conTerm 0 :: Term (WordN 4)) - (ssymTerm "a") - @=? ssymTerm "a" - pevalOrBitsTerm - (ssymTerm "a") - (conTerm 0 :: Term (WordN 4)) - @=? ssymTerm "a", - testCase "On all one bits" $ do - pevalOrBitsTerm - (conTerm 15 :: Term (WordN 4)) - (ssymTerm "a") - @=? conTerm 15 - pevalOrBitsTerm - (ssymTerm "a") - (conTerm 15 :: Term (WordN 4)) - @=? conTerm 15, - testCase "On symbolic" $ do - pevalOrBitsTerm - (ssymTerm "a" :: Term (WordN 4)) - (ssymTerm "b") - @=? orBitsTerm - (ssymTerm "a" :: Term (WordN 4)) - (ssymTerm "b" :: Term (WordN 4)) - ], - testGroup - "XorBits" - [ testCase "On both concrete" $ do - pevalXorBitsTerm - (conTerm 3 :: Term (WordN 4)) - (conTerm 5) - @=? conTerm 6, - testCase "On zeroBits" $ do - pevalXorBitsTerm - (conTerm 0 :: Term (WordN 4)) - (ssymTerm "a") - @=? ssymTerm "a" - pevalXorBitsTerm - (ssymTerm "a") - (conTerm 0 :: Term (WordN 4)) - @=? ssymTerm "a", - testCase "On all one bits" $ do - pevalXorBitsTerm - (conTerm 15 :: Term (WordN 4)) - (ssymTerm "a") - @=? pevalComplementBitsTerm (ssymTerm "a") - pevalXorBitsTerm - (ssymTerm "a") - (conTerm 15 :: Term (WordN 4)) - @=? pevalComplementBitsTerm (ssymTerm "a"), - testCase "On single complement" $ do - pevalXorBitsTerm - (pevalComplementBitsTerm $ ssymTerm "a" :: Term (WordN 4)) - (ssymTerm "b") - @=? pevalComplementBitsTerm (pevalXorBitsTerm (ssymTerm "a") (ssymTerm "b")) - pevalXorBitsTerm - (ssymTerm "a" :: Term (WordN 4)) - (pevalComplementBitsTerm $ ssymTerm "b") - @=? pevalComplementBitsTerm (pevalXorBitsTerm (ssymTerm "a") (ssymTerm "b")), - testCase "On both complement" $ do - pevalXorBitsTerm - (pevalComplementBitsTerm $ ssymTerm "a" :: Term (WordN 4)) - (pevalComplementBitsTerm $ ssymTerm "b") - @=? pevalXorBitsTerm (ssymTerm "a") (ssymTerm "b"), - testCase "On symbolic" $ do - pevalXorBitsTerm - (ssymTerm "a" :: Term (WordN 4)) - (ssymTerm "b") - @=? xorBitsTerm - (ssymTerm "a" :: Term (WordN 4)) - (ssymTerm "b" :: Term (WordN 4)) - ], - testGroup - "ComplementBits" - [ testCase "On concrete" $ do - pevalComplementBitsTerm (conTerm 5 :: Term (WordN 4)) @=? conTerm 10, - testCase "On complement" $ do - pevalComplementBitsTerm (pevalComplementBitsTerm (ssymTerm "a") :: Term (WordN 4)) @=? ssymTerm "a", - testCase "On symbolic" $ do - pevalComplementBitsTerm (ssymTerm "a" :: Term (WordN 4)) - @=? complementBitsTerm (ssymTerm "a" :: Term (WordN 4)) - ], - testGroup - "ShiftLeft" - [ testCase "On concrete" $ do - pevalShiftLeftTerm (conTerm 15 :: Term (WordN 4)) (conTerm 2) @=? conTerm 12 - pevalShiftLeftTerm (conTerm 15 :: Term (IntN 4)) (conTerm 2) @=? conTerm 12, - testCase "shift 0" $ do - pevalShiftLeftTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 0) @=? ssymTerm "a" - pevalShiftLeftTerm (ssymTerm "a" :: Term (IntN 4)) (conTerm 0) @=? ssymTerm "a", - testCase "shift greater or equal to left bitsize" $ do - pevalShiftLeftTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 4) @=? conTerm 0 - pevalShiftLeftTerm (ssymTerm "a" :: Term (IntN 4)) (conTerm 4) @=? conTerm 0 - pevalShiftLeftTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 5) @=? conTerm 0 - pevalShiftLeftTerm (ssymTerm "a" :: Term (IntN 4)) (conTerm 5) @=? conTerm 0, - testCase "shift negative amount is undefined on for IntN" $ do - pevalShiftLeftTerm (conTerm 15 :: Term (IntN 4)) (conTerm $ -1) - @=? shiftLeftTerm (conTerm 15) (conTerm $ -1) - pevalShiftLeftTerm (conTerm 15 :: Term (IntN 4)) (conTerm $ -8) - @=? shiftLeftTerm (conTerm 15) (conTerm $ -8), - testCase "shift symbolic" $ do - pevalShiftLeftTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 2) - @=? shiftLeftTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 2), - testCase "Regression: shift by very large number" $ do - pevalShiftLeftTerm (conTerm 15 :: Term (IntN 128)) (conTerm maxBound) @=? conTerm 0 - pevalShiftLeftTerm (conTerm 15 :: Term (WordN 128)) (conTerm maxBound) @=? conTerm 0 - ], - testGroup - "ShiftRight" - [ testCase "On concrete, should perform arithmetic shifting on IntN" $ do - pevalShiftRightTerm (conTerm 7 :: Term (IntN 4)) (conTerm 2) @=? conTerm 1 - pevalShiftRightTerm (conTerm 15 :: Term (IntN 4)) (conTerm 2) @=? conTerm 15, - testCase "On concrete, should perform logical shifting on WordN" $ do - pevalShiftRightTerm (conTerm 7 :: Term (WordN 4)) (conTerm 2) @=? conTerm 1 - pevalShiftRightTerm (conTerm 15 :: Term (WordN 4)) (conTerm 2) @=? conTerm 3, - testCase "shift 0" $ do - pevalShiftRightTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 0) @=? ssymTerm "a" - pevalShiftRightTerm (ssymTerm "a" :: Term (IntN 4)) (conTerm 0) @=? ssymTerm "a", - testCase "shift greater or equal to left bitsize on WordN" $ do - pevalShiftRightTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 4) @=? conTerm 0 - pevalShiftRightTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 5) @=? conTerm 0, - testCase "shift greater or equal to left bitsize on IntN will not be reduced" $ do - pevalShiftRightTerm (ssymTerm "a" :: Term (IntN 4)) (conTerm 5) - @=? shiftRightTerm (ssymTerm "a") (conTerm 5) - pevalShiftRightTerm (ssymTerm "a" :: Term (IntN 4)) (conTerm 4) - @=? shiftRightTerm (ssymTerm "a") (conTerm 4), - testCase "shift negative amount is undefined on for IntN" $ do - pevalShiftRightTerm (conTerm 15 :: Term (IntN 4)) (conTerm $ -1) - @=? shiftRightTerm (conTerm 15) (conTerm $ -1) - pevalShiftRightTerm (conTerm 15 :: Term (IntN 4)) (conTerm $ -8) - @=? shiftRightTerm (conTerm 15) (conTerm $ -8), - testCase "shift symbolic" $ do - pevalShiftRightTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 2) - @=? shiftRightTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 2), - testCase "Regression: shift by very large number" $ do - pevalShiftRightTerm (conTerm 15 :: Term (IntN 128)) (conTerm maxBound) @=? conTerm 0 - pevalShiftRightTerm (conTerm 15 :: Term (WordN 128)) (conTerm maxBound) @=? conTerm 0 - ], - testGroup - "RotateLeft" - [ testCase "On concrete" $ do - pevalRotateLeftTerm (conTerm 0b10100101 :: Term (WordN 8)) (conTerm 2) @=? conTerm 0b10010110 - pevalRotateLeftTerm (conTerm 0b10100101 :: Term (IntN 8)) (conTerm 2) @=? conTerm 0b10010110, - testCase "rotate 0" $ do - pevalRotateLeftTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 0) @=? ssymTerm "a" - pevalRotateLeftTerm (ssymTerm "a" :: Term (IntN 4)) (conTerm 0) @=? ssymTerm "a", - testCase "rotate bitsize" $ do - pevalRotateLeftTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 4) - @=? ssymTerm "a" - pevalRotateLeftTerm (ssymTerm "a" :: Term (IntN 4)) (conTerm 4) - @=? ssymTerm "a", - testCase "rotate greater than left bitsize" $ do - pevalRotateLeftTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 5) - @=? rotateLeftTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 1) - pevalRotateLeftTerm (ssymTerm "a" :: Term (IntN 4)) (conTerm 5) - @=? rotateLeftTerm (ssymTerm "a" :: Term (IntN 4)) (conTerm 1), - testCase "rotate negative amount is undefined on for IntN" $ do - pevalRotateLeftTerm (conTerm 15 :: Term (IntN 4)) (conTerm $ -1) - @=? rotateLeftTerm (conTerm 15) (conTerm $ -1) - pevalRotateLeftTerm (conTerm 15 :: Term (IntN 4)) (conTerm $ -8) - @=? rotateLeftTerm (conTerm 15) (conTerm $ -8), - testCase "rotate symbolic" $ do - pevalRotateLeftTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 2) - @=? rotateLeftTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 2), - testCase "Regression: rotate by very large number" $ do - pevalRotateLeftTerm (conTerm 15 :: Term (IntN 128)) (conTerm maxBound) @=? conTerm (rotateR 15 1) - pevalRotateLeftTerm (conTerm 15 :: Term (WordN 128)) (conTerm maxBound) @=? conTerm (rotateR 15 1) - ], - testGroup - "RotateRight" - [ testProperty "On concrete WordN 1" $ - concreteSmallRotateRightCorrect @(WordN 1), - testProperty "On concrete WordN 2" $ - concreteSmallRotateRightCorrect @(WordN 2), - testProperty "On concrete WordN 3" $ - concreteSmallRotateRightCorrect @(WordN 3), - testProperty "On concrete WordN 4" $ - concreteSmallRotateRightCorrect @(WordN 4), - testProperty "On concrete WordN 8" $ - concreteSmallRotateRightCorrect @(WordN 8), - testProperty "On concrete IntN 1" $ - concreteSmallRotateRightCorrect @(IntN 1), - testProperty "On concrete IntN 2" $ - concreteSmallRotateRightCorrect @(IntN 2), - testProperty "On concrete IntN 3" $ - concreteSmallRotateRightCorrect @(IntN 3), - testProperty "On concrete IntN 4" $ - concreteSmallRotateRightCorrect @(IntN 4), - testProperty "On concrete IntN 8" $ - concreteSmallRotateRightCorrect @(IntN 8), - testCase "rotate 0" $ do - pevalRotateRightTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 0) @=? ssymTerm "a" - pevalRotateRightTerm (ssymTerm "a" :: Term (IntN 4)) (conTerm 0) @=? ssymTerm "a", - testCase "rotate bitsize" $ do - pevalRotateRightTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 4) - @=? ssymTerm "a" - pevalRotateRightTerm (ssymTerm "a" :: Term (IntN 4)) (conTerm 4) - @=? ssymTerm "a", - testCase "rotate greater than left bitsize" $ do - pevalRotateRightTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 5) - @=? rotateRightTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 1) - pevalRotateRightTerm (ssymTerm "a" :: Term (IntN 4)) (conTerm 5) - @=? rotateRightTerm (ssymTerm "a" :: Term (IntN 4)) (conTerm 1), - testCase "rotate negative amount is undefined on for IntN" $ do - pevalRotateRightTerm (conTerm 15 :: Term (IntN 4)) (conTerm $ -1) - @=? rotateRightTerm (conTerm 15) (conTerm $ -1) - pevalRotateRightTerm (conTerm 15 :: Term (IntN 4)) (conTerm $ -8) - @=? rotateRightTerm (conTerm 15) (conTerm $ -8), - testCase "rotate symbolic" $ do - pevalRotateRightTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 2) - @=? rotateRightTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 2), - testCase "Regression: rotate by very large number" $ do - pevalRotateRightTerm (conTerm 15 :: Term (IntN 128)) (conTerm maxBound) @=? conTerm (rotateL 15 1) - pevalRotateRightTerm (conTerm 15 :: Term (WordN 128)) (conTerm maxBound) @=? conTerm (rotateL 15 1) - ] - ] - -concreteSmallRotateRightCorrect :: - (SupportedPrim a, Integral a, FiniteBits a, SymRotate a) => - a -> - a -> - Property -concreteSmallRotateRightCorrect _ b | b < 0 = discard -concreteSmallRotateRightCorrect a b = ioProperty $ do - pevalRotateRightTerm (conTerm a) (conTerm b) - @=? conTerm (rotateR a (fromIntegral b)) diff --git a/test/Grisette/IR/SymPrim/Data/Prim/BoolTests.hs b/test/Grisette/IR/SymPrim/Data/Prim/BoolTests.hs deleted file mode 100644 --- a/test/Grisette/IR/SymPrim/Data/Prim/BoolTests.hs +++ /dev/null @@ -1,738 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Grisette.IR.SymPrim.Data.Prim.BoolTests (boolTests) where - -import Grisette.Core.Data.BV (IntN, WordN) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors - ( andTerm, - conTerm, - eqvTerm, - notTerm, - orTerm, - ssymTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term (Term) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool - ( pevalAndTerm, - pevalEqvTerm, - pevalITETerm, - pevalImplyTerm, - pevalNotEqvTerm, - pevalNotTerm, - pevalOrTerm, - pevalXorTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.Num - ( pevalAddNumTerm, - ) -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit ((@=?)) - -boolTests :: Test -boolTests = - testGroup - "Bool" - [ testGroup - "Not" - [ testCase "On concrete" $ do - pevalNotTerm (conTerm True) @=? conTerm False - pevalNotTerm (conTerm True) @=? conTerm False, - testCase "On general symbolic" $ do - pevalNotTerm (ssymTerm "a") @=? notTerm (ssymTerm "a" :: Term Bool), - testCase "On Not" $ do - pevalNotTerm (pevalNotTerm (ssymTerm "a")) @=? ssymTerm "a", - testCase "On Or Not" $ do - pevalNotTerm (pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")) - @=? pevalAndTerm (ssymTerm "a") (pevalNotTerm (ssymTerm "b")) - pevalNotTerm (pevalOrTerm (ssymTerm "a") (pevalNotTerm (ssymTerm "b"))) - @=? pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b"), - testCase "On And Not" $ do - pevalNotTerm (pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")) - @=? pevalOrTerm (ssymTerm "a") (pevalNotTerm (ssymTerm "b")) - pevalNotTerm (pevalAndTerm (ssymTerm "a") (pevalNotTerm (ssymTerm "b"))) - @=? pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b") - ], - testGroup - "Eqv & NEqv" - [ testCase "Eqv on both concrete" $ do - pevalEqvTerm (conTerm True) (conTerm True) @=? conTerm True - pevalEqvTerm (conTerm True) (conTerm False) @=? conTerm False - pevalEqvTerm (conTerm False) (conTerm True) @=? conTerm False - pevalEqvTerm (conTerm False) (conTerm False) @=? conTerm True - pevalEqvTerm (conTerm (1 :: Integer)) (conTerm 1) @=? conTerm True - pevalEqvTerm (conTerm (1 :: Integer)) (conTerm 2) @=? conTerm False - pevalEqvTerm (conTerm (1 :: IntN 4)) (conTerm 1) @=? conTerm True - pevalEqvTerm (conTerm (1 :: IntN 4)) (conTerm 2) @=? conTerm False - pevalEqvTerm (conTerm (1 :: WordN 4)) (conTerm 1) @=? conTerm True - pevalEqvTerm (conTerm (1 :: WordN 4)) (conTerm 2) @=? conTerm False, - testCase "Eqv on single concrete always put concrete ones in the right" $ do - pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1) - @=? eqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1 :: Term Integer) - pevalEqvTerm (conTerm 1) (ssymTerm "a" :: Term Integer) - @=? eqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1 :: Term Integer), - testCase "Eqv on general symbolic" $ do - pevalEqvTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b") - @=? eqvTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b" :: Term Integer), - testCase "Eqv on Bool with single concrete" $ do - pevalEqvTerm (conTerm True) (ssymTerm "a") @=? ssymTerm "a" - pevalEqvTerm (ssymTerm "a") (conTerm True) @=? ssymTerm "a" - pevalEqvTerm (conTerm False) (ssymTerm "a") @=? pevalNotTerm (ssymTerm "a") - pevalEqvTerm (ssymTerm "a") (conTerm False) @=? pevalNotTerm (ssymTerm "a"), - testCase "NEqv on general symbolic" $ do - pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b") - @=? pevalNotTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b")), - testCase "Eqv(Not(x), x) / Eqv(x, Not(x))" $ do - pevalEqvTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "a") @=? conTerm False - pevalEqvTerm (ssymTerm "a") (pevalNotTerm (ssymTerm "a")) @=? conTerm False, - testCase "Eqv(n1+x, n2)" $ do - pevalEqvTerm (pevalAddNumTerm (conTerm 1 :: Term Integer) (ssymTerm "a")) (conTerm 3) - @=? pevalEqvTerm (ssymTerm "a") (conTerm 2 :: Term Integer) - pevalEqvTerm (pevalAddNumTerm (conTerm 1 :: Term (IntN 4)) (ssymTerm "a")) (conTerm 3) - @=? pevalEqvTerm (ssymTerm "a") (conTerm 2 :: Term (IntN 4)) - pevalEqvTerm (pevalAddNumTerm (conTerm 1 :: Term (WordN 4)) (ssymTerm "a")) (conTerm 3) - @=? pevalEqvTerm (ssymTerm "a") (conTerm 2 :: Term (WordN 4)), - testCase "Eqv(n1, n2+x)" $ do - pevalEqvTerm (conTerm 3) (pevalAddNumTerm (conTerm 1 :: Term Integer) (ssymTerm "a")) - @=? pevalEqvTerm (ssymTerm "a") (conTerm 2 :: Term Integer) - pevalEqvTerm (conTerm 3) (pevalAddNumTerm (conTerm 1 :: Term (IntN 4)) (ssymTerm "a")) - @=? pevalEqvTerm (ssymTerm "a") (conTerm 2 :: Term (IntN 4)) - pevalEqvTerm (conTerm 3) (pevalAddNumTerm (conTerm 1 :: Term (WordN 4)) (ssymTerm "a")) - @=? pevalEqvTerm (ssymTerm "a") (conTerm 2 :: Term (WordN 4)), - testCase "Eqv(l, ITE(c, l, f)) / Eqv(l, ITE(c, t, l) / Eqv(ITE(c, r, f), r) / Eqv(ITE(c, t, r), r)" $ do - pevalEqvTerm (ssymTerm "a" :: Term Integer) (pevalITETerm (ssymTerm "b") (ssymTerm "a") (ssymTerm "c")) - @=? pevalOrTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "a") (ssymTerm "c" :: Term Integer)) - pevalEqvTerm (ssymTerm "a" :: Term Integer) (pevalITETerm (ssymTerm "b") (ssymTerm "c") (ssymTerm "a")) - @=? pevalOrTerm (pevalNotTerm $ ssymTerm "b") (pevalEqvTerm (ssymTerm "a") (ssymTerm "c" :: Term Integer)) - pevalEqvTerm (pevalITETerm (ssymTerm "b") (ssymTerm "a") (ssymTerm "c")) (ssymTerm "a" :: Term Integer) - @=? pevalOrTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "c") (ssymTerm "a" :: Term Integer)) - pevalEqvTerm (pevalITETerm (ssymTerm "b") (ssymTerm "c") (ssymTerm "a")) (ssymTerm "a" :: Term Integer) - @=? pevalOrTerm (pevalNotTerm $ ssymTerm "b") (pevalEqvTerm (ssymTerm "c") (ssymTerm "a" :: Term Integer)) - ], - testGroup - "Or" - [ testCase "On both concrete" $ do - pevalOrTerm (conTerm True) (conTerm True) @=? conTerm True - pevalOrTerm (conTerm True) (conTerm False) @=? conTerm True - pevalOrTerm (conTerm False) (conTerm True) @=? conTerm True - pevalOrTerm (conTerm False) (conTerm False) @=? conTerm False, - testCase "On general symbolic" $ do - pevalOrTerm (ssymTerm "a") (ssymTerm "b") - @=? orTerm (ssymTerm "a" :: Term Bool) (ssymTerm "b" :: Term Bool), - testCase "Or(x, y) -> True" $ do - pevalOrTerm (conTerm True) (ssymTerm "b") @=? conTerm True - pevalOrTerm (ssymTerm "a") (conTerm True) @=? conTerm True - pevalOrTerm - (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) - @=? conTerm True - pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "a") @=? conTerm True - pevalOrTerm (ssymTerm "a") (pevalNotTerm (ssymTerm "a")) @=? conTerm True, - testCase "Or(x, y) -> x" $ do - pevalOrTerm (ssymTerm "a") (conTerm False) @=? ssymTerm "a" - pevalOrTerm - (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) - @=? pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1) - pevalOrTerm (ssymTerm "a") (ssymTerm "a") @=? ssymTerm "a", - testCase "Or(x, y) -> y" $ do - pevalOrTerm (conTerm False) (ssymTerm "a") @=? ssymTerm "a" - pevalOrTerm - (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) - (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - @=? pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1), - testCase "Or(x, Or(y1, y2)) -> True" $ do - pevalOrTerm (pevalNotTerm (ssymTerm "a")) (pevalOrTerm (ssymTerm "a") (ssymTerm "b")) @=? conTerm True - pevalOrTerm (ssymTerm "a") (pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")) @=? conTerm True - pevalOrTerm - (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - (pevalOrTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) - @=? conTerm True - - pevalOrTerm (pevalNotTerm (ssymTerm "a")) (pevalOrTerm (ssymTerm "b") (ssymTerm "a")) @=? conTerm True - pevalOrTerm (ssymTerm "a") (pevalOrTerm (ssymTerm "b") (pevalNotTerm (ssymTerm "a"))) @=? conTerm True - pevalOrTerm - (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - (pevalOrTerm (ssymTerm "b") (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) - @=? conTerm True, - testCase "Or(x, Or(y1, y2)) -> Or(x, y2)" $ do - pevalOrTerm - (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - (pevalOrTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) - @=? pevalOrTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"), - testCase "Or(x, Or(y1, y2)) -> Or(x, y1)" $ do - pevalOrTerm - (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - (pevalOrTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) - @=? pevalOrTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"), - testCase "Or(x, y@Or(y1, y2)) -> y" $ do - pevalOrTerm (ssymTerm "a") (pevalOrTerm (ssymTerm "a") (ssymTerm "b")) - @=? pevalOrTerm (ssymTerm "a") (ssymTerm "b") - pevalOrTerm - (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) - (pevalOrTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b")) - @=? pevalOrTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b") - pevalOrTerm (ssymTerm "a") (pevalOrTerm (ssymTerm "b") (ssymTerm "a")) - @=? pevalOrTerm (ssymTerm "b") (ssymTerm "a") - pevalOrTerm - (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) - (pevalOrTerm (ssymTerm "b") (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))) - @=? pevalOrTerm (ssymTerm "b") (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)), - testCase "Or(Or(x1, x2), y) -> True" $ do - pevalOrTerm (pevalOrTerm (ssymTerm "a") (ssymTerm "b")) (pevalNotTerm (ssymTerm "a")) @=? conTerm True - pevalOrTerm (pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")) (ssymTerm "a") @=? conTerm True - pevalOrTerm - (pevalOrTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) - (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - @=? conTerm True - - pevalOrTerm (pevalOrTerm (ssymTerm "b") (ssymTerm "a")) (pevalNotTerm (ssymTerm "a")) @=? conTerm True - pevalOrTerm (pevalOrTerm (ssymTerm "b") (pevalNotTerm (ssymTerm "a"))) (ssymTerm "a") @=? conTerm True - pevalOrTerm - (pevalOrTerm (ssymTerm "b") (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) - (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - @=? conTerm True, - testCase "Or(x@Or(x1, x2), y) -> x" $ do - pevalOrTerm (pevalOrTerm (ssymTerm "a") (ssymTerm "b")) (ssymTerm "a") - @=? pevalOrTerm (ssymTerm "a") (ssymTerm "b") - pevalOrTerm - (pevalOrTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b")) - (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) - @=? pevalOrTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b") - pevalOrTerm (pevalOrTerm (ssymTerm "b") (ssymTerm "a")) (ssymTerm "a") - @=? pevalOrTerm (ssymTerm "b") (ssymTerm "a") - pevalOrTerm - (pevalOrTerm (ssymTerm "b") (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))) - (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) - @=? pevalOrTerm (ssymTerm "b") (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)), - testCase "Or(Or(x1, x2), y) -> Or(x2, y)" $ do - pevalOrTerm - (pevalOrTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) - (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - @=? pevalOrTerm (ssymTerm "b") (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)), - testCase "Or(Or(x1, x2), y) -> Or(x1, y)" $ do - pevalOrTerm - (pevalOrTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) - (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - @=? pevalOrTerm (ssymTerm "b") (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)), - testCase "Or(x, And(y1, y2)) -> x" $ do - pevalOrTerm - (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - (pevalAndTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) - @=? pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1) - pevalOrTerm - (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - (pevalAndTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) - @=? pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1), - testCase "Or(x, And(y1, y2)) -> Or(x, y2)" $ do - pevalOrTerm (ssymTerm "a") (pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")) - @=? pevalOrTerm (ssymTerm "a") (ssymTerm "b") - pevalOrTerm (pevalNotTerm (ssymTerm "a")) (pevalAndTerm (ssymTerm "a") (ssymTerm "b")) - @=? pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b") - pevalOrTerm - (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - (pevalAndTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) - @=? pevalOrTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"), - testCase "Or(And(x1, x2), y) -> y" $ do - pevalOrTerm - (pevalAndTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) - (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - @=? pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1) - pevalOrTerm - (pevalAndTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) - (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - @=? pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1), - testCase "Or(x, And(y1, y2)) -> Or(x, y1)" $ do - pevalOrTerm (ssymTerm "a") (pevalAndTerm (ssymTerm "b") (pevalNotTerm (ssymTerm "a"))) - @=? pevalOrTerm (ssymTerm "a") (ssymTerm "b") - pevalOrTerm (pevalNotTerm (ssymTerm "a")) (pevalAndTerm (ssymTerm "b") (ssymTerm "a")) - @=? pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b") - pevalOrTerm - (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - (pevalAndTerm (ssymTerm "b") (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) - @=? pevalOrTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"), - testCase "Or(Not(x), Not(y)) -> Not(And(x, y))" $ do - pevalOrTerm (pevalNotTerm (ssymTerm "a")) (pevalNotTerm (ssymTerm "b")) - @=? pevalNotTerm (pevalAndTerm (ssymTerm "a") (ssymTerm "b")) - ], - testGroup - "And" - [ testCase "Oith both concrete" $ do - pevalAndTerm (conTerm True) (conTerm True) @=? conTerm True - pevalAndTerm (conTerm True) (conTerm False) @=? conTerm False - pevalAndTerm (conTerm False) (conTerm True) @=? conTerm False - pevalAndTerm (conTerm False) (conTerm False) @=? conTerm False, - testCase "On general symbolic" $ do - pevalAndTerm (ssymTerm "a") (ssymTerm "b") - @=? andTerm (ssymTerm "a" :: Term Bool) (ssymTerm "b" :: Term Bool), - testCase "And(x, y) -> False" $ do - pevalAndTerm (conTerm False) (ssymTerm "b") @=? conTerm False - pevalAndTerm (ssymTerm "a") (conTerm False) @=? conTerm False - pevalAndTerm - (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) - @=? conTerm False - pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "a") @=? conTerm False - pevalAndTerm (ssymTerm "a") (pevalNotTerm (ssymTerm "a")) @=? conTerm False, - testCase "And(x, y) -> x" $ do - pevalAndTerm (ssymTerm "a") (conTerm True) @=? ssymTerm "a" - pevalAndTerm - (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) - @=? pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1) - pevalAndTerm (ssymTerm "a") (ssymTerm "a") @=? ssymTerm "a", - testCase "And(x, y) -> y" $ do - pevalAndTerm (conTerm True) (ssymTerm "a") @=? ssymTerm "a" - pevalAndTerm - (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) - (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - @=? pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1), - testCase "And(x, And(y1, y2)) -> False" $ do - pevalAndTerm (pevalNotTerm (ssymTerm "a")) (pevalAndTerm (ssymTerm "a") (ssymTerm "b")) @=? conTerm False - pevalAndTerm (ssymTerm "a") (pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")) @=? conTerm False - pevalAndTerm - (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - (pevalAndTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) - @=? conTerm False - - pevalAndTerm (pevalNotTerm (ssymTerm "a")) (pevalAndTerm (ssymTerm "b") (ssymTerm "a")) @=? conTerm False - pevalAndTerm (ssymTerm "a") (pevalAndTerm (ssymTerm "b") (pevalNotTerm (ssymTerm "a"))) @=? conTerm False - pevalAndTerm - (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - (pevalAndTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) - @=? conTerm False, - testCase "And(x, And(y1, y2)) -> And(x, y2)" $ do - pevalAndTerm - (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - (pevalAndTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) - @=? pevalAndTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"), - testCase "And(x, And(y1, y2)) -> And(x, y1)" $ do - pevalAndTerm - (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - (pevalAndTerm (ssymTerm "b") (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) - @=? pevalAndTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"), - testCase "And(x, y@And(y1, y2)) -> y" $ do - pevalAndTerm (ssymTerm "a") (pevalAndTerm (ssymTerm "a") (ssymTerm "b")) - @=? pevalAndTerm (ssymTerm "a") (ssymTerm "b") - pevalAndTerm - (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) - (pevalAndTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b")) - @=? pevalAndTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b") - pevalAndTerm (ssymTerm "a") (pevalAndTerm (ssymTerm "b") (ssymTerm "a")) - @=? pevalAndTerm (ssymTerm "b") (ssymTerm "a") - pevalAndTerm - (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) - (pevalAndTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))) - @=? pevalAndTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)), - testCase "And(And(x1, x2), y) -> False" $ do - pevalAndTerm (pevalAndTerm (ssymTerm "a") (ssymTerm "b")) (pevalNotTerm (ssymTerm "a")) @=? conTerm False - pevalAndTerm (pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")) (ssymTerm "a") @=? conTerm False - pevalAndTerm - (pevalAndTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) - (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - @=? conTerm False - - pevalAndTerm (pevalAndTerm (ssymTerm "b") (ssymTerm "a")) (pevalNotTerm (ssymTerm "a")) @=? conTerm False - pevalAndTerm (pevalAndTerm (ssymTerm "b") (pevalNotTerm (ssymTerm "a"))) (ssymTerm "a") @=? conTerm False - pevalAndTerm - (pevalAndTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) - (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - @=? conTerm False, - testCase "And(x@And(x1, x2), y) -> x" $ do - pevalAndTerm (pevalAndTerm (ssymTerm "a") (ssymTerm "b")) (ssymTerm "a") - @=? pevalAndTerm (ssymTerm "a") (ssymTerm "b") - pevalAndTerm - (pevalAndTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b")) - (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) - @=? pevalAndTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b") - pevalAndTerm (pevalAndTerm (ssymTerm "b") (ssymTerm "a")) (ssymTerm "a") - @=? pevalAndTerm (ssymTerm "b") (ssymTerm "a") - pevalAndTerm - (pevalAndTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1))) - (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) - @=? pevalAndTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)), - testCase "And(And(x1, x2), y) -> And(x2, y)" $ do - pevalAndTerm - (pevalAndTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) - (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - @=? pevalAndTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)), - testCase "And(And(x1, x2), y) -> And(x1, y)" $ do - pevalAndTerm - (pevalAndTerm (ssymTerm "b") (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) - (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - @=? pevalAndTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)), - testCase "And(x, Or(y1, y2)) -> x" $ do - pevalAndTerm - (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - (pevalOrTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) - @=? pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1) - pevalAndTerm - (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - (pevalOrTerm (ssymTerm "b") (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) - @=? pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1), - testCase "And(x, Or(y1, y2)) -> And(x, y2)" $ do - pevalAndTerm (ssymTerm "a") (pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")) - @=? pevalAndTerm (ssymTerm "a") (ssymTerm "b") - pevalAndTerm (pevalNotTerm (ssymTerm "a")) (pevalOrTerm (ssymTerm "a") (ssymTerm "b")) - @=? pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b") - pevalAndTerm - (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - (pevalOrTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) - @=? pevalAndTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"), - testCase "And(Or(x1, x2), y) -> y" $ do - pevalAndTerm - (pevalOrTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) - (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - @=? pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1) - pevalAndTerm - (pevalOrTerm (ssymTerm "b") (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) - (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - @=? pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1), - testCase "And(x, Or(y1, y2)) -> And(x, y1)" $ do - pevalAndTerm (ssymTerm "a") (pevalOrTerm (ssymTerm "b") (pevalNotTerm (ssymTerm "a"))) - @=? pevalAndTerm (ssymTerm "a") (ssymTerm "b") - pevalAndTerm (pevalNotTerm (ssymTerm "a")) (pevalOrTerm (ssymTerm "b") (ssymTerm "a")) - @=? pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b") - pevalAndTerm - (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - (pevalOrTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) - @=? pevalAndTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"), - testCase "And(Not(x), Not(y)) -> Not(Or(x, y))" $ do - pevalAndTerm (pevalNotTerm (ssymTerm "a")) (pevalNotTerm (ssymTerm "b")) - @=? pevalNotTerm (pevalOrTerm (ssymTerm "a") (ssymTerm "b")) - ], - testGroup - "ITE" - [ testCase "On concrete condition" $ do - pevalITETerm (conTerm True) (ssymTerm "a" :: Term Integer) (ssymTerm "b") - @=? ssymTerm "a" - pevalITETerm (conTerm False) (ssymTerm "a" :: Term Integer) (ssymTerm "b") - @=? ssymTerm "b", - testCase "On same branches" $ do - pevalITETerm (ssymTerm "c") (ssymTerm "a" :: Term Integer) (ssymTerm "a") - @=? ssymTerm "a", - testCase "On both not" $ do - pevalITETerm (ssymTerm "c") (pevalNotTerm $ ssymTerm "a") (pevalNotTerm $ ssymTerm "b") - @=? pevalNotTerm (pevalITETerm (ssymTerm "c") (ssymTerm "a") (ssymTerm "b")), - testCase "On not in condition" $ do - pevalITETerm (pevalNotTerm $ ssymTerm "c") (ssymTerm "a" :: Term Integer) (ssymTerm "b") - @=? pevalITETerm (ssymTerm "c") (ssymTerm "b") (ssymTerm "a"), - testCase "On all arguments as ITE with same conditions" $ do - pevalITETerm - (pevalITETerm (ssymTerm "a") (ssymTerm "b") (ssymTerm "c")) - (pevalITETerm (ssymTerm "a") (ssymTerm "d" :: Term Integer) (ssymTerm "e")) - (pevalITETerm (ssymTerm "a") (ssymTerm "f" :: Term Integer) (ssymTerm "g")) - @=? pevalITETerm - (ssymTerm "a") - (pevalITETerm (ssymTerm "b") (ssymTerm "d") (ssymTerm "f")) - (pevalITETerm (ssymTerm "c") (ssymTerm "e") (ssymTerm "g")), - testCase "On with true branch as ITE" $ do - pevalITETerm - (ssymTerm "a") - (pevalITETerm (ssymTerm "a") (ssymTerm "b" :: Term Integer) (ssymTerm "c")) - (ssymTerm "d") - @=? pevalITETerm (ssymTerm "a") (ssymTerm "b") (ssymTerm "d") - pevalITETerm - (ssymTerm "a") - (pevalITETerm (ssymTerm "b") (ssymTerm "c" :: Term Integer) (ssymTerm "d")) - (ssymTerm "c") - @=? pevalITETerm - (pevalOrTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b")) - (ssymTerm "c") - (ssymTerm "d") - pevalITETerm - (ssymTerm "a") - (pevalITETerm (ssymTerm "b") (ssymTerm "c" :: Term Integer) (ssymTerm "d")) - (ssymTerm "d") - @=? pevalITETerm - (pevalAndTerm (ssymTerm "a") (ssymTerm "b")) - (ssymTerm "c") - (ssymTerm "d"), - testCase "On false branch as ITE" $ do - pevalITETerm - (ssymTerm "a") - (ssymTerm "b") - (pevalITETerm (ssymTerm "a") (ssymTerm "c" :: Term Integer) (ssymTerm "d")) - @=? pevalITETerm (ssymTerm "a") (ssymTerm "b") (ssymTerm "d") - pevalITETerm - (ssymTerm "a") - (ssymTerm "b") - (pevalITETerm (ssymTerm "c") (ssymTerm "b" :: Term Integer) (ssymTerm "d")) - @=? pevalITETerm - (pevalOrTerm (ssymTerm "a") (ssymTerm "c")) - (ssymTerm "b") - (ssymTerm "d") - pevalITETerm - (ssymTerm "a") - (ssymTerm "b") - (pevalITETerm (ssymTerm "c") (ssymTerm "d" :: Term Integer) (ssymTerm "b")) - @=? pevalITETerm - (pevalOrTerm (ssymTerm "a") (pevalNotTerm $ ssymTerm "c")) - (ssymTerm "b") - (ssymTerm "d"), - testCase "On both And" $ do - pevalITETerm - (ssymTerm "a") - (pevalAndTerm (ssymTerm "b") (ssymTerm "c")) - (pevalAndTerm (ssymTerm "b") (ssymTerm "d")) - @=? pevalAndTerm (ssymTerm "b") (pevalITETerm (ssymTerm "a") (ssymTerm "c") (ssymTerm "d")) - pevalITETerm - (ssymTerm "a") - (pevalAndTerm (ssymTerm "c") (ssymTerm "b")) - (pevalAndTerm (ssymTerm "b") (ssymTerm "d")) - @=? pevalAndTerm (ssymTerm "b") (pevalITETerm (ssymTerm "a") (ssymTerm "c") (ssymTerm "d")) - pevalITETerm - (ssymTerm "a") - (pevalAndTerm (ssymTerm "b") (ssymTerm "c")) - (pevalAndTerm (ssymTerm "d") (ssymTerm "b")) - @=? pevalAndTerm (ssymTerm "b") (pevalITETerm (ssymTerm "a") (ssymTerm "c") (ssymTerm "d")) - pevalITETerm - (ssymTerm "a") - (pevalAndTerm (ssymTerm "c") (ssymTerm "b")) - (pevalAndTerm (ssymTerm "d") (ssymTerm "b")) - @=? pevalAndTerm (ssymTerm "b") (pevalITETerm (ssymTerm "a") (ssymTerm "c") (ssymTerm "d")), - testCase "On left And" $ do - pevalITETerm - (ssymTerm "a") - (pevalAndTerm (ssymTerm "b") (ssymTerm "c")) - (ssymTerm "b") - @=? pevalAndTerm (ssymTerm "b") (pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "c")) - pevalITETerm - (ssymTerm "a") - (pevalAndTerm (ssymTerm "b") (ssymTerm "c")) - (ssymTerm "c") - @=? pevalAndTerm (ssymTerm "c") (pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")) - pevalITETerm - (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - (pevalAndTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) - (ssymTerm "c") - @=? pevalAndTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "c") - pevalITETerm - (ssymTerm "a") - (pevalAndTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b")) - (ssymTerm "c") - @=? pevalAndTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "c") - pevalITETerm - (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - (pevalAndTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) - (ssymTerm "c") - @=? pevalAndTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "c") - pevalITETerm - (ssymTerm "a") - (pevalAndTerm (ssymTerm "b") (pevalNotTerm $ ssymTerm "a")) - (ssymTerm "c") - @=? pevalAndTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "c") - pevalITETerm - (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - (pevalAndTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) - (ssymTerm "c") - @=? pevalITETerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b") (ssymTerm "c") - pevalITETerm - (ssymTerm "a") - (pevalAndTerm (ssymTerm "a") (ssymTerm "b")) - (ssymTerm "c") - @=? pevalITETerm (ssymTerm "a") (ssymTerm "b") (ssymTerm "c") - pevalITETerm - (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - (pevalAndTerm (ssymTerm "b") (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) - (ssymTerm "c") - @=? pevalITETerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b") (ssymTerm "c") - pevalITETerm - (ssymTerm "a") - (pevalAndTerm (ssymTerm "b") (ssymTerm "a")) - (ssymTerm "c") - @=? pevalITETerm (ssymTerm "a") (ssymTerm "b") (ssymTerm "c"), - testCase "On right And" $ do - pevalITETerm - (ssymTerm "a") - (ssymTerm "b") - (pevalAndTerm (ssymTerm "b") (ssymTerm "c")) - @=? pevalAndTerm (ssymTerm "b") (pevalOrTerm (ssymTerm "a") (ssymTerm "c")) - pevalITETerm - (ssymTerm "a") - (ssymTerm "c") - (pevalAndTerm (ssymTerm "b") (ssymTerm "c")) - @=? pevalAndTerm (ssymTerm "c") (pevalOrTerm (ssymTerm "a") (ssymTerm "b")), - testCase "On both Or" $ do - pevalITETerm - (ssymTerm "a") - (pevalOrTerm (ssymTerm "b") (ssymTerm "c")) - (pevalOrTerm (ssymTerm "b") (ssymTerm "d")) - @=? pevalOrTerm (ssymTerm "b") (pevalITETerm (ssymTerm "a") (ssymTerm "c") (ssymTerm "d")) - pevalITETerm - (ssymTerm "a") - (pevalOrTerm (ssymTerm "c") (ssymTerm "b")) - (pevalOrTerm (ssymTerm "b") (ssymTerm "d")) - @=? pevalOrTerm (ssymTerm "b") (pevalITETerm (ssymTerm "a") (ssymTerm "c") (ssymTerm "d")) - pevalITETerm - (ssymTerm "a") - (pevalOrTerm (ssymTerm "b") (ssymTerm "c")) - (pevalOrTerm (ssymTerm "d") (ssymTerm "b")) - @=? pevalOrTerm (ssymTerm "b") (pevalITETerm (ssymTerm "a") (ssymTerm "c") (ssymTerm "d")) - pevalITETerm - (ssymTerm "a") - (pevalOrTerm (ssymTerm "c") (ssymTerm "b")) - (pevalOrTerm (ssymTerm "d") (ssymTerm "b")) - @=? pevalOrTerm (ssymTerm "b") (pevalITETerm (ssymTerm "a") (ssymTerm "c") (ssymTerm "d")), - testCase "On left Or" $ do - pevalITETerm - (ssymTerm "a") - (pevalOrTerm (ssymTerm "b") (ssymTerm "c")) - (ssymTerm "b") - @=? pevalOrTerm (ssymTerm "b") (pevalAndTerm (ssymTerm "a") (ssymTerm "c")) - pevalITETerm - (ssymTerm "a") - (pevalOrTerm (ssymTerm "b") (ssymTerm "c")) - (ssymTerm "c") - @=? pevalOrTerm (ssymTerm "c") (pevalAndTerm (ssymTerm "a") (ssymTerm "b")) - pevalITETerm - (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - (pevalOrTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) - (ssymTerm "c") - @=? pevalITETerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b") (ssymTerm "c") - pevalITETerm - (ssymTerm "a") - (pevalOrTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b")) - (ssymTerm "c") - @=? pevalITETerm (ssymTerm "a") (ssymTerm "b") (ssymTerm "c") - pevalITETerm - (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - (pevalOrTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) - (ssymTerm "c") - @=? pevalITETerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b") (ssymTerm "c") - pevalITETerm - (ssymTerm "a") - (pevalOrTerm (ssymTerm "b") (pevalNotTerm $ ssymTerm "a")) - (ssymTerm "c") - @=? pevalITETerm (ssymTerm "a") (ssymTerm "b") (ssymTerm "c") - pevalITETerm - (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - (pevalOrTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) - (ssymTerm "c") - @=? pevalOrTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "c") - pevalITETerm - (ssymTerm "a") - (pevalOrTerm (ssymTerm "a") (ssymTerm "b")) - (ssymTerm "c") - @=? pevalOrTerm (ssymTerm "a") (ssymTerm "c") - pevalITETerm - (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - (pevalOrTerm (ssymTerm "b") (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) - (ssymTerm "c") - @=? pevalOrTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "c") - pevalITETerm - (ssymTerm "a") - (pevalOrTerm (ssymTerm "b") (ssymTerm "a")) - (ssymTerm "c") - @=? pevalOrTerm (ssymTerm "a") (ssymTerm "c"), - testCase "On right Or" $ do - pevalITETerm - (ssymTerm "a") - (ssymTerm "b") - (pevalOrTerm (ssymTerm "b") (ssymTerm "c")) - @=? pevalOrTerm (ssymTerm "b") (pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "c")) - pevalITETerm - (ssymTerm "a") - (ssymTerm "c") - (pevalOrTerm (ssymTerm "b") (ssymTerm "c")) - @=? pevalOrTerm (ssymTerm "c") (pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")), - testCase "On const boolean in branches" $ do - pevalITETerm - (ssymTerm "a") - (conTerm True) - (ssymTerm "b") - @=? pevalOrTerm (ssymTerm "a") (ssymTerm "b") - pevalITETerm - (ssymTerm "a") - (conTerm False) - (ssymTerm "b") - @=? pevalAndTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b") - pevalITETerm - (ssymTerm "a") - (ssymTerm "b") - (conTerm True) - @=? pevalOrTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b") - pevalITETerm - (ssymTerm "a") - (ssymTerm "b") - (conTerm False) - @=? pevalAndTerm (ssymTerm "a") (ssymTerm "b"), - testCase "On condition equal to some branch" $ do - pevalITETerm - (ssymTerm "a") - (ssymTerm "a") - (ssymTerm "b") - @=? pevalOrTerm (ssymTerm "a") (ssymTerm "b") - pevalITETerm - (ssymTerm "a") - (ssymTerm "b") - (ssymTerm "a") - @=? pevalAndTerm (ssymTerm "a") (ssymTerm "b"), - testCase "On left Not" $ do - pevalITETerm (ssymTerm "a") (pevalNotTerm (ssymTerm "a")) (ssymTerm "b") - @=? pevalAndTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b"), - testCase "On right Not" $ do - pevalITETerm (ssymTerm "a") (ssymTerm "b") (pevalNotTerm (ssymTerm "a")) - @=? pevalOrTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b"), - testCase "On left Not And" $ do - pevalITETerm - (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - (pevalNotTerm (pevalAndTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b"))) - (ssymTerm "c") - @=? pevalOrTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "c") - pevalITETerm - (ssymTerm "a") - (pevalNotTerm (pevalAndTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b"))) - (ssymTerm "c") - @=? pevalOrTerm (ssymTerm "a") (ssymTerm "c") - pevalITETerm - (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - (pevalNotTerm (pevalAndTerm (ssymTerm "b") (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)))) - (ssymTerm "c") - @=? pevalOrTerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "c") - pevalITETerm - (ssymTerm "a") - (pevalNotTerm (pevalAndTerm (ssymTerm "b") (pevalNotTerm $ ssymTerm "a"))) - (ssymTerm "c") - @=? pevalOrTerm (ssymTerm "a") (ssymTerm "c") - pevalITETerm - (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - (pevalNotTerm (pevalAndTerm (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b"))) - (ssymTerm "c") - @=? pevalITETerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (pevalNotTerm $ ssymTerm "b") (ssymTerm "c") - pevalITETerm - (ssymTerm "a") - (pevalNotTerm (pevalAndTerm (ssymTerm "a") (ssymTerm "b"))) - (ssymTerm "c") - @=? pevalITETerm (ssymTerm "a") (pevalNotTerm $ ssymTerm "b") (ssymTerm "c") - pevalITETerm - (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - (pevalNotTerm (pevalAndTerm (ssymTerm "b") (pevalNotEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 2)))) - (ssymTerm "c") - @=? pevalITETerm (pevalEqvTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (pevalNotTerm $ ssymTerm "b") (ssymTerm "c") - pevalITETerm - (ssymTerm "a") - (pevalNotTerm (pevalAndTerm (ssymTerm "b") (ssymTerm "a"))) - (ssymTerm "c") - @=? pevalITETerm (ssymTerm "a") (pevalNotTerm $ ssymTerm "b") (ssymTerm "c") - ], - testGroup - "Imply" - [ testCase "pevalImplyTerm" $ do - ssymTerm "a" - `pevalImplyTerm` ssymTerm "b" - @=? pevalOrTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b") - ], - testGroup - "Xor" - [ testCase "pevalXorTerm" $ do - ssymTerm "a" - `pevalXorTerm` ssymTerm "b" - @=? pevalOrTerm - (pevalAndTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b")) - (pevalAndTerm (ssymTerm "a") (pevalNotTerm $ ssymTerm "b")) - ] - ] diff --git a/test/Grisette/IR/SymPrim/Data/Prim/IntegralTests.hs b/test/Grisette/IR/SymPrim/Data/Prim/IntegralTests.hs deleted file mode 100644 --- a/test/Grisette/IR/SymPrim/Data/Prim/IntegralTests.hs +++ /dev/null @@ -1,191 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - -module Grisette.IR.SymPrim.Data.Prim.IntegralTests (integralTests) where - -import Control.DeepSeq (NFData (rnf), force) -import Control.Exception (ArithException, catch, evaluate) -import Data.Proxy (Proxy (Proxy)) -import Grisette.Core.Data.BV (IntN (IntN), WordN (WordN)) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors - ( conTerm, - divBoundedIntegralTerm, - divIntegralTerm, - modIntegralTerm, - quotBoundedIntegralTerm, - quotIntegralTerm, - remIntegralTerm, - ssymTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term - ( SupportedPrim, - Term, - ) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.Integral - ( pevalDivBoundedIntegralTerm, - pevalDivIntegralTerm, - pevalModIntegralTerm, - pevalQuotBoundedIntegralTerm, - pevalQuotIntegralTerm, - pevalRemIntegralTerm, - ) -import Test.Framework (Test, TestName, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.HUnit ((@=?)) -import Test.QuickCheck (Arbitrary, ioProperty) - -newtype AEWrapper = AEWrapper ArithException deriving (Eq) - -instance Show AEWrapper where - show (AEWrapper x) = show x - -instance NFData AEWrapper where - rnf (AEWrapper x) = x `seq` () - -sameDivPeval :: - forall t. - (Num t, Eq t, SupportedPrim t, Integral t) => - t -> - t -> - (Term t -> Term t -> Term t) -> - (t -> t -> t) -> - (Term t -> Term t -> Term t) -> - IO () -sameDivPeval i j pf cf consf = do - cx <- evaluate (force $ Right $ cf i j) `catch` \(_ :: ArithException) -> return $ Left AEWrapper - case cx of - Left _ -> pf (conTerm i) (conTerm j) @=? consf (conTerm i) (conTerm j) - Right t -> pf (conTerm i) (conTerm j) @=? conTerm t - -divisionPevalBoundedTests :: - forall p t. - (Num t, Eq t, Bounded t, SupportedPrim t, Integral t) => - p t -> - TestName -> - (Term t -> Term t -> Term t) -> - (t -> t -> t) -> - (Term t -> Term t -> Term t) -> - Test -divisionPevalBoundedTests _ name pf cf consf = - testGroup - name - [ testCase "On concrete min divide by -1" $ - sameDivPeval minBound (-1) pf cf consf - ] - -divisionPevalTests :: - forall p t0 t. - (Num t, Eq t, Arbitrary t0, Show t0, SupportedPrim t, Integral t) => - p t -> - TestName -> - (t0 -> t) -> - (Term t -> Term t -> Term t) -> - (t -> t -> t) -> - (Term t -> Term t -> Term t) -> - Test -divisionPevalTests _ name transform pf cf consf = - testGroup - name - [ testProperty "On concrete prop" $ - ioProperty . \(i0 :: t0, j0 :: t0) -> do - let i = transform i0 - let j = transform j0 - sameDivPeval i j pf cf consf, - testProperty "On concrete divide by 0" $ - ioProperty . \(i0 :: t0) -> do - let i = transform i0 - sameDivPeval i 0 pf cf consf, - testCase "divide by 1" $ do - pf (ssymTerm "a" :: Term t) (conTerm 1) @=? ssymTerm "a", - testCase "On symbolic" $ do - pf (ssymTerm "a" :: Term t) (ssymTerm "b") - @=? consf (ssymTerm "a" :: Term t) (ssymTerm "b" :: Term t) - ] - -divisionPevalBoundedTestGroup :: - TestName -> - (forall t. (SupportedPrim t, Bounded t, Integral t) => Term t -> Term t -> Term t) -> - (forall t. (Bounded t, Integral t) => t -> t -> t) -> - (forall t. (SupportedPrim t, Bounded t, Integral t) => Term t -> Term t -> Term t) -> - Test -divisionPevalBoundedTestGroup name pf cf consf = - testGroup - name - [ divisionPevalTests (Proxy @(IntN 4)) "IntN" IntN pf cf consf, - divisionPevalBoundedTests (Proxy @(IntN 4)) "IntN Bounded" pf cf consf - ] - -divisionPevalUnboundedTestGroup :: - TestName -> - (forall t. (SupportedPrim t, Integral t) => Term t -> Term t -> Term t) -> - (forall t. (Integral t) => t -> t -> t) -> - (forall t. (SupportedPrim t, Integral t) => Term t -> Term t -> Term t) -> - Test -divisionPevalUnboundedTestGroup name pf cf consf = - testGroup - name - [ divisionPevalTests (Proxy @Integer) "Integer" id pf cf consf, - divisionPevalTests (Proxy @(WordN 4)) "WordN" WordN pf cf consf, - divisionPevalBoundedTests (Proxy @(WordN 4)) "WordN Bounded" pf cf consf - ] - -moduloPevalTests :: - forall p t0 t. - (Num t, Eq t, Arbitrary t0, Show t0, SupportedPrim t, Integral t) => - p t -> - TestName -> - (t0 -> t) -> - (Term t -> Term t -> Term t) -> - (t -> t -> t) -> - (Term t -> Term t -> Term t) -> - Test -moduloPevalTests _ name transform pf cf consf = - testGroup - name - [ testProperty "On concrete" $ - ioProperty . \(i0 :: t0, j0 :: t0) -> do - let i = transform i0 - let j = transform j0 - sameDivPeval i j pf cf consf, - testProperty "On concrete divide by 0" $ - ioProperty . \(i0 :: t0) -> do - let i = transform i0 - sameDivPeval i 0 pf cf consf, - testCase "mod by 1" $ do - pf (ssymTerm "a" :: Term t) (conTerm 1) @=? conTerm 0, - testCase "mod by -1" $ do - pf (ssymTerm "a" :: Term t) (conTerm $ -1) @=? conTerm 0, - testCase "On symbolic" $ do - pf (ssymTerm "a" :: Term t) (ssymTerm "b") - @=? consf (ssymTerm "a" :: Term t) (ssymTerm "b" :: Term t) - ] - -moduloPevalTestGroup :: - TestName -> - (forall t. (SupportedPrim t, Integral t) => Term t -> Term t -> Term t) -> - (forall t. (Integral t) => t -> t -> t) -> - (forall t. (SupportedPrim t, Integral t) => Term t -> Term t -> Term t) -> - Test -moduloPevalTestGroup name pf cf consf = - testGroup - name - [ moduloPevalTests (Proxy @Integer) "Integer" id pf cf consf, - moduloPevalTests (Proxy @(IntN 4)) "IntN" IntN pf cf consf, - moduloPevalTests (Proxy @(WordN 4)) "WordN" WordN pf cf consf - ] - -integralTests :: Test -integralTests = - testGroup - "Integral" - [ divisionPevalUnboundedTestGroup "Div unbounded" pevalDivIntegralTerm div divIntegralTerm, - divisionPevalUnboundedTestGroup "Quot unbounded" pevalQuotIntegralTerm quot quotIntegralTerm, - divisionPevalBoundedTestGroup "Div bounded" pevalDivBoundedIntegralTerm div divBoundedIntegralTerm, - divisionPevalBoundedTestGroup "Quot bounded" pevalQuotBoundedIntegralTerm quot quotBoundedIntegralTerm, - moduloPevalTestGroup "Mod" pevalModIntegralTerm mod modIntegralTerm, - moduloPevalTestGroup "Rem" pevalRemIntegralTerm rem remIntegralTerm - ] diff --git a/test/Grisette/IR/SymPrim/Data/Prim/ModelTests.hs b/test/Grisette/IR/SymPrim/Data/Prim/ModelTests.hs deleted file mode 100644 --- a/test/Grisette/IR/SymPrim/Data/Prim/ModelTests.hs +++ /dev/null @@ -1,282 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Grisette.IR.SymPrim.Data.Prim.ModelTests (modelTests) where - -import qualified Data.HashMap.Strict as M -import qualified Data.HashSet as S -import Grisette.Core.Data.BV (IntN, WordN) -import Grisette.Core.Data.Class.ModelOps - ( ModelOps - ( emptyModel, - exact, - exceptFor, - extendTo, - insertValue, - restrictTo, - valueOf - ), - ModelRep (buildModel), - ) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors - ( conTerm, - ssymTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term - ( Term, - TypedSymbol (SimpleSymbol), - someTypedSymbol, - ) -import Grisette.IR.SymPrim.Data.Prim.Model - ( Model (Model), - ModelValuePair ((::=)), - SymbolSet (SymbolSet), - equation, - evaluateTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.ModelValue (toModelValue) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool - ( pevalEqvTerm, - pevalITETerm, - ) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.Num - ( pevalAddNumTerm, - pevalUMinusNumTerm, - ) -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit ((@=?)) - -modelTests :: Test -modelTests = - let asymbol :: TypedSymbol Integer = SimpleSymbol "a" - bsymbol :: TypedSymbol Bool = SimpleSymbol "b" - csymbol :: TypedSymbol Integer = SimpleSymbol "c" - dsymbol :: TypedSymbol Bool = SimpleSymbol "d" - esymbol :: TypedSymbol (WordN 4) = SimpleSymbol "e" - fsymbol :: TypedSymbol (IntN 4) = SimpleSymbol "f" - gsymbol :: TypedSymbol (WordN 16) = SimpleSymbol "g" - hsymbol :: TypedSymbol (IntN 16) = SimpleSymbol "h" - m1 = emptyModel - m2 = insertValue asymbol 1 m1 - m3 = insertValue bsymbol True m2 - in testGroup - "Model" - [ testCase "empty model is really empty" $ do - emptyModel @=? Model M.empty, - testCase "inserting to model" $ do - m3 - @=? Model - ( M.fromList - [ (someTypedSymbol asymbol, toModelValue (1 :: Integer)), - (someTypedSymbol bsymbol, toModelValue True) - ] - ), - testCase "equation" $ do - equation asymbol m3 @=? Just (pevalEqvTerm (ssymTerm "a") (conTerm 1 :: Term Integer)) - equation bsymbol m3 @=? Just (pevalEqvTerm (ssymTerm "b") (conTerm True)) - equation csymbol m3 @=? Nothing, - testCase "valueOf" $ do - valueOf asymbol m3 @=? Just (1 :: Integer) - valueOf bsymbol m3 @=? Just True - valueOf csymbol m3 @=? (Nothing :: Maybe Integer), - testCase "exceptFor" $ do - exceptFor (SymbolSet $ S.fromList [someTypedSymbol asymbol]) m3 - @=? Model - ( M.fromList - [ (someTypedSymbol bsymbol, toModelValue True) - ] - ), - testCase "restrictTo" $ do - restrictTo (SymbolSet $ S.fromList [someTypedSymbol asymbol]) m3 - @=? Model - ( M.fromList - [ (someTypedSymbol asymbol, toModelValue (1 :: Integer)) - ] - ), - testCase "extendTo" $ do - extendTo - ( SymbolSet $ - S.fromList - [ someTypedSymbol csymbol, - someTypedSymbol dsymbol, - someTypedSymbol esymbol, - someTypedSymbol fsymbol - ] - ) - m3 - @=? Model - ( M.fromList - [ (someTypedSymbol asymbol, toModelValue (1 :: Integer)), - (someTypedSymbol bsymbol, toModelValue True), - (someTypedSymbol csymbol, toModelValue (0 :: Integer)), - (someTypedSymbol dsymbol, toModelValue False), - (someTypedSymbol esymbol, toModelValue (0 :: WordN 4)), - (someTypedSymbol fsymbol, toModelValue (0 :: IntN 4)) - ] - ), - testCase "exact" $ do - exact - ( SymbolSet $ - S.fromList - [ someTypedSymbol asymbol, - someTypedSymbol csymbol - ] - ) - m3 - @=? Model - ( M.fromList - [ (someTypedSymbol asymbol, toModelValue (1 :: Integer)), - (someTypedSymbol csymbol, toModelValue (0 :: Integer)) - ] - ), - testCase "evaluateTerm" $ do - evaluateTerm False m3 (conTerm (1 :: Integer)) @=? conTerm 1 - evaluateTerm True m3 (conTerm (1 :: Integer)) @=? conTerm 1 - evaluateTerm False m3 (ssymTerm "a" :: Term Integer) @=? conTerm 1 - evaluateTerm True m3 (ssymTerm "a" :: Term Integer) @=? conTerm 1 - evaluateTerm False m3 (ssymTerm "x" :: Term Integer) @=? ssymTerm "x" - evaluateTerm True m3 (ssymTerm "x" :: Term Integer) @=? conTerm 0 - evaluateTerm False m3 (ssymTerm "y" :: Term Bool) @=? ssymTerm "y" - evaluateTerm True m3 (ssymTerm "y" :: Term Bool) @=? conTerm False - evaluateTerm False m3 (ssymTerm "z" :: Term (WordN 4)) @=? ssymTerm "z" - evaluateTerm True m3 (ssymTerm "z" :: Term (WordN 4)) @=? conTerm 0 - evaluateTerm False m3 (pevalUMinusNumTerm $ ssymTerm "a" :: Term Integer) @=? conTerm (-1) - evaluateTerm True m3 (pevalUMinusNumTerm $ ssymTerm "a" :: Term Integer) @=? conTerm (-1) - evaluateTerm False m3 (pevalUMinusNumTerm $ ssymTerm "x" :: Term Integer) @=? pevalUMinusNumTerm (ssymTerm "x") - evaluateTerm True m3 (pevalUMinusNumTerm $ ssymTerm "x" :: Term Integer) @=? conTerm 0 - evaluateTerm False m3 (pevalAddNumTerm (ssymTerm "a") (ssymTerm "a") :: Term Integer) @=? conTerm 2 - evaluateTerm True m3 (pevalAddNumTerm (ssymTerm "a") (ssymTerm "a") :: Term Integer) @=? conTerm 2 - evaluateTerm False m3 (pevalAddNumTerm (ssymTerm "x") (ssymTerm "a") :: Term Integer) @=? pevalAddNumTerm (conTerm 1) (ssymTerm "x") - evaluateTerm True m3 (pevalAddNumTerm (ssymTerm "x") (ssymTerm "a") :: Term Integer) @=? conTerm 1 - evaluateTerm False m3 (pevalAddNumTerm (ssymTerm "x") (ssymTerm "y") :: Term Integer) @=? pevalAddNumTerm (ssymTerm "x") (ssymTerm "y") - evaluateTerm True m3 (pevalAddNumTerm (ssymTerm "x") (ssymTerm "y") :: Term Integer) @=? conTerm 0 - evaluateTerm False m3 (pevalITETerm (ssymTerm "b") (pevalAddNumTerm (ssymTerm "a") (ssymTerm "a")) (ssymTerm "a") :: Term Integer) - @=? conTerm 2 - evaluateTerm True m3 (pevalITETerm (ssymTerm "b") (pevalAddNumTerm (ssymTerm "a") (ssymTerm "a")) (ssymTerm "a") :: Term Integer) - @=? conTerm 2 - evaluateTerm False m3 (pevalITETerm (ssymTerm "x") (pevalAddNumTerm (ssymTerm "a") (ssymTerm "a")) (ssymTerm "a") :: Term Integer) - @=? pevalITETerm (ssymTerm "x") (conTerm 2) (conTerm 1) - evaluateTerm True m3 (pevalITETerm (ssymTerm "x") (pevalAddNumTerm (ssymTerm "a") (ssymTerm "a")) (ssymTerm "a") :: Term Integer) - @=? conTerm 1 - evaluateTerm False m3 (pevalITETerm (ssymTerm "b") (ssymTerm "x") (pevalAddNumTerm (conTerm 1) (ssymTerm "y")) :: Term Integer) - @=? ssymTerm "x" - evaluateTerm True m3 (pevalITETerm (ssymTerm "b") (ssymTerm "x") (pevalAddNumTerm (conTerm 1) (ssymTerm "y")) :: Term Integer) - @=? conTerm 0 - evaluateTerm False m3 (pevalITETerm (ssymTerm "z") (ssymTerm "x") (pevalAddNumTerm (conTerm 1) (ssymTerm "y")) :: Term Integer) - @=? pevalITETerm (ssymTerm "z") (ssymTerm "x") (pevalAddNumTerm (conTerm 1) (ssymTerm "y")) - evaluateTerm True m3 (pevalITETerm (ssymTerm "z") (ssymTerm "x") (pevalAddNumTerm (conTerm 1) (ssymTerm "y")) :: Term Integer) - @=? conTerm 1, - testCase "construction from ModelValuePair" $ do - buildModel (asymbol ::= 1) @=? Model (M.singleton (someTypedSymbol asymbol) (toModelValue (1 :: Integer))) - buildModel (asymbol ::= 1, bsymbol ::= True) - @=? Model - ( M.fromList - [ (someTypedSymbol asymbol, toModelValue (1 :: Integer)), - (someTypedSymbol bsymbol, toModelValue True) - ] - ) - buildModel - ( asymbol ::= 1, - bsymbol ::= True, - csymbol ::= 2 - ) - @=? Model - ( M.fromList - [ (someTypedSymbol asymbol, toModelValue (1 :: Integer)), - (someTypedSymbol bsymbol, toModelValue True), - (someTypedSymbol csymbol, toModelValue (2 :: Integer)) - ] - ) - buildModel - ( asymbol ::= 1, - bsymbol ::= True, - csymbol ::= 2, - dsymbol ::= False - ) - @=? Model - ( M.fromList - [ (someTypedSymbol asymbol, toModelValue (1 :: Integer)), - (someTypedSymbol bsymbol, toModelValue True), - (someTypedSymbol csymbol, toModelValue (2 :: Integer)), - (someTypedSymbol dsymbol, toModelValue False) - ] - ) - buildModel - ( asymbol ::= 1, - bsymbol ::= True, - csymbol ::= 2, - dsymbol ::= False, - esymbol ::= 3 - ) - @=? Model - ( M.fromList - [ (someTypedSymbol asymbol, toModelValue (1 :: Integer)), - (someTypedSymbol bsymbol, toModelValue True), - (someTypedSymbol csymbol, toModelValue (2 :: Integer)), - (someTypedSymbol dsymbol, toModelValue False), - (someTypedSymbol esymbol, toModelValue (3 :: WordN 4)) - ] - ) - buildModel - ( asymbol ::= 1, - bsymbol ::= True, - csymbol ::= 2, - dsymbol ::= False, - esymbol ::= 3, - fsymbol ::= 4 - ) - @=? Model - ( M.fromList - [ (someTypedSymbol asymbol, toModelValue (1 :: Integer)), - (someTypedSymbol bsymbol, toModelValue True), - (someTypedSymbol csymbol, toModelValue (2 :: Integer)), - (someTypedSymbol dsymbol, toModelValue False), - (someTypedSymbol esymbol, toModelValue (3 :: WordN 4)), - (someTypedSymbol fsymbol, toModelValue (4 :: IntN 4)) - ] - ) - buildModel - ( asymbol ::= 1, - bsymbol ::= True, - csymbol ::= 2, - dsymbol ::= False, - esymbol ::= 3, - fsymbol ::= 4, - gsymbol ::= 5 - ) - @=? Model - ( M.fromList - [ (someTypedSymbol asymbol, toModelValue (1 :: Integer)), - (someTypedSymbol bsymbol, toModelValue True), - (someTypedSymbol csymbol, toModelValue (2 :: Integer)), - (someTypedSymbol dsymbol, toModelValue False), - (someTypedSymbol esymbol, toModelValue (3 :: WordN 4)), - (someTypedSymbol fsymbol, toModelValue (4 :: IntN 4)), - (someTypedSymbol gsymbol, toModelValue (5 :: WordN 16)) - ] - ) - buildModel - ( asymbol ::= 1, - bsymbol ::= True, - csymbol ::= 2, - dsymbol ::= False, - esymbol ::= 3, - fsymbol ::= 4, - gsymbol ::= 5, - hsymbol ::= 6 - ) - @=? Model - ( M.fromList - [ (someTypedSymbol asymbol, toModelValue (1 :: Integer)), - (someTypedSymbol bsymbol, toModelValue True), - (someTypedSymbol csymbol, toModelValue (2 :: Integer)), - (someTypedSymbol dsymbol, toModelValue False), - (someTypedSymbol esymbol, toModelValue (3 :: WordN 4)), - (someTypedSymbol fsymbol, toModelValue (4 :: IntN 4)), - (someTypedSymbol gsymbol, toModelValue (5 :: WordN 16)), - (someTypedSymbol hsymbol, toModelValue (6 :: IntN 16)) - ] - ) - ] diff --git a/test/Grisette/IR/SymPrim/Data/Prim/NumTests.hs b/test/Grisette/IR/SymPrim/Data/Prim/NumTests.hs deleted file mode 100644 --- a/test/Grisette/IR/SymPrim/Data/Prim/NumTests.hs +++ /dev/null @@ -1,408 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Grisette.IR.SymPrim.Data.Prim.NumTests (numTests) where - -import Grisette.Core.Data.BV (IntN, WordN) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors - ( absNumTerm, - addNumTerm, - conTerm, - leNumTerm, - ltNumTerm, - signumNumTerm, - ssymTerm, - timesNumTerm, - uminusNumTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term (Term) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool - ( pevalITETerm, - ) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.Num - ( pevalAbsNumTerm, - pevalAddNumTerm, - pevalGeNumTerm, - pevalGtNumTerm, - pevalLeNumTerm, - pevalLtNumTerm, - pevalMinusNumTerm, - pevalSignumNumTerm, - pevalTimesNumTerm, - pevalUMinusNumTerm, - ) -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit ((@=?)) - -numTests :: Test -numTests = - testGroup - "Num" - [ testGroup - "Add" - [ testCase "On concrete" $ do - pevalAddNumTerm (conTerm 1 :: Term Integer) (conTerm 2) @=? conTerm 3 - pevalAddNumTerm (conTerm 1 :: Term (WordN 3)) (conTerm 2) @=? conTerm 3 - pevalAddNumTerm (conTerm 1 :: Term (IntN 3)) (conTerm 2) @=? conTerm 3, - testCase "On left 0" $ do - pevalAddNumTerm (conTerm 0 :: Term Integer) (ssymTerm "a") @=? ssymTerm "a", - testCase "On right 0" $ do - pevalAddNumTerm (ssymTerm "a") (conTerm 0 :: Term Integer) @=? ssymTerm "a", - testCase "On left concrete" $ do - pevalAddNumTerm (conTerm 1 :: Term Integer) (ssymTerm "a") - @=? addNumTerm (conTerm 1 :: Term Integer) (ssymTerm "a" :: Term Integer), - testCase "On right concrete" $ do - pevalAddNumTerm (ssymTerm "a") (conTerm 1 :: Term Integer) - @=? addNumTerm (conTerm 1 :: Term Integer) (ssymTerm "a" :: Term Integer), - testCase "On no concrete" $ do - pevalAddNumTerm (ssymTerm "a") (ssymTerm "b" :: Term Integer) - @=? addNumTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b" :: Term Integer), - testCase "On left concrete and right add concrete value" $ do - pevalAddNumTerm (conTerm 1 :: Term Integer) (pevalAddNumTerm (conTerm 2 :: Term Integer) (ssymTerm "a")) - @=? pevalAddNumTerm (conTerm 3 :: Term Integer) (ssymTerm "a"), - testCase "On right concrete and left add concrete value" $ do - pevalAddNumTerm (pevalAddNumTerm (conTerm 2 :: Term Integer) (ssymTerm "a")) (conTerm 1 :: Term Integer) - @=? pevalAddNumTerm (conTerm 3 :: Term Integer) (ssymTerm "a"), - testCase "On left add concrete" $ do - pevalAddNumTerm (pevalAddNumTerm (conTerm 2 :: Term Integer) (ssymTerm "a")) (ssymTerm "b") - @=? pevalAddNumTerm (conTerm 2 :: Term Integer) (pevalAddNumTerm (ssymTerm "a") (ssymTerm "b")), - testCase "On right add concrete" $ do - pevalAddNumTerm (ssymTerm "b") (pevalAddNumTerm (conTerm 2 :: Term Integer) (ssymTerm "a")) - @=? pevalAddNumTerm (conTerm 2 :: Term Integer) (pevalAddNumTerm (ssymTerm "b") (ssymTerm "a")), - testCase "On both uminus" $ do - pevalAddNumTerm (pevalUMinusNumTerm $ ssymTerm "a" :: Term Integer) (pevalUMinusNumTerm $ ssymTerm "b") - @=? pevalUMinusNumTerm (pevalAddNumTerm (ssymTerm "a") (ssymTerm "b")), - testCase "On both times the same concrete" $ do - pevalAddNumTerm - (pevalTimesNumTerm (conTerm 3) (ssymTerm "a") :: Term Integer) - (pevalTimesNumTerm (conTerm 3) (ssymTerm "b")) - @=? pevalTimesNumTerm (conTerm 3) (pevalAddNumTerm (ssymTerm "a") (ssymTerm "b")), - testCase "On both times the same symbolic" $ do - pevalAddNumTerm - (pevalTimesNumTerm (conTerm 3) (ssymTerm "a") :: Term Integer) - (pevalTimesNumTerm (conTerm 3) (ssymTerm "a")) - @=? pevalTimesNumTerm (conTerm 6) (ssymTerm "a") - pevalAddNumTerm - (pevalTimesNumTerm (conTerm 3) (ssymTerm "a") :: Term Integer) - (pevalTimesNumTerm (conTerm 4) (ssymTerm "a")) - @=? pevalTimesNumTerm (conTerm 7) (ssymTerm "a"), - testCase "Unfold 1" $ do - pevalAddNumTerm - (conTerm 3) - (pevalITETerm (ssymTerm "a") (conTerm 1 :: Term Integer) (ssymTerm "a")) - @=? pevalITETerm (ssymTerm "a") (conTerm 4) (pevalAddNumTerm (conTerm 3) (ssymTerm "a")) - pevalAddNumTerm - (pevalITETerm (ssymTerm "a") (conTerm 1 :: Term Integer) (ssymTerm "a")) - (conTerm 3) - @=? pevalITETerm (ssymTerm "a") (conTerm 4) (pevalAddNumTerm (ssymTerm "a") (conTerm 3)) - ], - testGroup - "minus" - [ testCase "minus num should be delegated to add and uminus" $ do - pevalMinusNumTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b") - @=? pevalAddNumTerm (ssymTerm "a") (pevalUMinusNumTerm $ ssymTerm "b") - ], - testGroup - "UMinus" - [ testCase "On concrete" $ do - pevalUMinusNumTerm (conTerm 1 :: Term Integer) @=? conTerm (-1) - pevalUMinusNumTerm (conTerm 1 :: Term (WordN 3)) @=? conTerm (-1), - testCase "On UMinus" $ do - pevalUMinusNumTerm (pevalUMinusNumTerm (ssymTerm "a" :: Term Integer)) @=? ssymTerm "a", - testCase "On Add concrete" $ do - pevalUMinusNumTerm (pevalAddNumTerm (conTerm 1) (ssymTerm "a" :: Term Integer)) - @=? pevalAddNumTerm (conTerm $ -1) (pevalUMinusNumTerm $ ssymTerm "a"), - testCase "On Add uminus" $ do - pevalUMinusNumTerm (pevalAddNumTerm (pevalUMinusNumTerm $ ssymTerm "a") (ssymTerm "b" :: Term Integer)) - @=? pevalAddNumTerm (ssymTerm "a") (pevalUMinusNumTerm $ ssymTerm "b") - pevalUMinusNumTerm (pevalAddNumTerm (ssymTerm "a") (pevalUMinusNumTerm $ ssymTerm "b" :: Term Integer)) - @=? pevalAddNumTerm (pevalUMinusNumTerm $ ssymTerm "a") (ssymTerm "b"), - testCase "On Times concrete" $ do - pevalUMinusNumTerm (pevalTimesNumTerm (conTerm 3) (ssymTerm "a" :: Term Integer)) - @=? pevalTimesNumTerm (conTerm $ -3) (ssymTerm "a"), - testCase "On symbolic" $ do - pevalUMinusNumTerm (ssymTerm "a" :: Term Integer) - @=? uminusNumTerm (ssymTerm "a") - ], - testGroup - "Times" - [ testCase "On both concrete" $ do - pevalTimesNumTerm (conTerm 3 :: Term Integer) (conTerm 5) - @=? conTerm 15, - testCase "On left 0" $ do - pevalTimesNumTerm (conTerm 0 :: Term Integer) (ssymTerm "a") - @=? conTerm 0, - testCase "On right 0" $ do - pevalTimesNumTerm (ssymTerm "a") (conTerm 0 :: Term Integer) - @=? conTerm 0, - testCase "On left 1" $ do - pevalTimesNumTerm (conTerm 1 :: Term Integer) (ssymTerm "a") - @=? ssymTerm "a", - testCase "On right 1" $ do - pevalTimesNumTerm (ssymTerm "a") (conTerm 1 :: Term Integer) - @=? ssymTerm "a", - testCase "On left -1" $ do - pevalTimesNumTerm (conTerm $ -1 :: Term Integer) (ssymTerm "a") - @=? pevalUMinusNumTerm (ssymTerm "a"), - testCase "On right -1" $ do - pevalTimesNumTerm (ssymTerm "a") (conTerm $ -1 :: Term Integer) - @=? pevalUMinusNumTerm (ssymTerm "a"), - testCase "On left concrete and right times concrete symbolics" $ do - pevalTimesNumTerm (conTerm 3) (pevalTimesNumTerm (conTerm 5 :: Term Integer) (ssymTerm "a")) - @=? pevalTimesNumTerm (conTerm 15) (ssymTerm "a"), - testCase "On right concrete and left times concrete symbolics" $ do - pevalTimesNumTerm (pevalTimesNumTerm (conTerm 5 :: Term Integer) (ssymTerm "a")) (conTerm 3) - @=? pevalTimesNumTerm (conTerm 15) (ssymTerm "a"), - testCase "On left concrete and right add concrete symbolics" $ do - pevalTimesNumTerm (conTerm 3) (pevalAddNumTerm (conTerm 5 :: Term Integer) (ssymTerm "a")) - @=? pevalAddNumTerm (conTerm 15) (pevalTimesNumTerm (conTerm 3) (ssymTerm "a")), - testCase "On right concrete and left add concrete symbolics" $ do - pevalTimesNumTerm (pevalAddNumTerm (conTerm 5 :: Term Integer) (ssymTerm "a")) (conTerm 3) - @=? pevalAddNumTerm (conTerm 15) (pevalTimesNumTerm (conTerm 3) (ssymTerm "a")), - testCase "On left concrete and right uminus" $ do - pevalTimesNumTerm (conTerm 3 :: Term Integer) (pevalUMinusNumTerm (ssymTerm "a")) - @=? pevalTimesNumTerm (conTerm $ -3) (ssymTerm "a"), - testCase "On left times concrete symbolics" $ do - pevalTimesNumTerm (pevalTimesNumTerm (conTerm 3 :: Term Integer) (ssymTerm "a")) (ssymTerm "b") - @=? pevalTimesNumTerm (conTerm 3) (pevalTimesNumTerm (ssymTerm "a") (ssymTerm "b")), - testCase "On right times concrete symbolics" $ do - pevalTimesNumTerm (ssymTerm "b") (pevalTimesNumTerm (conTerm 3 :: Term Integer) (ssymTerm "a")) - @=? pevalTimesNumTerm (conTerm 3) (pevalTimesNumTerm (ssymTerm "b") (ssymTerm "a")), - testCase "On left uminus" $ do - pevalTimesNumTerm (pevalUMinusNumTerm $ ssymTerm "a") (ssymTerm "b" :: Term Integer) - @=? pevalUMinusNumTerm (pevalTimesNumTerm (ssymTerm "a") (ssymTerm "b")), - testCase "On right uminus" $ do - pevalTimesNumTerm (ssymTerm "a") (pevalUMinusNumTerm $ ssymTerm "b" :: Term Integer) - @=? pevalUMinusNumTerm (pevalTimesNumTerm (ssymTerm "a") (ssymTerm "b")), - testCase "On right concrete and left uminus" $ do - pevalTimesNumTerm (pevalUMinusNumTerm (ssymTerm "a")) (conTerm 3 :: Term Integer) - @=? pevalTimesNumTerm (conTerm $ -3) (ssymTerm "a"), - testCase "On left concrete" $ do - pevalTimesNumTerm (conTerm 3 :: Term Integer) (ssymTerm "a") - @=? timesNumTerm - (conTerm 3 :: Term Integer) - (ssymTerm "a" :: Term Integer), - testCase "On right concrete" $ do - pevalTimesNumTerm (ssymTerm "a") (conTerm 3 :: Term Integer) - @=? timesNumTerm - (conTerm 3 :: Term Integer) - (ssymTerm "a" :: Term Integer), - testCase "On no concrete" $ do - pevalTimesNumTerm (ssymTerm "a") (ssymTerm "b" :: Term Integer) - @=? timesNumTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b" :: Term Integer), - testCase "Unfold 1" $ do - pevalTimesNumTerm - (conTerm 3) - (pevalITETerm (ssymTerm "a") (conTerm 5 :: Term Integer) (ssymTerm "a")) - @=? pevalITETerm (ssymTerm "a") (conTerm 15) (pevalTimesNumTerm (conTerm 3) (ssymTerm "a")) - pevalTimesNumTerm - (pevalITETerm (ssymTerm "a") (conTerm 5 :: Term Integer) (ssymTerm "a")) - (conTerm 3) - @=? pevalITETerm (ssymTerm "a") (conTerm 15) (pevalTimesNumTerm (ssymTerm "a") (conTerm 3)) - ], - testGroup - "Abs" - [ testCase "On concrete" $ do - pevalAbsNumTerm (conTerm 10 :: Term Integer) @=? conTerm 10 - pevalAbsNumTerm (conTerm $ -10 :: Term Integer) @=? conTerm 10, - testCase "On UMinus Integer" $ do - pevalAbsNumTerm (pevalUMinusNumTerm $ ssymTerm "a" :: Term Integer) @=? pevalAbsNumTerm (ssymTerm "a"), - testCase "On UMinus BV" $ do - pevalAbsNumTerm (pevalUMinusNumTerm $ ssymTerm "a" :: Term (IntN 5)) @=? pevalAbsNumTerm (ssymTerm "a") - pevalAbsNumTerm (pevalUMinusNumTerm $ ssymTerm "a" :: Term (WordN 5)) @=? uminusNumTerm (ssymTerm "a"), - testCase "On Abs Integer" $ do - pevalAbsNumTerm (pevalAbsNumTerm $ ssymTerm "a" :: Term Integer) @=? pevalAbsNumTerm (ssymTerm "a"), - testCase "On Abs BV" $ do - pevalAbsNumTerm (pevalAbsNumTerm $ ssymTerm "a" :: Term (IntN 5)) @=? pevalAbsNumTerm (ssymTerm "a") - pevalAbsNumTerm (pevalAbsNumTerm $ ssymTerm "a" :: Term (WordN 5)) @=? ssymTerm "a", - testCase "On Times Integer" $ do - pevalAbsNumTerm (pevalTimesNumTerm (ssymTerm "a") (ssymTerm "b") :: Term Integer) - @=? pevalTimesNumTerm (pevalAbsNumTerm (ssymTerm "a")) (pevalAbsNumTerm (ssymTerm "b")), - testCase "On Times BV" $ do - pevalAbsNumTerm (pevalTimesNumTerm (ssymTerm "a") (ssymTerm "b") :: Term (IntN 5)) - @=? absNumTerm (pevalTimesNumTerm (ssymTerm "a") (ssymTerm "b") :: Term (IntN 5)) - pevalAbsNumTerm (pevalTimesNumTerm (ssymTerm "a") (ssymTerm "b") :: Term (WordN 5)) - @=? pevalTimesNumTerm (ssymTerm "a") (ssymTerm "b"), - testCase "On symbolic Integer" $ do - pevalAbsNumTerm (ssymTerm "a" :: Term Integer) - @=? absNumTerm (ssymTerm "a"), - testCase "On symbolic BV" $ do - pevalAbsNumTerm (ssymTerm "a" :: Term (IntN 5)) @=? absNumTerm (ssymTerm "a") - pevalAbsNumTerm (ssymTerm "a" :: Term (WordN 5)) @=? ssymTerm "a" - ], - testGroup - "Signum" - [ testCase "On concrete" $ do - pevalSignumNumTerm (conTerm 10 :: Term Integer) @=? conTerm 1 - pevalSignumNumTerm (conTerm 0 :: Term Integer) @=? conTerm 0 - pevalSignumNumTerm (conTerm $ -10 :: Term Integer) @=? conTerm (-1), - testCase "On UMinus Integer" $ do - pevalSignumNumTerm (pevalUMinusNumTerm $ ssymTerm "a" :: Term Integer) - @=? pevalUMinusNumTerm (pevalSignumNumTerm $ ssymTerm "a"), - testCase "On UMinus BV" $ do - pevalSignumNumTerm (pevalUMinusNumTerm $ ssymTerm "a" :: Term (IntN 5)) - @=? signumNumTerm (pevalUMinusNumTerm $ ssymTerm "a" :: Term (IntN 5)) - pevalSignumNumTerm (pevalUMinusNumTerm $ ssymTerm "a" :: Term (WordN 5)) - @=? signumNumTerm (pevalUMinusNumTerm $ ssymTerm "a" :: Term (WordN 5)), - testCase "On Times Integer" $ do - pevalSignumNumTerm (pevalTimesNumTerm (ssymTerm "a") (ssymTerm "b") :: Term Integer) - @=? pevalTimesNumTerm (pevalSignumNumTerm $ ssymTerm "a") (pevalSignumNumTerm $ ssymTerm "b"), - testCase "On Times BV" $ do - pevalSignumNumTerm (pevalTimesNumTerm (ssymTerm "a") (ssymTerm "b") :: Term (IntN 5)) - @=? signumNumTerm (pevalTimesNumTerm (ssymTerm "a") (ssymTerm "b") :: Term (IntN 5)) - pevalSignumNumTerm (pevalTimesNumTerm (ssymTerm "a") (ssymTerm "b") :: Term (WordN 5)) - @=? signumNumTerm (pevalTimesNumTerm (ssymTerm "a") (ssymTerm "b") :: Term (WordN 5)), - testCase "On symbolics" $ do - pevalSignumNumTerm (ssymTerm "a" :: Term Integer) - @=? signumNumTerm (ssymTerm "a") - ], - let concSignedBV :: Integer -> Term (IntN 5) = conTerm . fromInteger - concUnsignedBV :: Integer -> Term (WordN 5) = conTerm . fromInteger - in testGroup - "Lt" - [ testCase "On both concrete" $ do - pevalLtNumTerm (conTerm 1 :: Term Integer) (conTerm 2) @=? conTerm True - pevalLtNumTerm (conTerm 2 :: Term Integer) (conTerm 2) @=? conTerm False - pevalLtNumTerm (conTerm 3 :: Term Integer) (conTerm 2) @=? conTerm False - pevalLtNumTerm (conTerm 1 :: Term (IntN 2)) (conTerm 0) @=? conTerm False - pevalLtNumTerm (conTerm 2 :: Term (IntN 2)) (conTerm 0) @=? conTerm True - pevalLtNumTerm (conTerm 3 :: Term (IntN 2)) (conTerm 0) @=? conTerm True - pevalLtNumTerm (conTerm 1 :: Term (WordN 2)) (conTerm 2) @=? conTerm True - pevalLtNumTerm (conTerm 2 :: Term (WordN 2)) (conTerm 2) @=? conTerm False - pevalLtNumTerm (conTerm 3 :: Term (WordN 2)) (conTerm 2) @=? conTerm False, - testCase "On left constant and right add concrete Integers" $ do - pevalLtNumTerm (conTerm 1 :: Term Integer) (pevalAddNumTerm (conTerm 2) (ssymTerm "a")) - @=? pevalLtNumTerm (conTerm $ -1 :: Term Integer) (ssymTerm "a"), - testCase "On right constant left add concrete Integers" $ do - pevalLtNumTerm (pevalAddNumTerm (conTerm 2) (ssymTerm "a")) (conTerm 1 :: Term Integer) - @=? pevalLtNumTerm (conTerm 1 :: Term Integer) (pevalUMinusNumTerm $ ssymTerm "a"), - testCase "On right constant Integers" $ do - pevalLtNumTerm (ssymTerm "a") (conTerm 1 :: Term Integer) - @=? pevalLtNumTerm (conTerm $ -1 :: Term Integer) (pevalUMinusNumTerm $ ssymTerm "a"), - testCase "On right constant and left uminus Integers" $ do - pevalLtNumTerm (pevalUMinusNumTerm $ ssymTerm "a") (conTerm 1 :: Term Integer) - @=? pevalLtNumTerm (conTerm $ -1 :: Term Integer) (ssymTerm "a"), - testCase "On left add concrete Integers" $ do - pevalLtNumTerm (pevalAddNumTerm (conTerm 2) (ssymTerm "a")) (ssymTerm "b" :: Term Integer) - @=? pevalLtNumTerm (conTerm 2 :: Term Integer) (pevalAddNumTerm (ssymTerm "b") (pevalUMinusNumTerm $ ssymTerm "a")), - testCase "On right add concrete Integers" $ do - pevalLtNumTerm (ssymTerm "b" :: Term Integer) (pevalAddNumTerm (conTerm 2) (ssymTerm "a")) - @=? pevalLtNumTerm (conTerm $ -2 :: Term Integer) (pevalAddNumTerm (ssymTerm "a") (pevalUMinusNumTerm $ ssymTerm "b")), - testCase "On left constant and right add concrete BVs should not be simplified" $ do - pevalLtNumTerm (concSignedBV 1) (pevalAddNumTerm (conTerm 2) (ssymTerm "a")) - @=? ltNumTerm (concSignedBV 1) (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a")) - pevalLtNumTerm (concUnsignedBV 1) (pevalAddNumTerm (conTerm 2) (ssymTerm "a")) - @=? ltNumTerm (concUnsignedBV 1) (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")), - testCase "On right constant and left add concrete BVs should not be simplified" $ do - pevalLtNumTerm (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a")) (conTerm 1) - @=? ltNumTerm (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a")) (concSignedBV 1) - pevalLtNumTerm (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")) (conTerm 1) - @=? ltNumTerm (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")) (concUnsignedBV 1), - testCase "On right constant BVs should not be simplified" $ do - pevalLtNumTerm (ssymTerm "a") (concSignedBV 1) - @=? ltNumTerm (ssymTerm "a" :: Term (IntN 5)) (concSignedBV 1) - pevalLtNumTerm (ssymTerm "a") (concUnsignedBV 1) - @=? ltNumTerm (ssymTerm "a" :: Term (WordN 5)) (concUnsignedBV 1), - testCase "On right constant and left uminus BVs should not be simplified" $ do - pevalLtNumTerm (pevalUMinusNumTerm $ ssymTerm "a") (concSignedBV 1) - @=? ltNumTerm (pevalUMinusNumTerm $ ssymTerm "a" :: Term (IntN 5)) (concSignedBV 1) - pevalLtNumTerm (pevalUMinusNumTerm $ ssymTerm "a") (concUnsignedBV 1) - @=? ltNumTerm (pevalUMinusNumTerm $ ssymTerm "a" :: Term (WordN 5)) (concUnsignedBV 1), - testCase "On left add concrete BVs should not be simplified" $ do - pevalLtNumTerm (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a")) (ssymTerm "b") - @=? ltNumTerm (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a")) (ssymTerm "b" :: Term (IntN 5)) - pevalLtNumTerm (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")) (ssymTerm "b") - @=? ltNumTerm (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")) (ssymTerm "b" :: Term (WordN 5)), - testCase "On right add concrete BVs should not be simplified" $ do - pevalLtNumTerm (ssymTerm "b") (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a")) - @=? ltNumTerm - (ssymTerm "b" :: Term (IntN 5)) - (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a")) - pevalLtNumTerm (ssymTerm "b") (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")) - @=? ltNumTerm - (ssymTerm "b" :: Term (WordN 5)) - (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")), - testCase "On symbolic" $ do - pevalLtNumTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b") - @=? ltNumTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b" :: Term Integer) - ], - let concSignedBV :: Integer -> Term (IntN 5) = conTerm . fromInteger - concUnsignedBV :: Integer -> Term (WordN 5) = conTerm . fromInteger - in testGroup - "Le" - [ testCase "On both concrete" $ do - pevalLeNumTerm (conTerm 1 :: Term Integer) (conTerm 2) @=? conTerm True - pevalLeNumTerm (conTerm 2 :: Term Integer) (conTerm 2) @=? conTerm True - pevalLeNumTerm (conTerm 3 :: Term Integer) (conTerm 2) @=? conTerm False - pevalLeNumTerm (conTerm 0 :: Term (IntN 2)) (conTerm 0) @=? conTerm True - pevalLeNumTerm (conTerm 1 :: Term (IntN 2)) (conTerm 0) @=? conTerm False - pevalLeNumTerm (conTerm 2 :: Term (IntN 2)) (conTerm 0) @=? conTerm True - pevalLeNumTerm (conTerm 3 :: Term (IntN 2)) (conTerm 0) @=? conTerm True - pevalLeNumTerm (conTerm 1 :: Term (WordN 2)) (conTerm 2) @=? conTerm True - pevalLeNumTerm (conTerm 2 :: Term (WordN 2)) (conTerm 2) @=? conTerm True - pevalLeNumTerm (conTerm 3 :: Term (WordN 2)) (conTerm 2) @=? conTerm False, - testCase "On left constant and right add concrete Integers" $ do - pevalLeNumTerm (conTerm 1 :: Term Integer) (pevalAddNumTerm (conTerm 2) (ssymTerm "a")) - @=? pevalLeNumTerm (conTerm $ -1 :: Term Integer) (ssymTerm "a"), - testCase "On right constant and left add concrete Integers" $ do - pevalLeNumTerm (pevalAddNumTerm (conTerm 2) (ssymTerm "a")) (conTerm 1 :: Term Integer) - @=? pevalLeNumTerm (conTerm 1 :: Term Integer) (pevalUMinusNumTerm $ ssymTerm "a"), - testCase "On right constant Integers" $ do - pevalLeNumTerm (ssymTerm "a") (conTerm 1 :: Term Integer) - @=? pevalLeNumTerm (conTerm $ -1 :: Term Integer) (pevalUMinusNumTerm $ ssymTerm "a"), - testCase "On right constant left uminus Integers" $ do - pevalLeNumTerm (pevalUMinusNumTerm $ ssymTerm "a") (conTerm 1 :: Term Integer) - @=? pevalLeNumTerm (conTerm $ -1 :: Term Integer) (ssymTerm "a"), - testCase "On left add concrete Integers" $ do - pevalLeNumTerm (pevalAddNumTerm (conTerm 2) (ssymTerm "a")) (ssymTerm "b" :: Term Integer) - @=? pevalLeNumTerm (conTerm 2 :: Term Integer) (pevalAddNumTerm (ssymTerm "b") (pevalUMinusNumTerm $ ssymTerm "a")), - testCase "On right add concrete Integers" $ do - pevalLeNumTerm (ssymTerm "b" :: Term Integer) (pevalAddNumTerm (conTerm 2) (ssymTerm "a")) - @=? pevalLeNumTerm (conTerm $ -2 :: Term Integer) (pevalAddNumTerm (ssymTerm "a") (pevalUMinusNumTerm $ ssymTerm "b")), - testCase "On left constant and right add concrete BVs should not be simplified" $ do - pevalLeNumTerm (concSignedBV 1) (pevalAddNumTerm (conTerm 2) (ssymTerm "a")) - @=? leNumTerm (concSignedBV 1) (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a")) - pevalLeNumTerm (concUnsignedBV 1) (pevalAddNumTerm (conTerm 2) (ssymTerm "a")) - @=? leNumTerm (concUnsignedBV 1) (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")), - testCase "On right constant and left add concrete BVs should not be simplified" $ do - pevalLeNumTerm (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a")) (conTerm 1) - @=? leNumTerm (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a")) (concSignedBV 1) - pevalLeNumTerm (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")) (conTerm 1) - @=? leNumTerm (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")) (concUnsignedBV 1), - testCase "On right constant BVs should not be simplified" $ do - pevalLeNumTerm (ssymTerm "a") (concSignedBV 1) - @=? leNumTerm (ssymTerm "a" :: Term (IntN 5)) (concSignedBV 1) - pevalLeNumTerm (ssymTerm "a") (concUnsignedBV 1) - @=? leNumTerm (ssymTerm "a" :: Term (WordN 5)) (concUnsignedBV 1), - testCase "On right constant and left uminus BVs should not be simplified" $ do - pevalLeNumTerm (pevalUMinusNumTerm $ ssymTerm "a") (concSignedBV 1) - @=? leNumTerm (pevalUMinusNumTerm $ ssymTerm "a" :: Term (IntN 5)) (concSignedBV 1) - pevalLeNumTerm (pevalUMinusNumTerm $ ssymTerm "a") (concUnsignedBV 1) - @=? leNumTerm (pevalUMinusNumTerm $ ssymTerm "a" :: Term (WordN 5)) (concUnsignedBV 1), - testCase "On left add concrete BVs should not be simplified" $ do - pevalLeNumTerm (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a")) (ssymTerm "b") - @=? leNumTerm (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a")) (ssymTerm "b" :: Term (IntN 5)) - pevalLeNumTerm (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")) (ssymTerm "b") - @=? leNumTerm (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")) (ssymTerm "b" :: Term (WordN 5)), - testCase "Lt on right add concrete BVs should not be simplified" $ do - pevalLeNumTerm (ssymTerm "b") (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a")) - @=? leNumTerm - (ssymTerm "b" :: Term (IntN 5)) - (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a")) - pevalLeNumTerm (ssymTerm "b") (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")) - @=? leNumTerm - (ssymTerm "b" :: Term (WordN 5)) - (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")), - testCase "On symbolic" $ do - pevalLeNumTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b") - @=? leNumTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b" :: Term Integer) - ], - testCase "Gt should be delegated to Lt" $ - pevalGtNumTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b") - @=? pevalLtNumTerm (ssymTerm "b" :: Term Integer) (ssymTerm "a"), - testCase "Ge should be delegated to Le" $ do - pevalGeNumTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b") - @=? pevalLeNumTerm (ssymTerm "b" :: Term Integer) (ssymTerm "a") - ] diff --git a/test/Grisette/IR/SymPrim/Data/Prim/TabularFunTests.hs b/test/Grisette/IR/SymPrim/Data/Prim/TabularFunTests.hs deleted file mode 100644 --- a/test/Grisette/IR/SymPrim/Data/Prim/TabularFunTests.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} - -module Grisette.IR.SymPrim.Data.Prim.TabularFunTests (tabularFunTests) where - -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors - ( conTerm, - ssymTerm, - tabularFunApplyTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term (Term) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool - ( pevalEqvTerm, - pevalITETerm, - ) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.TabularFun - ( pevalTabularFunApplyTerm, - ) -import Grisette.IR.SymPrim.Data.TabularFun - ( type (=->) (TabularFun), - ) -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit ((@=?)) - -tabularFunTests :: Test -tabularFunTests = - testGroup - "TabularFun" - [ testGroup - "ApplyF" - [ testCase "On concrete" $ do - let f :: Integer =-> Integer = - TabularFun [(1, 2), (3, 4)] 5 - pevalTabularFunApplyTerm (conTerm f) (conTerm 0) @=? conTerm 5 - pevalTabularFunApplyTerm (conTerm f) (conTerm 1) @=? conTerm 2 - pevalTabularFunApplyTerm (conTerm f) (conTerm 2) @=? conTerm 5 - pevalTabularFunApplyTerm (conTerm f) (conTerm 3) @=? conTerm 4 - pevalTabularFunApplyTerm (conTerm f) (conTerm 4) @=? conTerm 5, - testCase "On concrete function" $ do - let f :: Integer =-> Integer = - TabularFun [(1, 2), (3, 4)] 5 - pevalTabularFunApplyTerm (conTerm f) (ssymTerm "b") - @=? pevalITETerm - (pevalEqvTerm (conTerm 1 :: Term Integer) (ssymTerm "b")) - (conTerm 2) - ( pevalITETerm - (pevalEqvTerm (conTerm 3 :: Term Integer) (ssymTerm "b")) - (conTerm 4) - (conTerm 5) - ), - testCase "On symbolic" $ do - pevalTabularFunApplyTerm (ssymTerm "f" :: Term (Integer =-> Integer)) (ssymTerm "a") - @=? tabularFunApplyTerm - (ssymTerm "f" :: Term (Integer =-> Integer)) - (ssymTerm "a" :: Term Integer) - ] - ] diff --git a/test/Grisette/IR/SymPrim/Data/SymPrimTests.hs b/test/Grisette/IR/SymPrim/Data/SymPrimTests.hs deleted file mode 100644 --- a/test/Grisette/IR/SymPrim/Data/SymPrimTests.hs +++ /dev/null @@ -1,1209 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NegativeLiterals #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module Grisette.IR.SymPrim.Data.SymPrimTests (symPrimTests) where - -import Control.DeepSeq (NFData (rnf), force) -import Control.Exception - ( ArithException (DivideByZero, Overflow, Underflow), - catch, - evaluate, - ) -import Control.Monad.Except (ExceptT, MonadError (throwError)) -import Data.Bits - ( Bits - ( bit, - bitSizeMaybe, - complement, - isSigned, - popCount, - rotate, - shift, - testBit, - xor, - (.&.), - (.|.) - ), - ) -import qualified Data.HashMap.Strict as M -import qualified Data.HashSet as S -import Data.Int (Int8) -import Data.Proxy (Proxy (Proxy)) -import Data.Word (Word8) -import Grisette.Core.Control.Monad.UnionM (UnionM) -import Grisette.Core.Data.BV (IntN (IntN), WordN (WordN)) -import Grisette.Core.Data.Class.BitVector - ( SizedBV - ( sizedBVConcat, - sizedBVExt, - sizedBVSelect, - sizedBVSext, - sizedBVZext - ), - ) -import Grisette.Core.Data.Class.EvaluateSym - ( EvaluateSym (evaluateSym), - ) -import Grisette.Core.Data.Class.ExtractSymbolics - ( ExtractSymbolics (extractSymbolics), - ) -import Grisette.Core.Data.Class.Function (Apply (apply), Function ((#))) -import Grisette.Core.Data.Class.GenSym - ( genSym, - genSymSimple, - nameWithInfo, - ) -import Grisette.Core.Data.Class.ITEOp (ITEOp (symIte)) -import Grisette.Core.Data.Class.LogicalOp - ( LogicalOp (symImplies, symNot, symXor, (.&&), (.||)), - ) -import Grisette.Core.Data.Class.Mergeable - ( Mergeable (rootStrategy), - MergingStrategy (SimpleStrategy), - ) -import Grisette.Core.Data.Class.ModelOps - ( ModelOps (emptyModel, insertValue), - ModelRep (buildModel), - ) -import Grisette.Core.Data.Class.SEq (SEq ((./=), (.==))) -import Grisette.Core.Data.Class.SOrd - ( SOrd (symCompare, (.<), (.<=), (.>), (.>=)), - ) -import Grisette.Core.Data.Class.SafeDivision - ( SafeDivision - ( safeDiv, - safeDiv', - safeDivMod, - safeDivMod', - safeMod, - safeMod', - safeQuot, - safeQuot', - safeQuotRem, - safeQuotRem', - safeRem, - safeRem' - ), - ) -import Grisette.Core.Data.Class.SafeLinearArith - ( SafeLinearArith - ( safeAdd, - safeAdd', - safeMinus, - safeMinus', - safeNeg, - safeNeg' - ), - ) -import Grisette.Core.Data.Class.SimpleMergeable - ( SimpleMergeable (mrgIte), - merge, - mrgIf, - mrgSingle, - ) -import Grisette.Core.Data.Class.Solvable - ( Solvable (con, conView, iinfosym, isym, ssym), - pattern Con, - ) -import Grisette.Core.Data.Class.ToCon (ToCon (toCon)) -import Grisette.Core.Data.Class.ToSym (ToSym (toSym)) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.InternedCtors - ( conTerm, - isymTerm, - ssymTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term - ( LinkedRep (wrapTerm), - Term, - TypedSymbol (SimpleSymbol), - someTypedSymbol, - type (-->), - ) -import Grisette.IR.SymPrim.Data.Prim.Model - ( Model (Model), - SymbolSet (SymbolSet), - ) -import Grisette.IR.SymPrim.Data.Prim.ModelValue (toModelValue) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.BV - ( pevalBVConcatTerm, - pevalBVExtendTerm, - pevalBVSelectTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bits - ( pevalAndBitsTerm, - pevalComplementBitsTerm, - pevalOrBitsTerm, - pevalRotateLeftTerm, - pevalRotateRightTerm, - pevalShiftLeftTerm, - pevalShiftRightTerm, - pevalXorBitsTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.Bool - ( pevalAndTerm, - pevalEqvTerm, - pevalITETerm, - pevalImplyTerm, - pevalNotTerm, - pevalOrTerm, - pevalXorTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.Integral - ( pevalDivBoundedIntegralTerm, - pevalDivIntegralTerm, - pevalModBoundedIntegralTerm, - pevalModIntegralTerm, - pevalQuotBoundedIntegralTerm, - pevalQuotIntegralTerm, - pevalRemBoundedIntegralTerm, - pevalRemIntegralTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.Num - ( pevalAbsNumTerm, - pevalAddNumTerm, - pevalGeNumTerm, - pevalGtNumTerm, - pevalLeNumTerm, - pevalLtNumTerm, - pevalMinusNumTerm, - pevalSignumNumTerm, - pevalTimesNumTerm, - pevalUMinusNumTerm, - ) -import Grisette.IR.SymPrim.Data.Prim.PartialEval.TabularFun - ( pevalTabularFunApplyTerm, - ) -import Grisette.IR.SymPrim.Data.SymPrim - ( ModelSymPair ((:=)), - SymBool (SymBool), - SymIntN (SymIntN), - SymInteger (SymInteger), - SymWordN (SymWordN), - symSize, - symsSize, - (-->), - type (-~>), - type (=~>), - ) -import Grisette.IR.SymPrim.Data.TabularFun (type (=->)) -import Test.Framework (Test, TestName, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.HUnit (Assertion, assertFailure, (@=?)) -import Test.QuickCheck (Arbitrary, ioProperty) - -newtype AEWrapper = AEWrapper ArithException deriving (Eq) - -instance Show AEWrapper where - show (AEWrapper x) = show x - -instance NFData AEWrapper where - rnf (AEWrapper x) = x `seq` () - -sameSafeDiv :: - forall c s. - ( Show s, - Eq s, - Eq c, - Num c, - Mergeable s, - NFData c, - Solvable c s - ) => - c -> - c -> - (s -> s -> ExceptT ArithException UnionM s) -> - (c -> c -> c) -> - Assertion -sameSafeDiv i j f cf = do - xc <- evaluate (force $ Right $ cf i j) `catch` \(e :: ArithException) -> return $ Left $ AEWrapper e - case xc of - Left (AEWrapper e) -> f (con i :: s) (con j) @=? merge (throwError e) - Right c -> f (con i :: s) (con j) @=? mrgSingle (con c) - -sameSafeDiv' :: - forall c s. - ( Show s, - Eq s, - Eq c, - Num c, - Mergeable s, - NFData c, - Solvable c s - ) => - c -> - c -> - ((ArithException -> ()) -> s -> s -> ExceptT () UnionM s) -> - (c -> c -> c) -> - Assertion -sameSafeDiv' i j f cf = do - xc <- evaluate (force $ Right $ cf i j) `catch` \(_ :: ArithException) -> return $ Left () - case xc of - Left () -> f (const ()) (con i :: s) (con j) @=? merge (throwError ()) - Right c -> f (const ()) (con i :: s) (con j) @=? mrgSingle (con c) - -sameSafeDivMod :: - forall c s. - ( Show s, - Eq s, - Eq c, - Num c, - Mergeable s, - NFData c, - Solvable c s - ) => - c -> - c -> - (s -> s -> ExceptT ArithException UnionM (s, s)) -> - (c -> c -> (c, c)) -> - Assertion -sameSafeDivMod i j f cf = do - xc <- evaluate (force $ Right $ cf i j) `catch` \(e :: ArithException) -> return $ Left $ AEWrapper e - case xc of - Left (AEWrapper e) -> f (con i :: s) (con j) @=? merge (throwError e) - Right (c1, c2) -> f (con i :: s) (con j) @=? mrgSingle (con c1, con c2) - -sameSafeDivMod' :: - forall c s. - ( Show s, - Eq s, - Eq c, - Num c, - Mergeable s, - NFData c, - Solvable c s - ) => - c -> - c -> - ((ArithException -> ()) -> s -> s -> ExceptT () UnionM (s, s)) -> - (c -> c -> (c, c)) -> - Assertion -sameSafeDivMod' i j f cf = do - xc <- evaluate (force $ Right $ cf i j) `catch` \(_ :: ArithException) -> return $ Left () - case xc of - Left () -> f (const ()) (con i :: s) (con j) @=? merge (throwError ()) - Right (c1, c2) -> f (const ()) (con i :: s) (con j) @=? mrgSingle (con c1, con c2) - -safeDivisionBoundedOnlyTests :: - forall c s. - (LinkedRep c s, Bounded c, Solvable c s, Eq s, Num c, Show s, Mergeable s, SEq s) => - (s -> s -> ExceptT ArithException UnionM s) -> - ((ArithException -> ()) -> s -> s -> ExceptT () UnionM s) -> - (c -> c -> c) -> - (Term c -> Term c -> Term c) -> - [Test] -safeDivisionBoundedOnlyTests f f' cf pf = - [ testCase "on concrete min divided by minus one" $ do - sameSafeDiv minBound (-1) f cf - sameSafeDiv' minBound (-1) f' cf, - testCase "on symbolic" $ do - f (ssym "a" :: s) (ssym "b") - @=? ( mrgIf - ((ssym "b" :: s) .== con (0 :: c) :: SymBool) - (throwError DivideByZero) - ( mrgIf - ((ssym "b" :: s) .== con (-1) .&& (ssym "a" :: s) .== con (minBound :: c) :: SymBool) - (throwError Overflow) - (mrgSingle $ wrapTerm $ pf (ssymTerm "a") (ssymTerm "b")) - ) :: - ExceptT ArithException UnionM s - ) - f' (const ()) (ssym "a" :: s) (ssym "b") - @=? ( mrgIf - ((ssym "b" :: s) .== con (0 :: c) :: SymBool) - (throwError ()) - ( mrgIf - ((ssym "b" :: s) .== con (-1) .&& (ssym "a" :: s) .== con (minBound :: c) :: SymBool) - (throwError ()) - (mrgSingle $ wrapTerm $ pf (ssymTerm "a") (ssymTerm "b")) - ) :: - ExceptT () UnionM s - ) - ] - -safeDivisionUnboundedOnlyTests :: - forall c s. - (LinkedRep c s, Solvable c s, Eq s, Num c, Show s, Mergeable s, SEq s) => - (s -> s -> ExceptT ArithException UnionM s) -> - ((ArithException -> ()) -> s -> s -> ExceptT () UnionM s) -> - (Term c -> Term c -> Term c) -> - [Test] -safeDivisionUnboundedOnlyTests f f' pf = - [ testCase "on symbolic" $ do - f (ssym "a" :: s) (ssym "b") - @=? ( mrgIf - ((ssym "b" :: s) .== con (0 :: c) :: SymBool) - (throwError DivideByZero) - (mrgSingle $ wrapTerm $ pf (ssymTerm "a") (ssymTerm "b")) :: - ExceptT ArithException UnionM s - ) - f' (const ()) (ssym "a" :: s) (ssym "b") - @=? ( mrgIf - ((ssym "b" :: s) .== con (0 :: c) :: SymBool) - (throwError ()) - (mrgSingle $ wrapTerm $ pf (ssymTerm "a") (ssymTerm "b")) :: - ExceptT () UnionM s - ) - ] - -safeDivisionGeneralTests :: - forall c c0 s. - (LinkedRep c s, Arbitrary c0, Show c0, Solvable c s, Eq s, Num c, Show s, Mergeable s, SEq s) => - (c0 -> c) -> - (s -> s -> ExceptT ArithException UnionM s) -> - ((ArithException -> ()) -> s -> s -> ExceptT () UnionM s) -> - (c -> c -> c) -> - [Test] -safeDivisionGeneralTests transform f f' cf = - [ testProperty "on concrete prop" $ \(i0 :: c0, j0 :: c0) -> - ioProperty $ do - let i = transform i0 - let j = transform j0 - sameSafeDiv i j f cf - sameSafeDiv' i j f' cf, - testProperty "on concrete divided by zero" $ \(i0 :: c0) -> - ioProperty $ do - let i = transform i0 - sameSafeDiv i 0 f cf - sameSafeDiv' i 0 f' cf, - testCase "when divided by zero" $ do - f (ssym "a" :: s) (con 0) - @=? (merge $ throwError DivideByZero :: ExceptT ArithException UnionM s) - f' (const ()) (ssym "a" :: s) (con 0) - @=? (merge $ throwError () :: ExceptT () UnionM s) - ] - -safeDivisionBoundedTests :: - forall c c0 s. - (LinkedRep c s, Arbitrary c0, Show c0, Bounded c, Solvable c s, Eq s, Num c, Show s, Mergeable s, SEq s) => - TestName -> - (c0 -> c) -> - (s -> s -> ExceptT ArithException UnionM s) -> - ((ArithException -> ()) -> s -> s -> ExceptT () UnionM s) -> - (c -> c -> c) -> - (Term c -> Term c -> Term c) -> - Test -safeDivisionBoundedTests name transform f f' cf pf = - testGroup name $ - safeDivisionGeneralTests transform f f' cf - ++ safeDivisionBoundedOnlyTests f f' cf pf - -safeDivisionUnboundedTests :: - forall c c0 s. - (LinkedRep c s, Arbitrary c0, Show c0, Solvable c s, Eq s, Num c, Show s, Mergeable s, SEq s) => - TestName -> - (c0 -> c) -> - (s -> s -> ExceptT ArithException UnionM s) -> - ((ArithException -> ()) -> s -> s -> ExceptT () UnionM s) -> - (c -> c -> c) -> - (Term c -> Term c -> Term c) -> - Test -safeDivisionUnboundedTests name transform f f' cf pf = - testGroup name $ - safeDivisionGeneralTests transform f f' cf - ++ safeDivisionUnboundedOnlyTests f f' pf - -safeDivModBoundedOnlyTests :: - forall c s. - (LinkedRep c s, Bounded c, Solvable c s, Eq s, Num c, Show s, Mergeable s, SEq s) => - ( s -> - s -> - ExceptT ArithException UnionM (s, s) - ) -> - ( (ArithException -> ()) -> - s -> - s -> - ExceptT () UnionM (s, s) - ) -> - (c -> c -> (c, c)) -> - (Term c -> Term c -> Term c) -> - (Term c -> Term c -> Term c) -> - [Test] -safeDivModBoundedOnlyTests f f' cf pf1 pf2 = - [ testCase "on concrete min divided by minus one" $ do - sameSafeDivMod minBound (-1) f cf - sameSafeDivMod' minBound (-1) f' cf, - testCase "on symbolic" $ do - f (ssym "a" :: s) (ssym "b") - @=? ( mrgIf - ((ssym "b" :: s) .== con (0 :: c) :: SymBool) - (throwError DivideByZero) - ( mrgIf - ((ssym "b" :: s) .== con (-1) .&& (ssym "a" :: s) .== con (minBound :: c) :: SymBool) - (throwError Overflow) - ( mrgSingle - ( wrapTerm $ pf1 (ssymTerm "a") (ssymTerm "b"), - wrapTerm $ pf2 (ssymTerm "a") (ssymTerm "b") - ) - ) - ) :: - ExceptT ArithException UnionM (s, s) - ) - f' (const ()) (ssym "a" :: s) (ssym "b") - @=? ( mrgIf - ((ssym "b" :: s) .== con (0 :: c) :: SymBool) - (throwError ()) - ( mrgIf - ((ssym "b" :: s) .== con (-1) .&& (ssym "a" :: s) .== con (minBound :: c) :: SymBool) - (throwError ()) - ( mrgSingle - ( wrapTerm $ pf1 (ssymTerm "a") (ssymTerm "b"), - wrapTerm $ pf2 (ssymTerm "a") (ssymTerm "b") - ) - ) - ) :: - ExceptT () UnionM (s, s) - ) - ] - -safeDivModUnboundedOnlyTests :: - forall c s. - (LinkedRep c s, Solvable c s, Eq s, Num c, Show s, Mergeable s, SEq s) => - ( s -> - s -> - ExceptT ArithException UnionM (s, s) - ) -> - ( (ArithException -> ()) -> - s -> - s -> - ExceptT () UnionM (s, s) - ) -> - (Term c -> Term c -> Term c) -> - (Term c -> Term c -> Term c) -> - [Test] -safeDivModUnboundedOnlyTests f f' pf1 pf2 = - [ testCase "on symbolic" $ do - f (ssym "a" :: s) (ssym "b") - @=? ( mrgIf - ((ssym "b" :: s) .== con (0 :: c) :: SymBool) - (throwError DivideByZero) - ( mrgSingle - ( wrapTerm $ pf1 (ssymTerm "a") (ssymTerm "b"), - wrapTerm $ pf2 (ssymTerm "a") (ssymTerm "b") - ) - ) :: - ExceptT ArithException UnionM (s, s) - ) - f' (const ()) (ssym "a" :: s) (ssym "b") - @=? ( mrgIf - ((ssym "b" :: s) .== con (0 :: c) :: SymBool) - (throwError ()) - ( mrgSingle - ( wrapTerm $ pf1 (ssymTerm "a") (ssymTerm "b"), - wrapTerm $ pf2 (ssymTerm "a") (ssymTerm "b") - ) - ) :: - ExceptT () UnionM (s, s) - ) - ] - -safeDivModGeneralTests :: - forall c c0 s. - (LinkedRep c s, Arbitrary c0, Show c0, Solvable c s, Eq s, Num c, Show s, Mergeable s, SEq s) => - (c0 -> c) -> - ( s -> - s -> - ExceptT ArithException UnionM (s, s) - ) -> - ( (ArithException -> ()) -> - s -> - s -> - ExceptT () UnionM (s, s) - ) -> - (c -> c -> (c, c)) -> - [Test] -safeDivModGeneralTests transform f f' cf = - [ testProperty "on concrete" $ \(i0 :: c0, j0 :: c0) -> - ioProperty $ do - let i = transform i0 - let j = transform j0 - sameSafeDivMod i j f cf - sameSafeDivMod' i j f' cf, - testProperty "on concrete divided by zero" $ \(i0 :: c0) -> - ioProperty $ do - let i = transform i0 - sameSafeDivMod i 0 f cf - sameSafeDivMod' i 0 f' cf, - testCase "when divided by zero" $ do - f (ssym "a" :: s) (con 0) - @=? (merge $ throwError DivideByZero :: ExceptT ArithException UnionM (s, s)) - f' (const ()) (ssym "a" :: s) (con 0) - @=? (merge $ throwError () :: ExceptT () UnionM (s, s)) - ] - -safeDivModBoundedTests :: - forall c c0 s. - (LinkedRep c s, Arbitrary c0, Show c0, Bounded c, Solvable c s, Eq s, Num c, Show s, Mergeable s, SEq s) => - TestName -> - (c0 -> c) -> - ( s -> - s -> - ExceptT ArithException UnionM (s, s) - ) -> - ( (ArithException -> ()) -> - s -> - s -> - ExceptT () UnionM (s, s) - ) -> - (c -> c -> (c, c)) -> - (Term c -> Term c -> Term c) -> - (Term c -> Term c -> Term c) -> - Test -safeDivModBoundedTests name transform f f' cf pf1 pf2 = - testGroup name $ - safeDivModGeneralTests transform f f' cf - ++ safeDivModBoundedOnlyTests f f' cf pf1 pf2 - -safeDivModUnboundedTests :: - forall c c0 s. - (LinkedRep c s, Arbitrary c0, Show c0, Solvable c s, Eq s, Num c, Show s, Mergeable s, SEq s) => - TestName -> - (c0 -> c) -> - ( s -> - s -> - ExceptT ArithException UnionM (s, s) - ) -> - ( (ArithException -> ()) -> - s -> - s -> - ExceptT () UnionM (s, s) - ) -> - (c -> c -> (c, c)) -> - (Term c -> Term c -> Term c) -> - (Term c -> Term c -> Term c) -> - Test -safeDivModUnboundedTests name transform f f' cf pf1 pf2 = - testGroup name $ - safeDivModGeneralTests transform f f' cf - ++ safeDivModUnboundedOnlyTests f f' pf1 pf2 - -symPrimTests :: Test -symPrimTests = - testGroup - "SymPrim" - [ testGroup - "General SymPrim" - [ testGroup - "Solvable" - [ testCase "con" $ (con 1 :: SymInteger) @=? SymInteger (conTerm 1), - testCase "ssym" $ (ssym "a" :: SymInteger) @=? SymInteger (ssymTerm "a"), - testCase "isym" $ (isym "a" 1 :: SymInteger) @=? SymInteger (isymTerm "a" 1), - testCase "conView" $ do - conView (con 1 :: SymInteger) @=? Just 1 - conView (ssym "a" :: SymInteger) @=? Nothing - case con 1 :: SymInteger of - Con 1 -> return () - _ -> assertFailure "Bad match" - case ssym "a" :: SymInteger of - Con _ -> assertFailure "Bad match" - _ -> return () - ], - testGroup - "ITEOp" - [ testCase "symIte" $ - symIte (ssym "a" :: SymBool) (ssym "b" :: SymInteger) (ssym "c") - @=? SymInteger (pevalITETerm (ssymTerm "a") (ssymTerm "b") (ssymTerm "c")) - ], - testCase "Mergeable" $ do - let SimpleStrategy s = rootStrategy :: MergingStrategy SymInteger - s (ssym "a") (ssym "b") (ssym "c") - @=? symIte (ssym "a" :: SymBool) (ssym "b" :: SymInteger) (ssym "c"), - testCase "SimpleMergeable" $ - mrgIte (ssym "a" :: SymBool) (ssym "b") (ssym "c") - @=? symIte (ssym "a" :: SymBool) (ssym "b" :: SymInteger) (ssym "c"), - testCase "IsString" $ ("a" :: SymBool) @=? SymBool (ssymTerm "a"), - testGroup - "ToSym" - [ testCase "From self" $ toSym (ssym "a" :: SymBool) @=? (ssym "a" :: SymBool), - testCase "From concrete" $ toSym True @=? (con True :: SymBool) - ], - testGroup - "ToCon" - [ testCase "To self" $ toCon (ssym "a" :: SymBool) @=? (Nothing :: Maybe Bool), - testCase "To concrete" $ toCon True @=? Just True - ], - testCase "EvaluateSym" $ do - let m1 = emptyModel :: Model - let m2 = insertValue (SimpleSymbol "a") (1 :: Integer) m1 - let m3 = insertValue (SimpleSymbol "b") True m2 - evaluateSym False m3 (symIte ("c" :: SymBool) "a" ("a" + "a" :: SymInteger)) - @=? symIte ("c" :: SymBool) 1 2 - evaluateSym True m3 (symIte ("c" :: SymBool) "a" ("a" + "a" :: SymInteger)) @=? 2, - testCase "ExtractSymbolics" $ - extractSymbolics (symIte ("c" :: SymBool) ("a" :: SymInteger) ("b" :: SymInteger)) - @=? SymbolSet - ( S.fromList - [ someTypedSymbol (SimpleSymbol "c" :: TypedSymbol Bool), - someTypedSymbol (SimpleSymbol "a" :: TypedSymbol Integer), - someTypedSymbol (SimpleSymbol "b" :: TypedSymbol Integer) - ] - ), - testCase "GenSym" $ do - (genSym () "a" :: UnionM SymBool) @=? mrgSingle (isym "a" 0) - (genSymSimple () "a" :: SymBool) @=? isym "a" 0 - (genSym (ssym "a" :: SymBool) "a" :: UnionM SymBool) @=? mrgSingle (isym "a" 0) - (genSymSimple (ssym "a" :: SymBool) "a" :: SymBool) @=? isym "a" 0 - (genSym () (nameWithInfo "a" True) :: UnionM SymBool) @=? mrgSingle (iinfosym "a" 0 True) - (genSymSimple () (nameWithInfo "a" True) :: SymBool) @=? iinfosym "a" 0 True, - testCase "SEq" $ do - (ssym "a" :: SymBool) .== ssym "b" @=? SymBool (pevalEqvTerm (ssymTerm "a" :: Term Bool) (ssymTerm "b")) - (ssym "a" :: SymBool) ./= ssym "b" @=? SymBool (pevalNotTerm $ pevalEqvTerm (ssymTerm "a" :: Term Bool) (ssymTerm "b")) - ], - testGroup - "SymBool" - [ testGroup - "LogicalOp" - [ testCase ".||" $ ssym "a" .|| ssym "b" @=? SymBool (pevalOrTerm (ssymTerm "a") (ssymTerm "b")), - testCase ".&&" $ ssym "a" .&& ssym "b" @=? SymBool (pevalAndTerm (ssymTerm "a") (ssymTerm "b")), - testCase "symNot" $ symNot (ssym "a") @=? SymBool (pevalNotTerm (ssymTerm "a")), - testCase "symXor" $ symXor (ssym "a") (ssym "b") @=? SymBool (pevalXorTerm (ssymTerm "a") (ssymTerm "b")), - testCase "symImplies" $ symImplies (ssym "a") (ssym "b") @=? SymBool (pevalImplyTerm (ssymTerm "a") (ssymTerm "b")) - ] - ], - testGroup - "SymInteger" - [ testGroup - "Num" - [ testCase "fromInteger" $ (1 :: SymInteger) @=? SymInteger (conTerm 1), - testCase "(+)" $ (ssym "a" :: SymInteger) + ssym "b" @=? SymInteger (pevalAddNumTerm (ssymTerm "a") (ssymTerm "b")), - testCase "(-)" $ (ssym "a" :: SymInteger) - ssym "b" @=? SymInteger (pevalMinusNumTerm (ssymTerm "a") (ssymTerm "b")), - testCase "(*)" $ (ssym "a" :: SymInteger) * ssym "b" @=? SymInteger (pevalTimesNumTerm (ssymTerm "a") (ssymTerm "b")), - testCase "negate" $ negate (ssym "a" :: SymInteger) @=? SymInteger (pevalUMinusNumTerm (ssymTerm "a")), - testCase "abs" $ abs (ssym "a" :: SymInteger) @=? SymInteger (pevalAbsNumTerm (ssymTerm "a")), - testCase "signum" $ signum (ssym "a" :: SymInteger) @=? SymInteger (pevalSignumNumTerm (ssymTerm "a")) - ], - testGroup - "SafeDivision" - [ safeDivisionUnboundedTests @Integer "safeDiv" id safeDiv safeDiv' div pevalDivIntegralTerm, - safeDivisionUnboundedTests @Integer "safeMod" id safeMod safeMod' mod pevalModIntegralTerm, - safeDivModUnboundedTests @Integer "safeDivMod" id safeDivMod safeDivMod' divMod pevalDivIntegralTerm pevalModIntegralTerm, - safeDivisionUnboundedTests @Integer "safeQuot" id safeQuot safeQuot' quot pevalQuotIntegralTerm, - safeDivisionUnboundedTests @Integer "safeRem" id safeRem safeRem' rem pevalRemIntegralTerm, - safeDivModUnboundedTests @Integer "safeQuotRem" id safeQuotRem safeQuotRem' quotRem pevalQuotIntegralTerm pevalRemIntegralTerm - ], - testGroup - "SafeLinearArith" - [ testProperty "safeAdd on concrete" $ \(i :: Integer, j :: Integer) -> - ioProperty $ do - safeAdd (con i :: SymInteger) (con j) - @=? (mrgSingle $ con $ i + j :: ExceptT ArithException UnionM SymInteger) - safeAdd' (const ()) (con i :: SymInteger) (con j) - @=? (mrgSingle $ con $ i + j :: ExceptT () UnionM SymInteger), - testCase "safeAdd on symbolic" $ do - safeAdd (ssym "a" :: SymInteger) (ssym "b") - @=? (mrgSingle $ SymInteger $ pevalAddNumTerm (ssymTerm "a") (ssymTerm "b") :: ExceptT ArithException UnionM SymInteger) - safeAdd' (const ()) (ssym "a" :: SymInteger) (ssym "b") - @=? (mrgSingle $ SymInteger $ pevalAddNumTerm (ssymTerm "a") (ssymTerm "b") :: ExceptT () UnionM SymInteger), - testProperty "safeNeg on concrete" $ \(i :: Integer) -> - ioProperty $ do - safeNeg (con i :: SymInteger) - @=? (mrgSingle $ con $ -i :: ExceptT ArithException UnionM SymInteger) - safeNeg' (const ()) (con i :: SymInteger) - @=? (mrgSingle $ con $ -i :: ExceptT () UnionM SymInteger), - testCase "safeNeg on symbolic" $ do - safeNeg (ssym "a" :: SymInteger) - @=? (mrgSingle $ SymInteger $ pevalUMinusNumTerm (ssymTerm "a") :: ExceptT ArithException UnionM SymInteger) - safeNeg' (const ()) (ssym "a" :: SymInteger) - @=? (mrgSingle $ SymInteger $ pevalUMinusNumTerm (ssymTerm "a") :: ExceptT () UnionM SymInteger), - testProperty "safeMinus on concrete" $ \(i :: Integer, j :: Integer) -> - ioProperty $ do - safeMinus (con i :: SymInteger) (con j) - @=? (mrgSingle $ con $ i - j :: ExceptT ArithException UnionM SymInteger) - safeMinus' (const ()) (con i :: SymInteger) (con j) - @=? (mrgSingle $ con $ i - j :: ExceptT () UnionM SymInteger), - testCase "safeMinus on symbolic" $ do - safeMinus (ssym "a" :: SymInteger) (ssym "b") - @=? (mrgSingle $ SymInteger $ pevalMinusNumTerm (ssymTerm "a") (ssymTerm "b") :: ExceptT ArithException UnionM SymInteger) - safeMinus' (const ()) (ssym "a" :: SymInteger) (ssym "b") - @=? (mrgSingle $ SymInteger $ pevalMinusNumTerm (ssymTerm "a") (ssymTerm "b") :: ExceptT () UnionM SymInteger) - ], - testGroup - "SOrd" - [ testProperty "SOrd on concrete" $ \(i :: Integer, j :: Integer) -> ioProperty $ do - (con i :: SymInteger) .<= con j @=? (con (i <= j) :: SymBool) - (con i :: SymInteger) .< con j @=? (con (i < j) :: SymBool) - (con i :: SymInteger) .>= con j @=? (con (i >= j) :: SymBool) - (con i :: SymInteger) .> con j @=? (con (i > j) :: SymBool) - (con i :: SymInteger) - `symCompare` con j - @=? (i `symCompare` j :: UnionM Ordering), - testCase "SOrd on symbolic" $ do - let a :: SymInteger = ssym "a" - let b :: SymInteger = ssym "b" - let at :: Term Integer = ssymTerm "a" - let bt :: Term Integer = ssymTerm "b" - a .<= b @=? SymBool (pevalLeNumTerm at bt) - a .< b @=? SymBool (pevalLtNumTerm at bt) - a .>= b @=? SymBool (pevalGeNumTerm at bt) - a .> b @=? SymBool (pevalGtNumTerm at bt) - (a `symCompare` ssym "b" :: UnionM Ordering) - @=? mrgIf (a .< b) (mrgSingle LT) (mrgIf (a .== b) (mrgSingle EQ) (mrgSingle GT)) - ] - ], - let au :: SymWordN 4 = ssym "a" - bu :: SymWordN 4 = ssym "b" - as :: SymIntN 4 = ssym "a" - bs :: SymIntN 4 = ssym "b" - aut :: Term (WordN 4) = ssymTerm "a" - but :: Term (WordN 4) = ssymTerm "b" - ast :: Term (IntN 4) = ssymTerm "a" - bst :: Term (IntN 4) = ssymTerm "b" - in testGroup - "Sym BV" - [ testGroup - "Num" - [ testCase "fromInteger" $ do - (1 :: SymWordN 4) @=? SymWordN (conTerm 1) - (1 :: SymIntN 4) @=? SymIntN (conTerm 1), - testCase "(+)" $ do - au + bu @=? SymWordN (pevalAddNumTerm aut but) - as + bs @=? SymIntN (pevalAddNumTerm ast bst), - testCase "(-)" $ do - au - bu @=? SymWordN (pevalMinusNumTerm aut but) - as - bs @=? SymIntN (pevalMinusNumTerm ast bst), - testCase "(*)" $ do - au * bu @=? SymWordN (pevalTimesNumTerm aut but) - as * bs @=? SymIntN (pevalTimesNumTerm ast bst), - testCase "negate" $ do - negate au @=? SymWordN (pevalUMinusNumTerm aut) - negate as @=? SymIntN (pevalUMinusNumTerm ast), - testCase "abs" $ do - abs au @=? SymWordN (pevalAbsNumTerm aut) - abs as @=? SymIntN (pevalAbsNumTerm ast), - testCase "signum" $ do - signum au @=? SymWordN (pevalSignumNumTerm aut) - signum as @=? SymIntN (pevalSignumNumTerm ast) - ], - testGroup - "SafeDivision" - [ testGroup - "WordN" - [ safeDivisionUnboundedTests @(WordN 4) "safeDiv" WordN safeDiv safeDiv' div pevalDivIntegralTerm, - safeDivisionUnboundedTests @(WordN 4) "safeMod" WordN safeMod safeMod' mod pevalModIntegralTerm, - safeDivModUnboundedTests @(WordN 4) "safeDivMod" WordN safeDivMod safeDivMod' divMod pevalDivIntegralTerm pevalModIntegralTerm, - safeDivisionUnboundedTests @(WordN 4) "safeQuot" WordN safeQuot safeQuot' quot pevalQuotIntegralTerm, - safeDivisionUnboundedTests @(WordN 4) "safeRem" WordN safeRem safeRem' rem pevalRemIntegralTerm, - safeDivModUnboundedTests @(WordN 4) "safeQuotRem" WordN safeQuotRem safeQuotRem' divMod pevalQuotIntegralTerm pevalRemIntegralTerm - ], - testGroup - "IntN" - [ safeDivisionBoundedTests @(IntN 4) "safeDiv" IntN safeDiv safeDiv' div pevalDivBoundedIntegralTerm, - safeDivisionUnboundedTests @(IntN 4) "safeMod" IntN safeMod safeMod' mod pevalModBoundedIntegralTerm, - safeDivModBoundedTests @(IntN 4) "safeDivMod" IntN safeDivMod safeDivMod' divMod pevalDivBoundedIntegralTerm pevalModBoundedIntegralTerm, - safeDivisionBoundedTests @(IntN 4) "safeQuot" IntN safeQuot safeQuot' quot pevalQuotBoundedIntegralTerm, - safeDivisionUnboundedTests @(IntN 4) "safeRem" IntN safeRem safeRem' rem pevalRemBoundedIntegralTerm, - safeDivModBoundedTests @(IntN 4) "safeQuotRem" IntN safeQuotRem safeQuotRem' quotRem pevalQuotBoundedIntegralTerm pevalRemBoundedIntegralTerm - ] - ], - testGroup - "SafeLinearArith" - [ testGroup - "IntN" - [ testProperty "safeAdd on concrete" $ \(i :: Int8, j :: Int8) -> - ioProperty $ - let iint = fromIntegral i :: Integer - jint = fromIntegral j - in safeAdd (toSym i :: SymIntN 8) (toSym j) - @=? mrgIf - (iint + jint .< fromIntegral (i + j)) - (throwError Underflow) - ( mrgIf - (iint + jint .> fromIntegral (i + j)) - (throwError Overflow) - (mrgSingle $ toSym $ i + j :: ExceptT ArithException UnionM (SymIntN 8)) - ), - testProperty "safeMinus on concrete" $ \(i :: Int8, j :: Int8) -> - ioProperty $ - let iint = fromIntegral i :: Integer - jint = fromIntegral j - in safeMinus (toSym i :: SymIntN 8) (toSym j) - @=? mrgIf - (iint - jint .< fromIntegral (i - j)) - (throwError Underflow) - ( mrgIf - (iint - jint .> fromIntegral (i - j)) - (throwError Overflow) - (mrgSingle $ toSym $ i - j :: ExceptT ArithException UnionM (SymIntN 8)) - ), - testProperty "safeNeg on concrete" $ \(i :: Int8) -> - ioProperty $ - let iint = fromIntegral i :: Integer - in safeNeg (toSym i :: SymIntN 8) - @=? mrgIf - (-iint .< fromIntegral (-i)) - (throwError Underflow) - ( mrgIf - (-iint .> fromIntegral (-i)) - (throwError Overflow) - (mrgSingle $ toSym $ -i :: ExceptT ArithException UnionM (SymIntN 8)) - ) - ], - testGroup - "WordN" - [ testProperty "safeAdd on concrete" $ \(i :: Word8, j :: Word8) -> - ioProperty $ - let iint = fromIntegral i :: Integer - jint = fromIntegral j - in safeAdd (toSym i :: SymWordN 8) (toSym j) - @=? mrgIf - (iint + jint .< fromIntegral (i + j)) - (throwError Underflow) - ( mrgIf - (iint + jint .> fromIntegral (i + j)) - (throwError Overflow) - (mrgSingle $ toSym $ i + j :: ExceptT ArithException UnionM (SymWordN 8)) - ), - testProperty "safeMinus on concrete" $ \(i :: Word8, j :: Word8) -> - ioProperty $ - let iint = fromIntegral i :: Integer - jint = fromIntegral j - in safeMinus (toSym i :: SymWordN 8) (toSym j) - @=? mrgIf - (iint - jint .< fromIntegral (i - j)) - (throwError Underflow) - ( mrgIf - (iint - jint .> fromIntegral (i - j)) - (throwError Overflow) - (mrgSingle $ toSym $ i - j :: ExceptT ArithException UnionM (SymWordN 8)) - ), - testProperty "safeNeg on concrete" $ \(i :: Word8) -> - ioProperty $ - let iint = fromIntegral i :: Integer - in safeNeg (toSym i :: SymWordN 8) - @=? mrgIf - (-iint .< fromIntegral (-i)) - (throwError Underflow) - ( mrgIf - (-iint .> fromIntegral (-i)) - (throwError Overflow) - (mrgSingle $ toSym $ -i :: ExceptT ArithException UnionM (SymWordN 8)) - ) - ] - ], - testGroup - "SOrd" - [ testProperty "SOrd on concrete" $ \(i :: Integer, j :: Integer) -> ioProperty $ do - let iu :: WordN 4 = fromInteger i - let ju :: WordN 4 = fromInteger j - let is :: IntN 4 = fromInteger i - let js :: IntN 4 = fromInteger j - let normalizeu k = k - k `div` 16 * 16 - let normalizes k = if normalizeu k >= 8 then normalizeu k - 16 else normalizeu k - (con iu :: SymWordN 4) .<= con ju @=? (con (normalizeu i <= normalizeu j) :: SymBool) - (con iu :: SymWordN 4) .< con ju @=? (con (normalizeu i < normalizeu j) :: SymBool) - (con iu :: SymWordN 4) .>= con ju @=? (con (normalizeu i >= normalizeu j) :: SymBool) - (con iu :: SymWordN 4) .> con ju @=? (con (normalizeu i > normalizeu j) :: SymBool) - (con iu :: SymWordN 4) - `symCompare` con ju - @=? (normalizeu i `symCompare` normalizeu j :: UnionM Ordering) - (con is :: SymIntN 4) .<= con js @=? (con (normalizes i <= normalizes j) :: SymBool) - (con is :: SymIntN 4) .< con js @=? (con (normalizes i < normalizes j) :: SymBool) - (con is :: SymIntN 4) .>= con js @=? (con (normalizes i >= normalizes j) :: SymBool) - (con is :: SymIntN 4) .> con js @=? (con (normalizes i > normalizes j) :: SymBool) - (con is :: SymIntN 4) - `symCompare` con js - @=? (normalizes i `symCompare` normalizes j :: UnionM Ordering), - testCase "SOrd on symbolic" $ do - au .<= bu @=? SymBool (pevalLeNumTerm aut but) - au .< bu @=? SymBool (pevalLtNumTerm aut but) - au .>= bu @=? SymBool (pevalGeNumTerm aut but) - au .> bu @=? SymBool (pevalGtNumTerm aut but) - (au `symCompare` bu :: UnionM Ordering) - @=? mrgIf (au .< bu) (mrgSingle LT) (mrgIf (au .== bu) (mrgSingle EQ) (mrgSingle GT)) - - as .<= bs @=? SymBool (pevalLeNumTerm ast bst) - as .< bs @=? SymBool (pevalLtNumTerm ast bst) - as .>= bs @=? SymBool (pevalGeNumTerm ast bst) - as .> bs @=? SymBool (pevalGtNumTerm ast bst) - (as `symCompare` bs :: UnionM Ordering) - @=? mrgIf (as .< bs) (mrgSingle LT) (mrgIf (as .== bs) (mrgSingle EQ) (mrgSingle GT)) - ], - testGroup - "Bits" - [ testCase ".&." $ do - au .&. bu @=? SymWordN (pevalAndBitsTerm aut but) - as .&. bs @=? SymIntN (pevalAndBitsTerm ast bst), - testCase ".|." $ do - au .|. bu @=? SymWordN (pevalOrBitsTerm aut but) - as .|. bs @=? SymIntN (pevalOrBitsTerm ast bst), - testCase "xor" $ do - au `xor` bu @=? SymWordN (pevalXorBitsTerm aut but) - as `xor` bs @=? SymIntN (pevalXorBitsTerm ast bst), - testCase "complement" $ do - complement au @=? SymWordN (pevalComplementBitsTerm aut) - complement as @=? SymIntN (pevalComplementBitsTerm ast), - testCase "shift" $ do - shift au 1 @=? SymWordN (pevalShiftLeftTerm aut $ conTerm 1) - shift as 1 @=? SymIntN (pevalShiftLeftTerm ast $ conTerm 1) - shift au (-1) @=? SymWordN (pevalShiftRightTerm aut $ conTerm 1) - shift as (-1) @=? SymIntN (pevalShiftRightTerm ast $ conTerm 1), - testCase "rotate" $ do - rotate au 1 @=? SymWordN (pevalRotateLeftTerm aut $ conTerm 1) - rotate as 1 @=? SymIntN (pevalRotateLeftTerm ast $ conTerm 1) - rotate au (-1) @=? SymWordN (pevalRotateRightTerm aut $ conTerm 1) - rotate as (-1) @=? SymIntN (pevalRotateRightTerm ast $ conTerm 1), - testCase "bitSize" $ do - bitSizeMaybe au @=? Just 4 - bitSizeMaybe as @=? Just 4, - testCase "isSigned" $ do - isSigned au @=? False - isSigned as @=? True, - testCase "testBit would only work on concrete ones" $ do - testBit (con 3 :: SymWordN 4) 1 @=? True - testBit (con 3 :: SymWordN 4) 2 @=? False - testBit (con 3 :: SymIntN 4) 1 @=? True - testBit (con 3 :: SymIntN 4) 2 @=? False, - testCase "bit would work" $ do - bit 1 @=? (con 2 :: SymWordN 4) - bit 1 @=? (con 2 :: SymIntN 4), - testCase "popCount would only work on concrete ones" $ do - popCount (con 3 :: SymWordN 4) @=? 2 - popCount (con 3 :: SymWordN 4) @=? 2 - popCount (con 3 :: SymIntN 4) @=? 2 - popCount (con 3 :: SymIntN 4) @=? 2 - ], - testGroup - "sizedBVConcat" - [ testCase "sizedBVConcat" $ - sizedBVConcat - (ssym "a" :: SymWordN 4) - (ssym "b" :: SymWordN 3) - @=? SymWordN - ( pevalBVConcatTerm - (ssymTerm "a" :: Term (WordN 4)) - (ssymTerm "b" :: Term (WordN 3)) - ) - ], - testGroup - "sizedBVExt for Sym BV" - [ testCase "sizedBVZext" $ do - sizedBVZext (Proxy @6) au @=? SymWordN (pevalBVExtendTerm False (Proxy @6) aut) - sizedBVZext (Proxy @6) as @=? SymIntN (pevalBVExtendTerm False (Proxy @6) ast), - testCase "sizedBVSext" $ do - sizedBVSext (Proxy @6) au @=? SymWordN (pevalBVExtendTerm True (Proxy @6) aut) - sizedBVSext (Proxy @6) as @=? SymIntN (pevalBVExtendTerm True (Proxy @6) ast), - testCase "sizedBVExt" $ do - sizedBVExt (Proxy @6) au @=? SymWordN (pevalBVExtendTerm False (Proxy @6) aut) - sizedBVExt (Proxy @6) as @=? SymIntN (pevalBVExtendTerm True (Proxy @6) ast) - ], - testGroup - "sizedBVSelect for Sym BV" - [ testCase "sizedBVSelect" $ do - sizedBVSelect (Proxy @2) (Proxy @1) au - @=? SymWordN (pevalBVSelectTerm (Proxy @2) (Proxy @1) aut) - sizedBVSelect (Proxy @2) (Proxy @1) as - @=? SymIntN (pevalBVSelectTerm (Proxy @2) (Proxy @1) ast) - ], - testGroup - "conversion between Int8 and Sym BV" - [ testCase "toSym" $ do - toSym (0 :: Int8) @=? (con 0 :: SymIntN 8) - toSym (-127 :: Int8) @=? (con $ -127 :: SymIntN 8) - toSym (-128 :: Int8) @=? (con $ -128 :: SymIntN 8) - toSym (127 :: Int8) @=? (con 127 :: SymIntN 8), - testCase "toCon" $ do - toCon (con 0 :: SymIntN 8) @=? Just (0 :: Int8) - toCon (con $ -127 :: SymIntN 8) @=? Just (-127 :: Int8) - toCon (con $ -128 :: SymIntN 8) @=? Just (-128 :: Int8) - toCon (con 127 :: SymIntN 8) @=? Just (127 :: Int8) - ], - testGroup - "conversion between Word8 and Sym BV" - [ testCase "toSym" $ do - toSym (0 :: Word8) @=? (con 0 :: SymWordN 8) - toSym (1 :: Word8) @=? (con 1 :: SymWordN 8) - toSym (255 :: Word8) @=? (con 255 :: SymWordN 8), - testCase "toCon" $ do - toCon (con 0 :: SymWordN 8) @=? Just (0 :: Word8) - toCon (con 1 :: SymWordN 8) @=? Just (1 :: Word8) - toCon (con 255 :: SymWordN 8) @=? Just (255 :: Word8) - ] - ], - testGroup - "TabularFun" - [ testCase "#" $ - (ssym "a" :: SymInteger =~> SymInteger) - # ssym "b" - @=? SymInteger (pevalTabularFunApplyTerm (ssymTerm "a" :: Term (Integer =-> Integer)) (ssymTerm "b")), - testCase "apply" $ - apply - (ssym "f" :: SymInteger =~> SymInteger =~> SymInteger) - (ssym "a") - (ssym "b") - @=? SymInteger - ( pevalTabularFunApplyTerm - ( pevalTabularFunApplyTerm - (ssymTerm "f" :: Term (Integer =-> Integer =-> Integer)) - (ssymTerm "a") - ) - (ssymTerm "b") - ) - ], - testGroup - "GeneralFun" - [ testCase "evaluate" $ do - evaluateSym - False - (buildModel ("a" := (1 :: Integer), "b" := (2 :: Integer))) - (con ("a" --> "a" + "b") :: SymInteger -~> SymInteger) - @=? (con ("a" --> "a" + 2) :: SymInteger -~> SymInteger) - evaluateSym - False - (buildModel ("a" := (1 :: Integer), "b" := (2 :: Integer), "c" := (3 :: Integer))) - (con ("a" --> con ("b" --> "a" + "b" + "c")) :: SymInteger -~> SymInteger -~> SymInteger) - @=? con ("a" --> con ("b" --> "a" + "b" + 3) :: Integer --> Integer --> Integer), - testCase "#" $ do - let f :: SymInteger -~> SymInteger -~> SymInteger = - con ("a" --> con ("b" --> "a" + "b")) - f # ssym "x" @=? con ("b" --> "x" + "b"), - testCase "apply" $ do - let f :: SymInteger -~> SymInteger -~> SymInteger = - con ("a" --> con ("b" --> "a" + "b")) - apply f "x" "y" @=? "x" + "y" - ], - testGroup - "Symbolic size" - [ testCase "symSize" $ do - symSize (ssym "a" :: SymInteger) @=? 1 - symSize (con 1 :: SymInteger) @=? 1 - symSize (con 1 + ssym "a" :: SymInteger) @=? 3 - symSize (ssym "a" + ssym "a" :: SymInteger) @=? 2 - symSize (-(ssym "a") :: SymInteger) @=? 2 - symSize (symIte (ssym "a" :: SymBool) (ssym "b") (ssym "c") :: SymInteger) @=? 4, - testCase "symsSize" $ symsSize [ssym "a" :: SymInteger, ssym "a" + ssym "a"] @=? 2 - ], - let asymbol :: TypedSymbol Integer = "a" - bsymbol :: TypedSymbol Bool = "b" - csymbol :: TypedSymbol Integer = "c" - dsymbol :: TypedSymbol Bool = "d" - esymbol :: TypedSymbol (WordN 4) = "e" - fsymbol :: TypedSymbol (IntN 4) = "f" - gsymbol :: TypedSymbol (WordN 16) = "g" - hsymbol :: TypedSymbol (IntN 16) = "h" - va :: Integer = 1 - vc :: Integer = 2 - ve :: WordN 4 = 3 - vf :: IntN 4 = 4 - vg :: WordN 16 = 5 - vh :: IntN 16 = 6 - in testCase - "construting Model from ModelSymPair" - $ do - buildModel ("a" := va) @=? Model (M.singleton (someTypedSymbol asymbol) (toModelValue va)) - buildModel ("a" := va, "b" := True) - @=? Model - ( M.fromList - [ (someTypedSymbol asymbol, toModelValue va), - (someTypedSymbol bsymbol, toModelValue True) - ] - ) - buildModel - ( "a" := va, - "b" := True, - "c" := vc - ) - @=? Model - ( M.fromList - [ (someTypedSymbol asymbol, toModelValue va), - (someTypedSymbol bsymbol, toModelValue True), - (someTypedSymbol csymbol, toModelValue vc) - ] - ) - buildModel - ( "a" := va, - "b" := True, - "c" := vc, - "d" := False - ) - @=? Model - ( M.fromList - [ (someTypedSymbol asymbol, toModelValue va), - (someTypedSymbol bsymbol, toModelValue True), - (someTypedSymbol csymbol, toModelValue vc), - (someTypedSymbol dsymbol, toModelValue False) - ] - ) - buildModel - ( "a" := va, - "b" := True, - "c" := vc, - "d" := False, - "e" := ve - ) - @=? Model - ( M.fromList - [ (someTypedSymbol asymbol, toModelValue va), - (someTypedSymbol bsymbol, toModelValue True), - (someTypedSymbol csymbol, toModelValue vc), - (someTypedSymbol dsymbol, toModelValue False), - (someTypedSymbol esymbol, toModelValue ve) - ] - ) - buildModel - ( "a" := va, - "b" := True, - "c" := vc, - "d" := False, - "e" := ve, - "f" := vf - ) - @=? Model - ( M.fromList - [ (someTypedSymbol asymbol, toModelValue va), - (someTypedSymbol bsymbol, toModelValue True), - (someTypedSymbol csymbol, toModelValue vc), - (someTypedSymbol dsymbol, toModelValue False), - (someTypedSymbol esymbol, toModelValue ve), - (someTypedSymbol fsymbol, toModelValue vf) - ] - ) - buildModel - ( "a" := va, - "b" := True, - "c" := vc, - "d" := False, - "e" := ve, - "f" := vf, - "g" := vg - ) - @=? Model - ( M.fromList - [ (someTypedSymbol asymbol, toModelValue va), - (someTypedSymbol bsymbol, toModelValue True), - (someTypedSymbol csymbol, toModelValue vc), - (someTypedSymbol dsymbol, toModelValue False), - (someTypedSymbol esymbol, toModelValue ve), - (someTypedSymbol fsymbol, toModelValue vf), - (someTypedSymbol gsymbol, toModelValue vg) - ] - ) - buildModel - ( "a" := va, - "b" := True, - "c" := vc, - "d" := False, - "e" := ve, - "f" := vf, - "g" := vg, - "h" := vh - ) - @=? Model - ( M.fromList - [ (someTypedSymbol asymbol, toModelValue va), - (someTypedSymbol bsymbol, toModelValue True), - (someTypedSymbol csymbol, toModelValue vc), - (someTypedSymbol dsymbol, toModelValue False), - (someTypedSymbol esymbol, toModelValue ve), - (someTypedSymbol fsymbol, toModelValue vf), - (someTypedSymbol gsymbol, toModelValue vg), - (someTypedSymbol hsymbol, toModelValue vh) - ] - ) - ] diff --git a/test/Grisette/IR/SymPrim/Data/TabularFunTests.hs b/test/Grisette/IR/SymPrim/Data/TabularFunTests.hs deleted file mode 100644 --- a/test/Grisette/IR/SymPrim/Data/TabularFunTests.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} - -module Grisette.IR.SymPrim.Data.TabularFunTests (tabularFunTests) where - -import Grisette.Core.Data.Class.Function (Function ((#))) -import Grisette.IR.SymPrim.Data.TabularFun - ( type (=->) (TabularFun), - ) -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit ((@=?)) - -tabularFunTests :: Test -tabularFunTests = - testGroup - "TabularFun" - [ testCase "Tabular application" $ do - let f :: Integer =-> Integer = TabularFun [(1, 2), (3, 4)] 5 - (f # 0) @=? 5 - (f # 1) @=? 2 - (f # 2) @=? 5 - (f # 3) @=? 4 - (f # 4) @=? 5 - ] diff --git a/test/Grisette/Lib/Control/ApplicativeTest.hs b/test/Grisette/Lib/Control/ApplicativeTest.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/Lib/Control/ApplicativeTest.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Grisette.Lib.Control.ApplicativeTest + ( applicativeFunctionTests, + ) +where + +import Control.Applicative (Alternative (empty)) +import Control.Monad.State + ( MonadState (get, put), + MonadTrans (lift), + StateT (runStateT), + ) +import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) +import Grisette + ( UnionM, + UnionMergeable1 (mrgIfPropagatedStrategy), + mrgAsum, + mrgEmpty, + mrgPure, + mrgReturn, + mrgSingle, + ) +import Grisette.Lib.Control.Applicative + ( mrgLiftA, + mrgLiftA2, + mrgLiftA3, + mrgMany, + mrgOptional, + mrgSome, + (.*>), + (.<*), + (.<**>), + (.<*>), + (.<|>), + ) +import Grisette.TestUtil.NoMerge + ( NoMerge (NoMerge), + noMergeNotMerged, + oneNotMerged, + ) +import Test.Framework + ( Test, + TestOptions' (topt_timeout), + plusTestOptions, + testGroup, + ) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@?=)) + +applicativeFunctionTests :: Test +applicativeFunctionTests = + testGroup + "Applicative" + [ testCase "mrgPure" $ (mrgPure 1 :: UnionM Integer) @?= mrgSingle 1, + testGroup + ".<*>" + [ testCase "merge result" $ do + let actual = + (return (\x -> x * x)) + .<*> mrgIfPropagatedStrategy "a" (return $ -1) (return 1) + actual @?= (mrgSingle 1 :: UnionM Integer), + testCase "merge arguments" $ do + let actual = (return (const NoMerge)) .<*> oneNotMerged + actual @?= (mrgSingle NoMerge :: UnionM NoMerge) + ], + testGroup + "mrgLiftA2" + [ testCase "merge result" $ do + let actual = + mrgLiftA2 (const $ const 1) noMergeNotMerged noMergeNotMerged + let expected = mrgPure 1 :: UnionM Int + actual @?= expected, + testCase "merge argument" $ do + let actual = + mrgLiftA2 (const $ const NoMerge) oneNotMerged oneNotMerged + let expected = mrgPure NoMerge + actual @?= expected + ], + testGroup + ".*>" + [ testCase "merge result" $ + noMergeNotMerged .*> oneNotMerged @?= mrgSingle 1, + testCase "merge arguments" $ + oneNotMerged .*> return NoMerge @?= mrgSingle NoMerge + ], + testGroup + ".<*" + [ testCase "merge result" $ + oneNotMerged .<* noMergeNotMerged @?= mrgSingle 1, + testCase "merge arguments" $ + return NoMerge .<* oneNotMerged @?= mrgSingle NoMerge + ], + testCase "mrgEmpty" $ + (mrgEmpty :: MaybeT UnionM Integer) @?= MaybeT (mrgReturn Nothing), + testGroup + ".<|>" + [ testCase "merge result" $ + return 1 .<|> return 2 @?= (mrgSingle 1 :: MaybeT UnionM Integer), + testCase "merge lhs" $ do + let lhs = + MaybeT $ + mrgIfPropagatedStrategy "a" (return Nothing) (return Nothing) + let expected = mrgSingle NoMerge :: MaybeT UnionM NoMerge + lhs .<|> return NoMerge @?= expected + ], + plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $ + testGroup + "mrgSome" + [ testCase "merge" $ + runStateT (mrgSome f) 100 @?= (mrgSingle (replicate 100 (), 0)), + testCase "single" $ + runStateT (mrgSome f) 1 @?= (mrgSingle ([()], 0)), + testCase "zero" $ + runStateT (mrgSome f) 0 @?= MaybeT (mrgReturn Nothing) + ], + plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $ + testGroup + "mrgMany" + [ testCase "merge" $ + runStateT (mrgMany f) 100 @?= (mrgSingle (replicate 100 (), 0)), + testCase "single" $ + runStateT (mrgMany f) 1 @?= (mrgSingle ([()], 0)), + testCase "zero" $ + runStateT (mrgMany f) 0 @?= (mrgSingle ([], 0)) + ], + testGroup + ".<**>" + [ testCase "merge result" $ do + let actual = + mrgIfPropagatedStrategy "a" (return $ -1) (return 1) + .<**> (return (\x -> x * x)) + actual @?= (mrgSingle 1 :: UnionM Integer), + testCase "merge arguments" $ do + let actual = oneNotMerged .<**> (return (const NoMerge)) + actual @?= (mrgSingle NoMerge :: UnionM NoMerge) + ], + testGroup + "mrgLiftA" + [ testCase "merge result" $ do + let actual = mrgLiftA (const 1) noMergeNotMerged + let expected = mrgReturn 1 :: UnionM Int + actual @?= expected, + testCase "merge argument" $ do + let actual = mrgLiftA (const NoMerge) oneNotMerged + let expected = mrgReturn NoMerge + actual @?= expected + ], + testGroup + "mrgLiftA3" + [ testCase "merge result" $ do + let actual = + mrgLiftA3 + (const $ const $ const 1) + noMergeNotMerged + noMergeNotMerged + noMergeNotMerged + let expected = mrgReturn 1 :: UnionM Int + actual @?= expected, + testCase "merge argument" $ do + let actual = + mrgLiftA3 + (const $ const $ const NoMerge) + oneNotMerged + oneNotMerged + oneNotMerged + let expected = mrgReturn NoMerge + actual @?= expected + ], + testGroup + "mrgOptional" + [ testCase "one" $ do + let actual = + mrgOptional + ( MaybeT $ + mrgIfPropagatedStrategy + "a" + (return $ Just 1) + (return $ Just 1) + ) + let expected = mrgSingle (Just 1) :: MaybeT UnionM (Maybe Int) + actual @?= expected, + testCase "none" $ do + let actual = + mrgOptional + ( MaybeT $ + mrgIfPropagatedStrategy "a" (return Nothing) (return Nothing) + ) + let expected = mrgSingle Nothing :: MaybeT UnionM (Maybe Int) + actual @?= expected + ], + plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $ + testGroup + "mrgAsum" + [ testCase "merge" $ do + let none = + MaybeT $ + mrgIfPropagatedStrategy "a" (return Nothing) (return Nothing) + let expected = + MaybeT (mrgSingle Nothing) :: + MaybeT UnionM (Maybe Int) + mrgAsum (replicate 100 none) @?= expected, + testCase "semantics" $ do + (mrgAsum [mrgEmpty, mrgEmpty] :: MaybeT UnionM Integer) + @?= mrgEmpty + (mrgAsum [mrgPure 1, mrgEmpty] :: MaybeT UnionM Integer) + @?= mrgPure 1 + (mrgAsum [mrgEmpty, mrgPure 1] :: MaybeT UnionM Integer) + @?= mrgPure 1 + (mrgAsum [mrgPure 2, mrgPure 1] :: MaybeT UnionM Integer) + @?= mrgPure 2 + ] + ] + +f :: StateT Int (MaybeT UnionM) () +f = do + i <- get + if (i == 0) + then empty + else do + put (i - 1) + lift . lift $ + mrgIfPropagatedStrategy "a" (return ()) (return ()) diff --git a/test/Grisette/Lib/Control/Monad/ExceptTests.hs b/test/Grisette/Lib/Control/Monad/ExceptTests.hs --- a/test/Grisette/Lib/Control/Monad/ExceptTests.hs +++ b/test/Grisette/Lib/Control/Monad/ExceptTests.hs @@ -2,22 +2,34 @@ module Grisette.Lib.Control.Monad.ExceptTests (monadExceptFunctionTests) where +import Control.Monad.Error.Class (MonadError (throwError)) import Control.Monad.Trans.Except (ExceptT (ExceptT), runExceptT) -import Grisette.Core.Control.Monad.UnionM (UnionM) -import Grisette.Core.Data.Class.ITEOp (ITEOp (symIte)) -import Grisette.Core.Data.Class.SimpleMergeable - ( UnionLike (unionIf), +import Grisette + ( ITEOp (symIte), + SEq ((.==)), + UnionM, + UnionMergeable1 (mrgIfPropagatedStrategy), + mrgIf, mrgSingle, ) -import Grisette.IR.SymPrim.Data.SymPrim (SymBool) import Grisette.Lib.Control.Monad.Except ( mrgCatchError, + mrgHandleError, + mrgLiftEither, + mrgMapError, + mrgModifyError, mrgThrowError, + mrgTryError, + mrgWithError, ) +import Grisette.SymPrim (SymBool, SymInteger) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit ((@?=)) +exceptUnion :: ExceptT SymInteger UnionM SymInteger +exceptUnion = mrgIfPropagatedStrategy "a" (throwError "b") (return "c") + monadExceptFunctionTests :: Test monadExceptFunctionTests = testGroup @@ -26,9 +38,53 @@ runExceptT (mrgThrowError 1 :: ExceptT Integer UnionM ()) @?= mrgSingle (Left 1), testCase "mrgCatchError" $ - ( ExceptT (unionIf "a" (return $ Left "b") (return $ Right "c")) :: + ( mrgIfPropagatedStrategy "a" (throwError "b") (return "c") :: ExceptT SymBool UnionM SymBool ) `mrgCatchError` return - @?= mrgSingle (symIte "a" "b" "c") + @?= mrgSingle (symIte "a" "b" "c"), + testCase "mrgLiftEither" $ do + runExceptT (mrgLiftEither (Left "a") :: ExceptT SymBool UnionM ()) + @?= mrgSingle (Left "a"), + testCase "mrgTryError" $ do + let expected = mrgIf "a" (mrgSingle (Left "b")) (mrgSingle (Right "c")) + mrgTryError exceptUnion @?= expected, + testCase "mrgWithError" $ do + let expected = mrgIf "a" (mrgThrowError $ "b" + 1) (mrgSingle "c") + mrgWithError (+ 1) exceptUnion @?= expected, + testCase "mrgCatchError" $ + mrgHandleError + return + ( mrgIfPropagatedStrategy "a" (throwError "b") (return "c") :: + ExceptT SymBool UnionM SymBool + ) + @?= mrgSingle (symIte "a" "b" "c"), + testCase "mrgMapError" $ do + let expected = + ( mrgIf + "a" + (mrgThrowError (Just "b")) + (mrgSingle $ ("c" :: SymInteger) .== 1) :: + ExceptT (Maybe SymInteger) UnionM SymBool + ) + mrgMapError + ( \m -> ExceptT $ do + v <- runExceptT m + case v of + Left _ -> error "Should not happen" + Right (Left e) -> return $ Right $ Left $ Just e + Right (Right v) -> return $ Right $ Right $ v .== 1 + ) + exceptUnion + @?= expected, + testCase "mrgModifyError" $ do + let original = + mrgIf "a" (mrgThrowError "b") (mrgSingle "c") :: + ExceptT SymInteger (ExceptT SymBool UnionM) SymInteger + let expected = + mrgIf + "a" + (mrgThrowError $ ("b" :: SymInteger) .== 1) + (mrgSingle "c") + mrgModifyError (.== 1) original @?= expected ] diff --git a/test/Grisette/Lib/Control/Monad/State/ClassTests.hs b/test/Grisette/Lib/Control/Monad/State/ClassTests.hs --- a/test/Grisette/Lib/Control/Monad/State/ClassTests.hs +++ b/test/Grisette/Lib/Control/Monad/State/ClassTests.hs @@ -3,8 +3,7 @@ ) where -import Control.Monad.State.Lazy (state) -import Control.Monad.Trans.State.Lazy (runStateT) +import Control.Monad.Trans.State.Lazy (StateT (StateT), runStateT) import Grisette.Lib.Control.Monad.State.Class ( mrgGet, mrgGets, @@ -28,9 +27,9 @@ testGroup "Class" [ testCase "mrgState" $ mrgStateTest mrgState runStateT, - testCase "mrgGet" $ mrgGetTest state runStateT mrgGet, - testCase "mrgPut" $ mrgPutTest state runStateT mrgPut, - testCase "mrgModify" $ mrgModifyTest state runStateT mrgModify, - testCase "mrgModify'" $ mrgModifyTest state runStateT mrgModify', - testCase "mrgGets" $ mrgGetsTest state runStateT mrgGets + testCase "mrgGet" $ mrgGetTest StateT runStateT mrgGet, + testCase "mrgPut" $ mrgPutTest StateT runStateT mrgPut, + testCase "mrgModify" $ mrgModifyTest StateT runStateT mrgModify, + testCase "mrgModify'" $ mrgModifyTest StateT runStateT mrgModify', + testCase "mrgGets" $ mrgGetsTest StateT runStateT mrgGets ] diff --git a/test/Grisette/Lib/Control/Monad/Trans/ClassTests.hs b/test/Grisette/Lib/Control/Monad/Trans/ClassTests.hs --- a/test/Grisette/Lib/Control/Monad/Trans/ClassTests.hs +++ b/test/Grisette/Lib/Control/Monad/Trans/ClassTests.hs @@ -6,14 +6,14 @@ where import Control.Monad.Except (ExceptT) -import Grisette.Core.Control.Monad.UnionM (UnionM) -import Grisette.Core.Data.Class.ITEOp (ITEOp (symIte)) -import Grisette.Core.Data.Class.SimpleMergeable - ( UnionLike (single, unionIf), +import Grisette + ( ITEOp (symIte), + UnionM, + UnionMergeable1 (mrgIfPropagatedStrategy), mrgSingle, ) -import Grisette.IR.SymPrim.Data.SymPrim (SymBool) import Grisette.Lib.Control.Monad.Trans (mrgLift) +import Grisette.SymPrim (SymBool) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit ((@?=)) @@ -24,7 +24,7 @@ "Class" [ testCase "mrgLift" $ do ( mrgLift - ( unionIf "a" (single "b") (single "c") :: + ( mrgIfPropagatedStrategy "a" (return "b") (return "c") :: UnionM SymBool ) :: ExceptT SymBool UnionM SymBool diff --git a/test/Grisette/Lib/Control/Monad/Trans/ExceptTests.hs b/test/Grisette/Lib/Control/Monad/Trans/ExceptTests.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/Lib/Control/Monad/Trans/ExceptTests.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Grisette.Lib.Control.Monad.Trans.ExceptTests (exceptTests) where + +import Control.Monad.Except + ( ExceptT (ExceptT), + MonadError (throwError), + runExceptT, + ) +import Grisette + ( ITEOp (symIte), + UnionM, + UnionMergeable1 (mrgIfPropagatedStrategy), + mrgIf, + mrgSingle, + ) +import Grisette.Lib.Control.Monad.Trans.Except + ( mrgCatchE, + mrgExcept, + mrgRunExceptT, + mrgThrowE, + mrgWithExceptT, + ) +import Grisette.SymPrim (SymBool, SymInteger) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@?=)) + +unmergedExceptT :: ExceptT SymInteger UnionM SymBool +unmergedExceptT = + mrgIfPropagatedStrategy + "e" + (mrgIfPropagatedStrategy "c" (throwError "a") (throwError "b")) + (return "d") + +mergedExceptT :: ExceptT SymInteger UnionM SymBool +mergedExceptT = + ExceptT $ + mrgIf "e" (mrgSingle (Left (symIte "c" "a" "b"))) (mrgSingle (Right "d")) + +mergedExceptTPlus1 :: ExceptT SymInteger UnionM SymBool +mergedExceptTPlus1 = + ExceptT $ + mrgIf "e" (mrgSingle (Left (symIte "c" "a" "b" + 1))) (mrgSingle (Right "d")) + +exceptTests :: Test +exceptTests = + testGroup + "Except" + [ testCase "mrgExcept" $ do + let actual = mrgExcept (Left "a") :: ExceptT SymInteger UnionM SymBool + let expected = ExceptT (mrgSingle (Left "a")) + actual @?= expected, + testCase "mrgRunExceptT" $ do + mrgRunExceptT unmergedExceptT @?= runExceptT mergedExceptT, + testCase "mrgWithExceptT" $ do + mrgWithExceptT (+ 1) unmergedExceptT @?= mergedExceptTPlus1, + testCase "mrgThrowE" $ do + let actual = mrgThrowE "a" :: ExceptT SymInteger UnionM SymBool + actual @?= ExceptT (mrgSingle (Left "a")), + testCase "mrgCatchE" $ do + let actual = mrgCatchE unmergedExceptT (throwError . (+ 1)) + actual @?= mergedExceptTPlus1 + ] diff --git a/test/Grisette/Lib/Control/Monad/Trans/State/Common.hs b/test/Grisette/Lib/Control/Monad/Trans/State/Common.hs --- a/test/Grisette/Lib/Control/Monad/Trans/State/Common.hs +++ b/test/Grisette/Lib/Control/Monad/Trans/State/Common.hs @@ -14,18 +14,24 @@ ) where -import Grisette.Core.Control.Monad.UnionM (UnionM, unionSize) -import Grisette.Core.Data.Class.LogicalOp (LogicalOp ((.&&))) -import Grisette.Core.Data.Class.SimpleMergeable - ( SimpleMergeable (mrgIte), - UnionLike (unionIf), +import Grisette + ( LogicalOp ((.&&)), + MonadUnion, + SimpleMergeable (mrgIte), + SymBool, + UnionM, + UnionMergeable1 (mrgIfPropagatedStrategy), mrgSingle, + unionSize, ) -import Grisette.Core.Data.Class.TestValues (ssymBool) -import Grisette.IR.SymPrim.Data.SymPrim (SymBool) +import Grisette.Core.Data.Class.TestValues + ( ssymBool, + ) import Grisette.TestUtil.SymbolicAssertion ((@?=~)) import Test.HUnit (Assertion, (@?=)) +type StateConstructor stateT s a = (s -> UnionM (a, s)) -> stateT s UnionM a + type StateFunc stateT s a = (s -> (a, s)) -> stateT s UnionM a type RunStateFunc stateT s a = stateT s UnionM a -> s -> UnionM (a, s) @@ -52,26 +58,28 @@ type GetsFunc stateT s a = (s -> a) -> stateT s UnionM a +bodyA :: SymBool -> UnionM (SymBool, SymBool) +bodyA s = return (s .&& ssymBool "av", s .&& ssymBool "as") + stateA :: - StateFunc stateT SymBool SymBool -> stateT SymBool UnionM SymBool -stateA state = state (\s -> (s .&& ssymBool "av", s .&& ssymBool "as")) + StateConstructor stateT SymBool SymBool -> stateT SymBool UnionM SymBool +stateA state = state bodyA +bodyB :: SymBool -> UnionM (SymBool, SymBool) +bodyB s = return (s .&& ssymBool "bv", s .&& ssymBool "bs") + stateB :: - StateFunc stateT SymBool SymBool -> stateT SymBool UnionM SymBool -stateB state = state (\s -> (s .&& ssymBool "bv", s .&& ssymBool "bs")) + StateConstructor stateT SymBool SymBool -> stateT SymBool UnionM SymBool +stateB state = state bodyB stateAB :: - (UnionLike (stateT SymBool UnionM)) => - StateFunc stateT SymBool SymBool -> + (UnionMergeable1 (stateT SymBool UnionM)) => + StateConstructor stateT SymBool SymBool -> stateT SymBool UnionM SymBool -stateAB state = - unionIf - (ssymBool "c") - (stateA state) - (stateB state) +stateAB state = mrgIfPropagatedStrategy (ssymBool "c") (state bodyA) (state bodyB) mrgStateTest :: - (UnionLike (stateT SymBool UnionM)) => + (MonadUnion (stateT SymBool UnionM)) => StateFunc stateT SymBool SymBool -> RunStateFunc stateT SymBool SymBool -> Assertion @@ -80,7 +88,7 @@ mrgState (\s -> (s .&& ssymBool "av", s .&& ssymBool "as")) let b = mrgState (\s -> (s .&& ssymBool "bv", s .&& ssymBool "bs")) - let actual = runStateT (unionIf (ssymBool "c") a b) (ssymBool "d") + let actual = runStateT (mrgIfPropagatedStrategy (ssymBool "c") a b) (ssymBool "d") let expected = mrgSingle ( mrgIte @@ -96,8 +104,8 @@ actual @?=~ expected mrgRunStateTTest :: - (UnionLike (stateT SymBool UnionM)) => - StateFunc stateT SymBool SymBool -> + (MonadUnion (stateT SymBool UnionM)) => + StateConstructor stateT SymBool SymBool -> RunStateFunc stateT SymBool SymBool -> Assertion mrgRunStateTTest state mrgRunStateT = do @@ -117,8 +125,8 @@ actual @?=~ expected mrgEvalStateTTest :: - (UnionLike (stateT SymBool UnionM)) => - StateFunc stateT SymBool SymBool -> + (MonadUnion (stateT SymBool UnionM)) => + StateConstructor stateT SymBool SymBool -> EvalStateFunc stateT SymBool SymBool -> Assertion mrgEvalStateTTest state mrgEvalStateT = do @@ -134,8 +142,8 @@ actual @?=~ expected mrgExecStateTTest :: - (UnionLike (stateT SymBool UnionM)) => - StateFunc stateT SymBool SymBool -> + (MonadUnion (stateT SymBool UnionM)) => + StateConstructor stateT SymBool SymBool -> ExecStateFunc stateT SymBool SymBool -> Assertion mrgExecStateTTest state mrgExecStateT = do @@ -151,15 +159,15 @@ actual @?=~ expected mrgMapStateTTest :: - (UnionLike (stateT SymBool UnionM)) => - StateFunc stateT SymBool SymBool -> + (MonadUnion (stateT SymBool UnionM)) => + StateConstructor stateT SymBool SymBool -> RunStateFunc stateT SymBool SymBool -> MapStateFunc stateT SymBool SymBool -> Assertion mrgMapStateTTest state runStateT mrgMapStateT = do let a = mrgMapStateT id (stateA state) let b = mrgMapStateT id (stateB state) - let actual = runStateT (unionIf (ssymBool "c") a b) (ssymBool "d") + let actual = runStateT (mrgIfPropagatedStrategy (ssymBool "c") a b) (ssymBool "d") let expected = mrgSingle ( mrgIte @@ -175,15 +183,15 @@ actual @?=~ expected mrgWithStateTTest :: - (UnionLike (stateT SymBool UnionM)) => - StateFunc stateT SymBool SymBool -> + (MonadUnion (stateT SymBool UnionM)) => + StateConstructor stateT SymBool SymBool -> RunStateFunc stateT SymBool SymBool -> WithStateFunc stateT SymBool SymBool -> Assertion mrgWithStateTTest state runStateT mrgWithStateT = do let a = mrgWithStateT (.&& ssymBool "x") (stateA state) let b = mrgWithStateT (.&& ssymBool "y") (stateB state) - let actual = runStateT (unionIf (ssymBool "c") a b) (ssymBool "d") + let actual = runStateT (mrgIfPropagatedStrategy (ssymBool "c") a b) (ssymBool "d") let expected = mrgSingle ( mrgIte @@ -199,15 +207,15 @@ actual @?=~ expected mrgGetTest :: - (UnionLike (stateT SymBool UnionM), Monad (stateT SymBool UnionM)) => - StateFunc stateT SymBool SymBool -> + (MonadUnion (stateT SymBool UnionM), Monad (stateT SymBool UnionM)) => + StateConstructor stateT SymBool SymBool -> RunStateFunc stateT SymBool SymBool -> GetFunc stateT SymBool SymBool -> Assertion mrgGetTest state runStateT mrgGet = do let a = do stateA state; mrgGet let b = do stateB state; mrgGet - let actual = runStateT (unionIf (ssymBool "c") a b) (ssymBool "d") + let actual = runStateT (mrgIfPropagatedStrategy (ssymBool "c") a b) (ssymBool "d") let expected = mrgSingle ( mrgIte @@ -223,15 +231,15 @@ actual @?=~ expected mrgPutTest :: - (UnionLike (stateT SymBool UnionM), Monad (stateT SymBool UnionM)) => - StateFunc stateT SymBool SymBool -> + (MonadUnion (stateT SymBool UnionM), Monad (stateT SymBool UnionM)) => + StateConstructor stateT SymBool SymBool -> RunStateFunc stateT SymBool () -> PutFunc stateT SymBool SymBool -> Assertion mrgPutTest state runStateT mrgPut = do let a = do stateA state; mrgPut (ssymBool "x") let b = do stateB state; mrgPut (ssymBool "y") - let actual = runStateT (unionIf (ssymBool "c") a b) (ssymBool "d") + let actual = runStateT (mrgIfPropagatedStrategy (ssymBool "c") a b) (ssymBool "d") let expected = mrgSingle ( mrgIte (ssymBool "c") ((), ssymBool "x") ((), ssymBool "y") @@ -240,15 +248,15 @@ actual @?=~ expected mrgModifyTest :: - (UnionLike (stateT SymBool UnionM), Monad (stateT SymBool UnionM)) => - StateFunc stateT SymBool SymBool -> + (MonadUnion (stateT SymBool UnionM), Monad (stateT SymBool UnionM)) => + StateConstructor stateT SymBool SymBool -> RunStateFunc stateT SymBool () -> ModifyFunc stateT SymBool SymBool -> Assertion mrgModifyTest state runStateT mrgModify = do let a = do stateA state; mrgModify (.&& ssymBool "x") let b = do stateB state; mrgModify (.&& ssymBool "y") - let actual = runStateT (unionIf (ssymBool "c") a b) (ssymBool "d") + let actual = runStateT (mrgIfPropagatedStrategy (ssymBool "c") a b) (ssymBool "d") let expected = mrgSingle ( mrgIte @@ -264,15 +272,15 @@ actual @?=~ expected mrgGetsTest :: - (UnionLike (stateT SymBool UnionM), Monad (stateT SymBool UnionM)) => - StateFunc stateT SymBool SymBool -> + (MonadUnion (stateT SymBool UnionM), Monad (stateT SymBool UnionM)) => + StateConstructor stateT SymBool SymBool -> RunStateFunc stateT SymBool SymBool -> GetsFunc stateT SymBool SymBool -> Assertion mrgGetsTest state runStateT mrgGets = do let a = do stateA state; mrgGets (.&& ssymBool "x") let b = do stateB state; mrgGets (.&& ssymBool "y") - let actual = runStateT (unionIf (ssymBool "c") a b) (ssymBool "d") + let actual = runStateT (mrgIfPropagatedStrategy (ssymBool "c") a b) (ssymBool "d") let expected = mrgSingle ( mrgIte diff --git a/test/Grisette/Lib/Control/Monad/Trans/State/LazyTests.hs b/test/Grisette/Lib/Control/Monad/Trans/State/LazyTests.hs --- a/test/Grisette/Lib/Control/Monad/Trans/State/LazyTests.hs +++ b/test/Grisette/Lib/Control/Monad/Trans/State/LazyTests.hs @@ -3,8 +3,7 @@ ) where -import Control.Monad.State.Lazy (state) -import Control.Monad.Trans.State.Lazy (runStateT) +import Control.Monad.Trans.State.Lazy (StateT (StateT), runStateT) import Grisette.Lib.Control.Monad.Trans.State.Common ( mrgEvalStateTTest, mrgExecStateTTest, @@ -38,15 +37,15 @@ testGroup "Lazy" [ testCase "mrgState" $ mrgStateTest mrgState runStateT, - testCase "mrgRunStateT" $ mrgRunStateTTest state mrgRunStateT, - testCase "mrgEvalStateT" $ mrgEvalStateTTest state mrgEvalStateT, - testCase "mrgExecStateT" $ mrgExecStateTTest state mrgExecStateT, - testCase "mrgMapStateT" $ mrgMapStateTTest state runStateT mrgMapStateT, + testCase "mrgRunStateT" $ mrgRunStateTTest StateT mrgRunStateT, + testCase "mrgEvalStateT" $ mrgEvalStateTTest StateT mrgEvalStateT, + testCase "mrgExecStateT" $ mrgExecStateTTest StateT mrgExecStateT, + testCase "mrgMapStateT" $ mrgMapStateTTest StateT runStateT mrgMapStateT, testCase "mrgWithStateT" $ - mrgWithStateTTest state runStateT mrgWithStateT, - testCase "mrgGet" $ mrgGetTest state runStateT mrgGet, - testCase "mrgPut" $ mrgPutTest state runStateT mrgPut, - testCase "mrgModify" $ mrgModifyTest state runStateT mrgModify, - testCase "mrgModify'" $ mrgModifyTest state runStateT mrgModify', - testCase "mrgGets" $ mrgGetsTest state runStateT mrgGets + mrgWithStateTTest StateT runStateT mrgWithStateT, + testCase "mrgGet" $ mrgGetTest StateT runStateT mrgGet, + testCase "mrgPut" $ mrgPutTest StateT runStateT mrgPut, + testCase "mrgModify" $ mrgModifyTest StateT runStateT mrgModify, + testCase "mrgModify'" $ mrgModifyTest StateT runStateT mrgModify', + testCase "mrgGets" $ mrgGetsTest StateT runStateT mrgGets ] diff --git a/test/Grisette/Lib/Control/Monad/Trans/State/StrictTests.hs b/test/Grisette/Lib/Control/Monad/Trans/State/StrictTests.hs --- a/test/Grisette/Lib/Control/Monad/Trans/State/StrictTests.hs +++ b/test/Grisette/Lib/Control/Monad/Trans/State/StrictTests.hs @@ -3,8 +3,7 @@ ) where -import Control.Monad.State.Strict (state) -import Control.Monad.Trans.State.Strict (runStateT) +import Control.Monad.Trans.State.Strict (StateT (StateT), runStateT) import Grisette.Lib.Control.Monad.Trans.State.Common ( mrgEvalStateTTest, mrgExecStateTTest, @@ -38,15 +37,15 @@ testGroup "Strict" [ testCase "mrgState" $ mrgStateTest mrgState runStateT, - testCase "mrgRunStateT" $ mrgRunStateTTest state mrgRunStateT, - testCase "mrgEvalStateT" $ mrgEvalStateTTest state mrgEvalStateT, - testCase "mrgExecStateT" $ mrgExecStateTTest state mrgExecStateT, - testCase "mrgMapStateT" $ mrgMapStateTTest state runStateT mrgMapStateT, + testCase "mrgRunStateT" $ mrgRunStateTTest StateT mrgRunStateT, + testCase "mrgEvalStateT" $ mrgEvalStateTTest StateT mrgEvalStateT, + testCase "mrgExecStateT" $ mrgExecStateTTest StateT mrgExecStateT, + testCase "mrgMapStateT" $ mrgMapStateTTest StateT runStateT mrgMapStateT, testCase "mrgWithStateT" $ - mrgWithStateTTest state runStateT mrgWithStateT, - testCase "mrgGet" $ mrgGetTest state runStateT mrgGet, - testCase "mrgPut" $ mrgPutTest state runStateT mrgPut, - testCase "mrgModify" $ mrgModifyTest state runStateT mrgModify, - testCase "mrgModify'" $ mrgModifyTest state runStateT mrgModify', - testCase "mrgGets" $ mrgGetsTest state runStateT mrgGets + mrgWithStateTTest StateT runStateT mrgWithStateT, + testCase "mrgGet" $ mrgGetTest StateT runStateT mrgGet, + testCase "mrgPut" $ mrgPutTest StateT runStateT mrgPut, + testCase "mrgModify" $ mrgModifyTest StateT runStateT mrgModify, + testCase "mrgModify'" $ mrgModifyTest StateT runStateT mrgModify', + testCase "mrgGets" $ mrgGetsTest StateT runStateT mrgGets ] diff --git a/test/Grisette/Lib/Control/MonadTests.hs b/test/Grisette/Lib/Control/MonadTests.hs --- a/test/Grisette/Lib/Control/MonadTests.hs +++ b/test/Grisette/Lib/Control/MonadTests.hs @@ -3,23 +3,80 @@ module Grisette.Lib.Control.MonadTests (monadFunctionTests) where +import Control.Monad (MonadPlus (mzero), when) +import Control.Monad.Except (ExceptT (ExceptT), MonadError (throwError)) +import Control.Monad.State + ( MonadState (get, put), + MonadTrans (lift), + StateT (runStateT), + ) import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) -import Grisette.Core.Control.Monad.UnionM (UnionM) -import Grisette.Core.Data.Class.SimpleMergeable - ( UnionLike (single, unionIf), +import Grisette + ( ITEOp (symIte), + LogicalOp ((.&&), (.||)), + SEq ((./=), (.==)), + SOrd ((.<=)), + Solvable (con), + SymInteger, + UnionM, + UnionMergeable1 (mrgIfPropagatedStrategy), + mrgFilterM, + mrgGuard, mrgIf, + mrgLiftM, + mrgLiftM5, + mrgMapAndUnzipM, + mrgReplicateM, + mrgReplicateM_, mrgSingle, + mrgWhen, + mrgZipWithM, + symReplicateM_, + symWhen, ) import Grisette.Lib.Control.Monad - ( mrgFmap, + ( mrgAp, + mrgFail, mrgFoldM, + mrgFoldM_, + mrgForever, + mrgJoin, + mrgLiftM2, + mrgLiftM3, + mrgLiftM4, + mrgMfilter, mrgMplus, mrgMzero, mrgReturn, + mrgUnless, + mrgZipWithM_, + symFilterM, + symGuard, + symMfilter, + symReplicateM, + symUnless, + (.<$!>), + (.<=<), + (.=<<), + (.>=>), (.>>), (.>>=), ) -import Test.Framework (Test, testGroup) +import Grisette.Lib.Control.Monad.Except + ( mrgThrowError, + ) +import Grisette.TestUtil.NoMerge + ( NoMerge (NoMerge), + noMergeNotMerged, + oneNotMerged, + ) +import Grisette.TestUtil.SymbolicAssertion ((.@?=)) +import Test.Framework + ( Test, + TestOptions' (topt_timeout), + plusTestOptions, + testGroup, + ) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit ((@?=)) @@ -27,38 +84,450 @@ monadFunctionTests = testGroup "Monad" - [ testCase "mrgReturn" $ do - (mrgReturn 1 :: UnionM Integer) @?= mrgSingle 1, - testCase "mrgFoldM" $ do - ( mrgFoldM - (\acc (c, v) -> unionIf c (single $ acc + v) (single $ acc * v)) - 10 - [("a", 2), ("b", 3)] :: - UnionM Integer - ) - @?= mrgIf - "a" - (mrgIf "b" (mrgReturn 15) (mrgReturn 36)) - (mrgIf "b" (mrgReturn 23) (mrgReturn 60)), + [ testCase "mrgReturn" $ (mrgReturn 1 :: UnionM Integer) @?= mrgSingle 1, + testGroup + ".>>=" + [ testCase "merge result" $ do + let actual = + mrgIfPropagatedStrategy "a" (return $ -1) (return 1) + .>>= (\x -> return $ x * x) + actual @?= (mrgSingle 1 :: UnionM Integer), + testCase "merge argument" $ do + let actual = + mrgIfPropagatedStrategy "a" (return (1 :: Int)) (return 1) + .>>= const (return NoMerge) + actual @?= (mrgSingle NoMerge :: UnionM NoMerge) + ], + testGroup + ".>>" + [ testCase "merge result" $ do + let actual = + ( mrgIfPropagatedStrategy "a" (return $ -1) (return 1) :: + UnionM Integer + ) + .>> mrgIfPropagatedStrategy "a" (return $ -1) (return 1) + let expected = + mrgIf "a" (mrgReturn $ -1) (mrgReturn 1) :: + UnionM Integer + actual @?= expected, + testCase "merge lhs" $ do + let actual = + ( mrgIfPropagatedStrategy "a" (return 1) (return 1) :: + UnionM Integer + ) + .>> return NoMerge + let expected = mrgReturn NoMerge :: UnionM NoMerge + actual @?= expected + ], + testCase "mrgFail" $ do + let actual = mrgFail "a" :: MaybeT UnionM Int + actual @?= MaybeT (mrgSingle Nothing), testCase "mrgMzero" $ do (mrgMzero :: MaybeT UnionM Integer) @?= MaybeT (mrgReturn Nothing), - testCase "mrgMplus" $ do - (mrgMzero `mrgMplus` mrgMzero :: MaybeT UnionM Integer) @?= MaybeT (mrgReturn Nothing) - (mrgReturn 1 `mrgMplus` mrgMzero :: MaybeT UnionM Integer) - @?= mrgReturn 1 - (mrgMzero `mrgMplus` mrgReturn 1 :: MaybeT UnionM Integer) - @?= mrgReturn 1 - (mrgReturn 2 `mrgMplus` mrgReturn 1 :: MaybeT UnionM Integer) - @?= mrgReturn 2, - testCase "mrgFmap" $ do - mrgFmap (\x -> x * x) (mrgIf "a" (mrgReturn $ -1) (mrgReturn 1) :: UnionM Integer) - @?= mrgReturn 1, - testCase ".>>" $ do - (unionIf "a" (single $ -1) (single 1) :: UnionM Integer) - .>> unionIf "a" (single $ -1) (single 1) - @?= (mrgIf "a" (mrgReturn $ -1) (mrgReturn 1) :: UnionM Integer), - testCase ".>>=" $ do - unionIf "a" (single $ -1) (single 1) - .>>= (\x -> return $ x * x) - @?= (mrgSingle 1 :: UnionM Integer) + testGroup + "mrgMplus" + [ testCase "merge result" $ do + let actual = (mzero `mrgMplus` return 1 :: MaybeT UnionM Integer) + actual @?= mrgReturn 1, + testCase "merge lhs" $ do + let lhs = + MaybeT $ + mrgIfPropagatedStrategy "a" (return Nothing) (return Nothing) :: + MaybeT UnionM NoMerge + let rhs = return NoMerge + lhs `mrgMplus` rhs @?= MaybeT (mrgReturn $ Just NoMerge) + ], + testGroup + ".=<<" + [ testCase "merge result" $ do + let actual = + (\x -> return $ x * x) + .=<< mrgIfPropagatedStrategy "a" (return $ -1) (return 1) + actual @?= (mrgSingle 1 :: UnionM Integer), + testCase "merge argument" $ do + let actual = + const (return NoMerge) + .=<< mrgIfPropagatedStrategy "a" (return (1 :: Int)) (return 1) + actual @?= (mrgSingle NoMerge :: UnionM NoMerge) + ], + testGroup + ".>=>" + [ testCase "merge result" $ do + let lhs = + const + ( mrgIfPropagatedStrategy + "a" + (return $ -1) + (return 1) :: + UnionM Integer + ) + let actual = lhs .>=> (\x -> return $ x * x) + actual (0 :: Integer) @?= (mrgSingle 1 :: UnionM Integer), + testCase "merge lhs result" $ do + let lhs = + const + ( mrgIfPropagatedStrategy + "a" + (return 1) + (return 1) :: + UnionM Integer + ) + let actual = lhs .>=> const (return NoMerge) + actual (0 :: Integer) @?= mrgSingle NoMerge + ], + testGroup + ".<=<" + [ testCase "merge result" $ do + let rhs = + const + ( mrgIfPropagatedStrategy + "a" + (return $ -1) + (return 1) :: + UnionM Integer + ) + let actual = (\x -> return $ x * x) .<=< rhs + actual (0 :: Integer) @?= (mrgSingle 1 :: UnionM Integer), + testCase "merge rhs result" $ do + let rhs = + const + ( mrgIfPropagatedStrategy + "a" + (return 1) + (return 1) :: + UnionM Integer + ) + let actual = const (return NoMerge) .<=< rhs + actual (0 :: Integer) @?= mrgSingle NoMerge + ], + testCase "mrgForever" $ do + let f :: StateT Int (ExceptT NoMerge UnionM) () + f = do + i <- get + when (i == 0) $ throwError NoMerge + put (i - 1) + lift . lift $ + mrgIfPropagatedStrategy "a" (return ()) (return ()) + let actual = mrgForever f :: StateT Int (ExceptT NoMerge UnionM) NoMerge + runStateT actual 10 @?= ExceptT (mrgReturn $ Left NoMerge), + testCase "mrgJoin" $ + mrgJoin (return $ return 1) @?= (mrgSingle 1 :: UnionM Integer), + testCase "mrgMfilter" $ do + let actual = mrgMfilter (const True) (return 1 :: MaybeT UnionM Int) + actual @?= (mrgSingle 1), + testCase "symMfilter" $ do + let actual = symMfilter (.== 0) (return "a" :: MaybeT UnionM SymInteger) + let expected = + mrgIf ("a" .== (0 :: SymInteger)) (mrgReturn "a") mrgMzero + actual @?= expected, + testGroup + "mrgFilterM" + [ testCase "merge result" $ do + let actual = mrgFilterM (return . odd) [1, 2, 3, 4] + let expected = mrgReturn [1, 3] :: UnionM [Int] + actual @?= expected, + testCase "merge argument" $ do + let actual = + mrgFilterM + (const $ mrgIfPropagatedStrategy "a" (return True) (return True)) + [NoMerge, NoMerge] + let expected = mrgReturn [NoMerge, NoMerge] :: UnionM [NoMerge] + actual @?= expected + ], + testGroup + "symFilterM" + [ testCase "merge result" $ do + let actual = symFilterM (return . con . odd) [1, 2, 3, 4] + let expected = mrgReturn [1, 3] :: UnionM [Int] + actual @?= expected, + testCase "merge argument" $ do + let actual = + symFilterM + ( const $ + mrgIfPropagatedStrategy + "a" + (return $ con True) + (return $ con True) + ) + [NoMerge, NoMerge] + let expected = mrgReturn [NoMerge, NoMerge] :: UnionM [NoMerge] + actual @?= expected, + testCase "symbolic semantics" $ do + let a = "a" :: SymInteger + let b = "b" :: SymInteger + let actual = symFilterM (return . (./= 0)) [a, b] + let expected = + mrgIf (a .== 0 .&& b .== 0) (return []) $ + mrgIf + (a .== 0 .|| b .== 0) + (return [symIte (a .== 0) b a]) + (return [a, b]) :: + UnionM [SymInteger] + actual @?= expected + actual .@?= expected + ], + plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $ + testCase "mrgMapAndUnzipM" $ do + let actual = + mrgMapAndUnzipM + ( \x -> + mrgIfPropagatedStrategy + "a" + (return (x, x + 1)) + (return (x, x + 1)) + ) + [1 .. 100] :: + UnionM ([Int], [Int]) + let expected = mrgReturn ([1 .. 100], [2 .. 101]) + actual @?= expected, + plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $ + testCase "mrgZipWithM" $ do + let actual = + mrgZipWithM + ( \x y -> + mrgIfPropagatedStrategy + "a" + (return $ x + y) + (return $ x + y) + ) + [1 .. 100] + [1 .. 100] :: + UnionM ([Int]) + let expected = mrgReturn ((* 2) <$> [1 .. 100]) + actual @?= expected, + plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $ + testCase "mrgZipWithM_" $ do + let actual = + mrgZipWithM_ + ( \x y -> + mrgIfPropagatedStrategy + "a" + (return $ x + y) + (return $ x + y) + ) + [1 .. 100 :: Int] + [1 .. 100] :: + UnionM () + let expected = mrgReturn () + actual @?= expected, + plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $ + testCase "mrgFoldM" $ do + let actual = + mrgFoldM + ( \acc v -> + mrgIfPropagatedStrategy + "a" + (return $ acc + v) + (return $ acc + v) + ) + 10 + [1 .. 100] :: + UnionM Integer + actual @?= mrgReturn 5060, + plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $ + testCase "mrgFoldM_" $ do + let actual = + mrgFoldM_ + ( \acc v -> + mrgIfPropagatedStrategy + "a" + (return $ acc + v) + (return $ acc + v) + ) + 10 + [1 .. 100 :: Int] :: + UnionM () + actual @?= mrgReturn (), + plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $ + testCase "mrgReplicateM" $ do + let actual = + mrgReplicateM + 100 + (mrgIfPropagatedStrategy "a" (return 1) (return 1)) :: + UnionM [Int] + actual @?= mrgReturn [1 | _ <- [1 .. 100]], + plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $ + testGroup + "symReplicateM" + [ testCase "merge result and intermediate" $ do + let actual = + symReplicateM + 200 + (100 :: SymInteger) + (mrgIfPropagatedStrategy "a" (return 1) (return 1)) :: + UnionM [Int] + actual @?= mrgReturn [1 | _ <- [1 .. 100]], + testCase "symbolic semantics" $ do + let a = "a" :: SymInteger + let actual = + symReplicateM + 2 + a + (mrgIfPropagatedStrategy "a" (return 1) (return 1)) :: + UnionM [Int] + let expected = + mrgIf + (a .<= 0) + (return []) + (mrgIf (a .== 1) (return [1]) (return [1, 1])) :: + UnionM [Int] + actual .@?= expected + ], + plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $ + testCase "mrgReplicateM_" $ do + let actual = mrgReplicateM_ 100 noMergeNotMerged :: UnionM () + actual @?= mrgReturn (), + plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $ + testGroup + "symReplicateM_" + [ testCase "merge result and intermediate" $ do + let actual = + symReplicateM_ 200 (100 :: SymInteger) noMergeNotMerged :: + UnionM () + actual @?= mrgReturn () + ], + testCase "mrgGuard" $ do + mrgGuard True @?= (mrgReturn () :: MaybeT UnionM ()) + mrgGuard False @?= (MaybeT $ mrgReturn Nothing :: MaybeT UnionM ()), + testCase "symGuard" $ do + let expected = + MaybeT $ + mrgIf "a" (return $ Just ()) (return Nothing) :: + MaybeT UnionM () + symGuard "a" @?= expected, + testCase "mrgWhen" $ do + mrgWhen True (throwError "a") + @?= (mrgThrowError "a" :: ExceptT String UnionM ()) + mrgWhen False (throwError "a") + @?= (mrgReturn () :: ExceptT String UnionM ()), + testCase "symWhen" $ do + let expected = + mrgIf "a" (mrgThrowError "x") (return ()) :: + ExceptT String UnionM () + symWhen "a" (throwError "x") @?= expected, + testCase "mrgUnless" $ do + mrgUnless False (throwError "a") + @?= (mrgThrowError "a" :: ExceptT String UnionM ()) + mrgUnless True (throwError "a") + @?= (mrgReturn () :: ExceptT String UnionM ()), + testCase "symUnless" $ do + let expected = + mrgIf "a" (return ()) (mrgThrowError "x") :: + ExceptT String UnionM () + symUnless "a" (throwError "x") @?= expected, + testGroup + "mrgLiftM" + [ testCase "merge result" $ do + let actual = mrgLiftM (const 1) noMergeNotMerged + let expected = mrgReturn 1 :: UnionM Int + actual @?= expected, + testCase "merge argument" $ do + let actual = mrgLiftM (const NoMerge) oneNotMerged + let expected = mrgReturn NoMerge + actual @?= expected + ], + testGroup + "mrgLiftM2" + [ testCase "merge result" $ do + let actual = + mrgLiftM2 (const $ const 1) noMergeNotMerged noMergeNotMerged + let expected = mrgReturn 1 :: UnionM Int + actual @?= expected, + testCase "merge argument" $ do + let actual = + mrgLiftM2 (const $ const NoMerge) oneNotMerged oneNotMerged + let expected = mrgReturn NoMerge + actual @?= expected + ], + testGroup + "mrgLiftM3" + [ testCase "merge result" $ do + let actual = + mrgLiftM3 + (const $ const $ const 1) + noMergeNotMerged + noMergeNotMerged + noMergeNotMerged + let expected = mrgReturn 1 :: UnionM Int + actual @?= expected, + testCase "merge argument" $ do + let actual = + mrgLiftM3 + (const $ const $ const NoMerge) + oneNotMerged + oneNotMerged + oneNotMerged + let expected = mrgReturn NoMerge + actual @?= expected + ], + testGroup + "mrgLiftM4" + [ testCase "merge result" $ do + let actual = + mrgLiftM4 + (const $ const $ const $ const 1) + noMergeNotMerged + noMergeNotMerged + noMergeNotMerged + noMergeNotMerged + let expected = mrgReturn 1 :: UnionM Int + actual @?= expected, + testCase "merge argument" $ do + let actual = + mrgLiftM4 + (const $ const $ const $ const NoMerge) + oneNotMerged + oneNotMerged + oneNotMerged + oneNotMerged + let expected = mrgReturn NoMerge + actual @?= expected + ], + testGroup + "mrgLiftM5" + [ testCase "merge result" $ do + let actual = + mrgLiftM5 + (const $ const $ const $ const $ const 1) + noMergeNotMerged + noMergeNotMerged + noMergeNotMerged + noMergeNotMerged + noMergeNotMerged + let expected = mrgReturn 1 :: UnionM Int + actual @?= expected, + testCase "merge argument" $ do + let actual = + mrgLiftM5 + (const $ const $ const $ const $ const NoMerge) + oneNotMerged + oneNotMerged + oneNotMerged + oneNotMerged + oneNotMerged + let expected = mrgReturn NoMerge + actual @?= expected + ], + testGroup + "mrgAp" + [ testCase "merge result" $ do + let actual = mrgAp (return $ const 1) noMergeNotMerged + let expected = mrgReturn 1 :: UnionM Int + actual @?= expected, + testCase "merge argument" $ do + let actual = mrgAp (return $ const NoMerge) oneNotMerged + let expected = mrgReturn NoMerge + actual @?= expected + ], + testGroup + ".<$!>" + [ testCase "merge result" $ do + let actual = const 1 .<$!> noMergeNotMerged + let expected = mrgReturn 1 :: UnionM Int + actual @?= expected, + testCase "merge argument" $ do + let actual = const NoMerge .<$!> oneNotMerged + let expected = mrgReturn NoMerge + actual @?= expected + ] ] diff --git a/test/Grisette/Lib/Data/FoldableTests.hs b/test/Grisette/Lib/Data/FoldableTests.hs --- a/test/Grisette/Lib/Data/FoldableTests.hs +++ b/test/Grisette/Lib/Data/FoldableTests.hs @@ -7,24 +7,53 @@ MonadError (throwError), runExceptT, ) -import Control.Monad.Trans.Maybe (MaybeT) -import Grisette.Core.Control.Monad.UnionM (UnionM) -import Grisette.Core.Data.Class.SimpleMergeable - ( UnionLike (single, unionIf), +import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) +import Grisette + ( ITEOp (symIte), + LogicalOp ((.&&), (.||)), + SEq ((./=), (.==)), + SOrd (symCompare, (.<=), (.>)), + SymBool, + SymInteger, + UnionM, + UnionMergeable1 (mrgIfPropagatedStrategy), mrgIf, + symAll, + symAny, + symOr, ) import Grisette.Lib.Control.Monad (mrgMzero, mrgReturn) import Grisette.Lib.Data.Foldable - ( mrgFoldlM, + ( mrgFind, + mrgFoldlM, mrgFoldrM, mrgForM_, mrgFor_, mrgMapM_, + mrgMaximum, + mrgMaximumBy, + mrgMinimum, + mrgMinimumBy, mrgMsum, + mrgSequenceA_, mrgSequence_, mrgTraverse_, + symAnd, + symElem, + symMaximum, + symMaximumBy, + symMinimum, + symMinimumBy, + symNotElem, ) -import Test.Framework (Test, testGroup) +import Grisette.TestUtil.NoMerge (noMergeNotMerged, oneNotMerged) +import Grisette.TestUtil.SymbolicAssertion ((.@?=)) +import Test.Framework + ( Test, + TestOptions' (topt_timeout), + plusTestOptions, + testGroup, + ) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit ((@?=)) @@ -32,99 +61,237 @@ foldableFunctionTests = testGroup "Foldable" - [ testCase "mrgFoldlM" $ do - ( mrgFoldlM - (\acc (c, v) -> unionIf c (single $ acc + v) (single $ acc * v)) - 10 - [("a", 2), ("b", 3)] :: - UnionM Integer - ) - @?= mrgIf - "a" - (mrgIf "b" (mrgReturn 15) (mrgReturn 36)) + [ testCase "symElem" $ do + let [a, b, c] = ["a", "b", "c"] :: [SymInteger] + let actual = symElem a [b, c] + actual .@?= (a .== b .|| a .== c), + testCase "mrgMaximum" $ do + let [a, b, c] = ["a", "b", "c"] :: [SymInteger] + let actual = mrgMaximum [[a], [b, a], [c, a, b]] + let expected = + mrgIf + (a .> b .&& a .> c) + (return [a]) + (mrgIf (b .> c) (return [b, a]) (return [c, a, b])) :: + UnionM [SymInteger] + actual .@?= expected, + testCase "symMaximum" $ do + let [a, b, c] = ["a", "b", "c"] :: [SymInteger] + let actual = symMaximum [a, b, c] + let expected = symIte (a .> b .&& a .> c) a (symIte (b .> c) b c) + actual .@?= expected, + testCase "mrgMinimum" $ do + let [a, b, c] = ["a", "b", "c"] :: [SymInteger] + let actual = mrgMinimum [[a], [b, a], [c, a, b]] + let expected = + mrgIf + (a .<= b .&& a .<= c) + (return [a]) + (mrgIf (b .<= c) (return [b, a]) (return [c, a, b])) :: + UnionM [SymInteger] + actual .@?= expected, + testCase "symMinimum" $ do + let [a, b, c] = ["a", "b", "c"] :: [SymInteger] + let actual = symMinimum [a, b, c] + let expected = symIte (a .<= b .&& a .<= c) a (symIte (b .<= c) b c) + actual .@?= expected, + plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $ + testGroup + "mrgFoldrM" + [ testCase "semantics" $ do + let actual = + mrgFoldrM + ( \(c, v) acc -> + mrgIfPropagatedStrategy + c + (return $ acc + v) + (return $ acc * v) + ) + 10 + [("a", 2), ("b", 3)] :: + UnionM Integer + let expected = + mrgIf + "b" + (mrgIf "a" (mrgReturn 15) (mrgReturn 26)) + (mrgIf "a" (mrgReturn 32) (mrgReturn 60)) + actual @?= expected, + testCase "merge intermediate" $ do + let actual = mrgFoldrM (const $ const oneNotMerged) 1 [1 .. 1000] + let expected = mrgReturn 1 :: UnionM Int + actual @?= expected + ], + plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $ + testGroup + "mrgFoldlM" + [ testCase "semantics" $ do + let actual = + mrgFoldlM + ( \acc (c, v) -> + mrgIfPropagatedStrategy + c + (return $ acc + v) + (return $ acc * v) + ) + 10 + [("a", 2), ("b", 3)] :: + UnionM Integer + let expected = + mrgIf + "a" + (mrgIf "b" (mrgReturn 15) (mrgReturn 36)) + (mrgIf "b" (mrgReturn 23) (mrgReturn 60)) + actual @?= expected, + testCase "merge intermediate" $ do + let actual = mrgFoldlM (const $ const oneNotMerged) 1 [1 .. 1000] + let expected = mrgReturn 1 :: UnionM Int + actual @?= expected + ], + plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $ + testGroup "mrgTraverse_, mrgMapM_, mrgFor_, mrgForM_" $ do + (name, func0, func1) <- + [ ("mrgTraverse_", mrgTraverse_, mrgTraverse_), + ("mrgMapM_", mrgMapM_, mrgMapM_), + ("mrgFor_", flip mrgFor_, flip mrgFor_), + ("mrgForM_", flip mrgForM_, flip mrgForM_) + ] + [ testGroup + name + [ testCase "semantics" $ do + let actual = + runExceptT + ( func0 + ( \(c, x) -> + ExceptT $ + mrgIfPropagatedStrategy + c + (return $ Left x) + (return $ Right c) + ) + [("a", 3), ("b", 2)] :: + ExceptT Integer UnionM () + ) + let expected = runExceptT $ do + _ <- mrgIf "a" (throwError 3) (return ()) + _ <- mrgIf "b" (throwError 2) (return ()) + mrgReturn () + actual @?= expected, + testCase "discard and merge intermediate" $ do + let actual = func1 (const noMergeNotMerged) [1 .. 1000] + let expected = mrgReturn () :: UnionM () + actual @?= expected + ] + ], + plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $ + testGroup "mrgSequence_, mrgSequenceA_" $ do + (name, func0, func1) <- + [ ("mrgSequence_", mrgSequence_, mrgSequence_), + ("mrgSequenceA_", mrgSequenceA_, mrgSequenceA_) + ] + [ testGroup + name + [ testCase "semantics" $ do + let actual = + runExceptT + ( func0 $ + ( \(c, x) -> + ExceptT $ + mrgIfPropagatedStrategy + c + (return $ Left x) + (return $ Right c) + ) + <$> [("a", 3), ("b", 2)] :: + ExceptT Integer UnionM () + ) + let expected = runExceptT $ do + _ <- mrgIf "a" (throwError 3) (return ()) + _ <- mrgIf "b" (throwError 2) (return ()) + mrgReturn () + actual @?= expected, + testCase "discard and merge intermediate" $ do + let actual = func1 (replicate 1000 noMergeNotMerged) + let expected = mrgReturn () :: UnionM () + actual @?= expected + ] + ], + plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $ + testGroup + "mrgMsum" + [ testCase "merge" $ do + let none = + MaybeT $ + mrgIfPropagatedStrategy "a" (return Nothing) (return Nothing) + let expected = + MaybeT (mrgReturn Nothing) :: + MaybeT UnionM (Maybe Int) + mrgMsum (replicate 100 none) @?= expected, + testCase "semantics" $ do + (mrgMsum [mrgMzero, mrgMzero] :: MaybeT UnionM Integer) + @?= mrgMzero + (mrgMsum [mrgReturn 1, mrgMzero] :: MaybeT UnionM Integer) + @?= mrgReturn 1 + (mrgMsum [mrgMzero, mrgReturn 1] :: MaybeT UnionM Integer) + @?= mrgReturn 1 + (mrgMsum [mrgReturn 2, mrgReturn 1] :: MaybeT UnionM Integer) + @?= mrgReturn 2 + ], + testCase "symAnd" $ do + let [a, b, c] = ["a", "b", "c"] :: [SymBool] + symAnd [a, b, c] .@?= (a .&& b .&& c), + testCase "symOr" $ do + let [a, b, c] = ["a", "b", "c"] :: [SymBool] + symOr [a, b, c] .@?= (a .|| b .|| c), + testCase "symAny" $ do + let [a, b, c] = ["a", "b", "c"] :: [SymInteger] + symAny (.== 0) [a, b, c] .@?= (a .== 0 .|| b .== 0 .|| c .== 0), + testCase "symAll" $ do + let [a, b, c] = ["a", "b", "c"] :: [SymInteger] + symAll (.== 0) [a, b, c] .@?= (a .== 0 .&& b .== 0 .&& c .== 0), + testCase "mrgMaximumBy" $ do + let [a, b, c] = ["a", "b", "c"] :: [SymInteger] + let actual = mrgMaximumBy symCompare [[a], [b, a], [c, a, b]] + let expected = + mrgIf + (a .> b .&& a .> c) + (return [a]) + (mrgIf (b .> c) (return [b, a]) (return [c, a, b])) :: + UnionM [SymInteger] + actual .@?= expected, + testCase "symMaximumBy" $ do + let [a, b, c] = ["a", "b", "c"] :: [SymInteger] + let actual = symMaximumBy symCompare [a, b, c] + let expected = symIte (a .> b .&& a .> c) a (symIte (b .> c) b c) + actual .@?= expected, + testCase "mrgMinimumBy" $ do + let [a, b, c] = ["a", "b", "c"] :: [SymInteger] + let actual = mrgMinimumBy symCompare [[a], [b, a], [c, a, b]] + let expected = + mrgIf + (a .<= b .&& a .<= c) + (return [a]) + (mrgIf (b .<= c) (return [b, a]) (return [c, a, b])) :: + UnionM [SymInteger] + actual .@?= expected, + testCase "symMinimumBy" $ do + let [a, b, c] = ["a", "b", "c"] :: [SymInteger] + let actual = symMinimumBy symCompare [a, b, c] + let expected = symIte (a .<= b .&& a .<= c) a (symIte (b .<= c) b c) + actual .@?= expected, + testCase "symNotElem" $ do + let [a, b, c] = ["a", "b", "c"] :: [SymInteger] + let actual = symNotElem a [b, c] + actual .@?= (a ./= b .&& a ./= c), + testCase "mrgFind" $ do + let [a, b, c] = ["a", "b", "c"] :: [SymInteger] + let actual = mrgFind (.== 0) [a, b, c] :: UnionM (Maybe SymInteger) + actual + .@?= mrgIf + (a .== 0) + (return $ Just a) ( mrgIf - "b" - (mrgReturn 23) - (mrgReturn 60) - ), - testCase "mrgFoldrM" $ do - ( mrgFoldrM - (\(c, v) acc -> unionIf c (single $ acc + v) (single $ acc * v)) - 10 - [("a", 2), ("b", 3)] :: - UnionM Integer - ) - @?= mrgIf - "b" - (mrgIf "a" (mrgReturn 15) (mrgReturn 26)) - (mrgIf "a" (mrgReturn 32) (mrgReturn 60)), - testCase "mrgTraverse_" $ do - runExceptT - ( mrgTraverse_ - (\(c, x) -> ExceptT $ unionIf c (return $ Left x) (return $ Right c)) - [("a", 3), ("b", 2)] :: - ExceptT Integer (UnionM) () - ) - @?= runExceptT - ( do - _ <- mrgIf "a" (throwError 3) (return ()) - _ <- mrgIf "b" (throwError 2) (return ()) - mrgReturn () - ), - testCase "mrgFor_" $ do - runExceptT - ( mrgFor_ - [("a", 3), ("b", 2)] - (\(c, x) -> ExceptT $ unionIf c (return $ Left x) (return $ Right c)) :: - ExceptT Integer UnionM () - ) - @?= runExceptT - ( do - _ <- mrgIf "a" (throwError 3) (return ()) - _ <- mrgIf "b" (throwError 2) (return ()) - mrgReturn () - ), - testCase "mrgMapM_" $ do - runExceptT - ( mrgMapM_ - (\(c, x) -> ExceptT $ unionIf c (return $ Left x) (return $ Right c)) - [("a", 3), ("b", 2)] :: - ExceptT Integer UnionM () - ) - @?= runExceptT - ( do - _ <- mrgIf "a" (throwError 3) (return ()) - _ <- mrgIf "b" (throwError 2) (return ()) - mrgReturn () - ), - testCase "mrgForM_" $ do - runExceptT - ( mrgForM_ - [("a", 3), ("b", 2)] - (\(c, x) -> ExceptT $ unionIf c (return $ Left x) (return $ Right c)) :: - ExceptT Integer UnionM () - ) - @?= runExceptT - ( do - _ <- mrgIf "a" (throwError 3) (return ()) - _ <- mrgIf "b" (throwError 2) (return ()) - mrgReturn () - ), - testCase "mrgSequence_" $ do - runExceptT - ( mrgSequence_ - [mrgIf "a" (throwError 3) (return ()), mrgIf "b" (throwError 2) (return ())] :: - ExceptT Integer UnionM () - ) - @?= runExceptT - ( do - _ <- mrgIf "a" (throwError 3) (return ()) - _ <- mrgIf "b" (throwError 2) (return ()) - mrgReturn () - ), - testCase "mrgMsum" $ do - (mrgMsum [mrgMzero, mrgMzero] :: MaybeT UnionM Integer) @?= mrgMzero - (mrgMsum [mrgReturn 1, mrgMzero] :: MaybeT UnionM Integer) @?= mrgReturn 1 - (mrgMsum [mrgMzero, mrgReturn 1] :: MaybeT UnionM Integer) @?= mrgReturn 1 - (mrgMsum [mrgReturn 2, mrgReturn 1] :: MaybeT UnionM Integer) @?= mrgReturn 2 + (b .== 0) + (return $ Just b) + (mrgIf (c .== 0) (return $ Just c) (return Nothing)) + ) ] diff --git a/test/Grisette/Lib/Data/FunctorTests.hs b/test/Grisette/Lib/Data/FunctorTests.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/Lib/Data/FunctorTests.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Grisette.Lib.Data.FunctorTests (functorFunctionTests) where + +import Grisette + ( ITEOp (symIte), + SymInteger, + UnionM, + UnionMergeable1 (mrgIfPropagatedStrategy), + mrgIf, + mrgSingle, + mrgVoid, + ) +import Grisette.Lib.Data.Functor + ( mrgFmap, + mrgUnzip, + (.$>), + (.<$), + (.<$>), + (.<&>), + ) +import Grisette.TestUtil.NoMerge + ( NoMerge (NoMerge), + noMergeNotMerged, + oneNotMerged, + ) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@?=)) + +functorFunctionTests :: Test +functorFunctionTests = + testGroup + "Functor" + [ testGroup + "mrgFmap" + [ testCase "merge result" $ do + let actual = + mrgFmap (\x -> x * x) $ + mrgIfPropagatedStrategy "a" (return $ -1) (return 1) + actual @?= (mrgSingle 1 :: UnionM Integer), + testCase "merge arguments" $ do + let actual = mrgFmap (const NoMerge) oneNotMerged + actual @?= (mrgSingle NoMerge :: UnionM NoMerge) + ], + testGroup + ".<$>" + [ testCase "merge result" $ do + let actual = + (\x -> x * x) + .<$> mrgIfPropagatedStrategy "a" (return $ -1) (return 1) + actual @?= (mrgSingle 1 :: UnionM Integer), + testCase "merge arguments" $ do + let actual = (const NoMerge) .<$> oneNotMerged + actual @?= (mrgSingle NoMerge :: UnionM NoMerge) + ], + testGroup + ".<$" + [ testCase "merge result" $ + 1 .<$ noMergeNotMerged @?= (mrgSingle 1 :: UnionM Integer), + testCase "merge arguments" $ + NoMerge .<$ oneNotMerged @?= (mrgSingle NoMerge :: UnionM NoMerge) + ], + testGroup + ".$>" + [ testCase "merge result" $ + noMergeNotMerged .$> 1 @?= (mrgSingle 1 :: UnionM Integer), + testCase "merge arguments" $ + oneNotMerged .$> NoMerge @?= (mrgSingle NoMerge :: UnionM NoMerge) + ], + testGroup + ".<&>" + [ testCase "merge result" $ do + let actual = + mrgIfPropagatedStrategy "a" (return $ -1) (return 1) + .<&> (\x -> x * x) + actual @?= (mrgSingle 1 :: UnionM Integer), + testCase "merge arguments" $ do + let actual = oneNotMerged .<&> (const NoMerge) + actual @?= (mrgSingle NoMerge :: UnionM NoMerge) + ], + testCase "mrgUnzip" $ do + let actual = + mrgUnzip + (mrgIfPropagatedStrategy "x" (return ("a", 1)) (return ("b", 2))) + let expected = + ( mrgSingle (symIte "x" "a" "b"), + mrgIf "x" 1 2 + ) :: + (UnionM SymInteger, UnionM Integer) + actual @?= expected, + testCase "mrgVoid" $ do + let actual = mrgVoid noMergeNotMerged + let expected = mrgSingle () :: UnionM () + actual @?= expected + ] diff --git a/test/Grisette/Lib/Data/ListTests.hs b/test/Grisette/Lib/Data/ListTests.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/Lib/Data/ListTests.hs @@ -0,0 +1,753 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Use elemIndex" #-} +{-# HLINT ignore "Use elemIndices" #-} +{-# HLINT ignore "Use nub" #-} +{-# HLINT ignore "Use union" #-} +{-# HLINT ignore "Use intersect" #-} +{-# HLINT ignore "Use insert" #-} +{-# HLINT ignore "Use group" #-} + +module Grisette.Lib.Data.ListTests (listTests) where + +import Data.List + ( delete, + deleteBy, + deleteFirstsBy, + dropWhileEnd, + elemIndex, + elemIndices, + findIndex, + findIndices, + group, + groupBy, + insert, + insertBy, + intersect, + intersectBy, + isInfixOf, + isPrefixOf, + isSubsequenceOf, + isSuffixOf, + nub, + nubBy, + partition, + stripPrefix, + union, + unionBy, + (\\), + ) +import Grisette + ( ITEOp (symIte), + LogicalOp (symNot, (.&&), (.||)), + SEq ((./=), (.==)), + SOrd (symCompare, (.<=), (.>=)), + Solvable (con), + SymBool, + UnionM, + mrgGroupBy, + mrgIf, + ) +import Grisette.Lib.Control.Applicative (mrgPure) +import Grisette.Lib.Data.List + ( mrgBreak, + mrgDelete, + mrgDeleteBy, + mrgDeleteFirstsBy, + mrgDrop, + mrgDropWhile, + mrgDropWhileEnd, + mrgElemIndex, + mrgElemIndices, + mrgFilter, + mrgFindIndex, + mrgFindIndices, + mrgGroup, + mrgInsert, + mrgInsertBy, + mrgIntersect, + mrgIntersectBy, + mrgLookup, + mrgNub, + mrgNubBy, + mrgPartition, + mrgSpan, + mrgSplitAt, + mrgStripPrefix, + mrgTake, + mrgTakeWhile, + mrgUnion, + mrgUnionBy, + symIsInfixOf, + symIsPrefixOf, + symIsSubsequenceOf, + symIsSuffixOf, + (.!?), + (.\\), + ) +import Grisette.SymPrim (SymInteger) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.HUnit ((@?=)) +import Test.QuickCheck (Gen, forAll, ioProperty, listOf, oneof) + +aint, bint, cint, dint, eint, fint :: SymInteger +aint = "a" +bint = "b" +cint = "c" +dint = "d" +eint = "e" +fint = "f" + +ranint :: Gen SymInteger +ranint = oneof $ return <$> [aint, bint, cint, dint, eint, fint, -1, 0, 1] + +ranilist :: Gen [SymInteger] +ranilist = listOf ranint + +listTests :: Test +listTests = + testGroup + "List" + [ testGroup + "mrgTake" + [ testProperty "concrete int" $ + \(n :: Integer) -> forAll ranilist $ \ranilist -> ioProperty $ do + let actual = mrgTake n ranilist :: UnionM [SymInteger] + let expected = mrgPure $ take (fromInteger n) ranilist + actual @?= expected, + testCase "symbolic int" $ do + let actual = mrgTake aint [bint, cint, dint] :: UnionM [SymInteger] + let expected = + mrgIf (aint .<= 0) (return []) $ + mrgIf (aint .== 1) (return [bint]) $ + mrgIf (aint .== 2) (return [bint, cint]) $ + return [bint, cint, dint] + actual @?= expected + ], + testGroup + "mrgDrop" + [ testProperty "concrete int" $ + \(n :: Integer) -> forAll ranilist $ \ranilist -> ioProperty $ do + let actual = mrgDrop n ranilist :: UnionM [SymInteger] + let expected = mrgPure $ drop (fromInteger n) ranilist + actual @?= expected, + testCase "symbolic int" $ do + let actual = mrgDrop aint [bint, cint, dint] :: UnionM [SymInteger] + let expected = + mrgIf (aint .>= 3) (return []) $ + mrgIf (aint .== 2) (return [dint]) $ + mrgIf (aint .== 1) (return [cint, dint]) $ + return [bint, cint, dint] + actual @?= expected + ], + testGroup + "mrgSplitAt" + [ testProperty "concrete int" $ + \(n :: Integer) -> forAll ranilist $ \ranilist -> ioProperty $ do + let actual = + mrgSplitAt n ranilist :: + UnionM ([SymInteger], [SymInteger]) + let expected = mrgPure $ splitAt (fromInteger n) ranilist + actual @?= expected, + testCase "symbolic int" $ do + let actual = + mrgSplitAt aint [bint, cint, dint] :: + UnionM ([SymInteger], [SymInteger]) + let expected = + mrgIf (aint .<= 0) (return ([], [bint, cint, dint])) $ + mrgIf (aint .== 1) (return ([bint], [cint, dint])) $ + mrgIf (aint .== 2) (return ([bint, cint], [dint])) $ + return ([bint, cint, dint], []) + actual @?= expected + ], + testGroup + "mrgTakeWhile" + [ testProperty "concrete int" $ + \ranilist -> ioProperty $ do + let actual = mrgTakeWhile (.== 0) ranilist :: UnionM [Integer] + let expected = mrgPure $ takeWhile (== 0) ranilist + actual @?= expected, + testCase "symbolic int" $ do + let actual = + mrgTakeWhile (.== 0) [aint, bint, cint] :: UnionM [SymInteger] + let expected = + mrgIf (aint ./= 0) (return []) $ + mrgIf (bint ./= 0) (return [aint]) $ + mrgIf (cint ./= 0) (return ([aint, bint])) $ + return [aint, bint, cint] + actual @?= expected + ], + testGroup + "mrgDropWhile" + [ testProperty "concrete int" $ + \ranilist -> ioProperty $ do + let actual = mrgDropWhile (.== 0) ranilist :: UnionM [Integer] + let expected = mrgPure $ dropWhile (== 0) ranilist + actual @?= expected, + testCase "symbolic int" $ do + let actual = + mrgDropWhile (.== 0) [aint, bint, cint] :: UnionM [SymInteger] + let expected = + mrgIf + ((aint .== 0 .&& bint .== 0) .&& cint .== 0) + (return []) + $ mrgIf (aint .== 0 .&& bint .== 0) (return [cint]) + $ mrgIf (aint .== 0) (return ([bint, cint])) + $ return [aint, bint, cint] + actual @?= expected + ], + testGroup + "mrgDropWhileEnd" + [ testProperty "concrete int" $ + \ranilist -> ioProperty $ do + let actual = mrgDropWhileEnd (.== 0) ranilist :: UnionM [Integer] + let expected = mrgPure $ dropWhileEnd (== 0) ranilist + actual @?= expected, + testCase "symbolic int" $ do + let actual = + mrgDropWhileEnd (.== 0) [aint, bint, cint] :: + UnionM [SymInteger] + let expected = + mrgIf + ((cint .== 0 .&& bint .== 0) .&& aint .== 0) + (return []) + $ mrgIf (cint .== 0 .&& bint .== 0) (return [aint]) + $ mrgIf (cint .== 0) (return ([aint, bint])) + $ return [aint, bint, cint] + actual @?= expected + ], + testGroup + "mrgSpan" + [ testProperty "concrete int" $ + \ranilist -> ioProperty $ do + let actual = + mrgSpan (.== 0) ranilist :: UnionM ([Integer], [Integer]) + let expected = mrgPure $ span (== 0) ranilist + actual @?= expected, + testCase "symbolic int" $ do + let actual = + mrgSpan (.== 0) [aint, bint, cint] :: + UnionM ([SymInteger], [SymInteger]) + let expected = + mrgIf (aint ./= 0) (return ([], [aint, bint, cint])) $ + mrgIf (bint ./= 0) (return ([aint], [bint, cint])) $ + mrgIf (cint ./= 0) (return ([aint, bint], [cint])) $ + return ([aint, bint, cint], []) + actual @?= expected + ], + testGroup + "mrgBreak" + [ testProperty "concrete int" $ + \ranilist -> ioProperty $ do + let actual = + mrgBreak (.== 0) ranilist :: UnionM ([Integer], [Integer]) + let expected = mrgPure $ break (== 0) ranilist + actual @?= expected, + testCase "symbolic int" $ do + let actual = + mrgBreak (.== 0) [aint, bint, cint] :: + UnionM ([SymInteger], [SymInteger]) + let expected = + mrgIf (aint .== 0) (return ([], [aint, bint, cint])) $ + mrgIf (bint .== 0) (return ([aint], [bint, cint])) $ + mrgIf (cint .== 0) (return ([aint, bint], [cint])) $ + return ([aint, bint, cint], []) + actual @?= expected + ], + testGroup + "mrgStripPrefix" + [ testProperty "concrete int" $ + \l1 l2 -> ioProperty $ do + let actual = mrgStripPrefix l1 l2 :: UnionM (Maybe [Integer]) + let expected = mrgPure $ stripPrefix l1 l2 + actual @?= expected, + testCase "symbolic int" $ do + let actual = + mrgStripPrefix [aint, bint] [cint, dint, eint] :: + UnionM (Maybe [SymInteger]) + let expected = + mrgIf + (symNot ((aint .== cint) .&& (bint .== dint))) + (return Nothing) + (return $ Just [eint]) + actual @?= expected + ], + testGroup + "mrgGroup" + [ testProperty "concrete int" $ + \l -> ioProperty $ do + let actual = mrgGroup l :: UnionM [[Integer]] + let expected = mrgPure $ group l + actual @?= expected, + testCase "symbolic int" $ do + let actual = mrgGroup [aint, bint, cint] :: UnionM [[SymInteger]] + let expected = + mrgIf + (aint .== bint .&& aint .== cint) + (return [[aint, bint, cint]]) + $ mrgIf + (aint .== bint .|| bint .== cint) + ( mrgIf (aint .== bint) (return [[aint, bint], [cint]]) $ + return [[aint], [bint, cint]] + ) + $ return [[aint], [bint], [cint]] + + actual @?= expected + ], + testGroup + "symIsPrefixOf" + [ testProperty "concrete int" $ + \(l1 :: [Int]) l2 -> ioProperty $ do + let actual = symIsPrefixOf l1 l2 :: SymBool + let expected = con $ isPrefixOf l1 l2 + actual @?= expected, + testCase "symbolic int" $ do + let actual = symIsPrefixOf [aint, bint] [cint, dint, eint] + actual @?= (aint .== cint .&& bint .== dint), + testCase "symbolic int, not long enough" $ do + let actual = symIsPrefixOf [cint, dint, eint] [aint, bint] + actual @?= con False + ], + testGroup + "symIsSuffixOf" + [ testProperty "concrete int" $ + \(l1 :: [Int]) l2 -> ioProperty $ do + let actual = symIsSuffixOf l1 l2 :: SymBool + let expected = con $ isSuffixOf l1 l2 + actual @?= expected, + testCase "symbolic int" $ do + let actual = symIsSuffixOf [aint, bint] [cint, dint, eint] + actual @?= (bint .== eint .&& aint .== dint), + testCase "symbolic int, not long enough" $ do + let actual = symIsSuffixOf [cint, dint, eint] [aint, bint] + actual @?= con False + ], + testGroup + "symIsInfixOf" + [ testProperty "concrete int" $ + \(l1 :: [Int]) l2 -> ioProperty $ do + let actual = symIsInfixOf l1 l2 :: SymBool + let expected = con $ isInfixOf l1 l2 + actual @?= expected, + testCase "symbolic int" $ do + let actual = symIsInfixOf [aint, bint] [cint, dint, eint, fint] + actual + @?= ( (aint .== cint .&& bint .== dint) + .|| (aint .== dint .&& bint .== eint) + ) + .|| (aint .== eint .&& bint .== fint), + testCase "symbolic int, not long enough" $ do + let actual = symIsInfixOf [cint, dint, eint] [aint, bint] + actual @?= con False + ], + testGroup + "symIsSubsequenceOf" + [ testProperty "concrete int" $ + \(l1 :: [Int]) l2 -> ioProperty $ do + let actual = symIsSubsequenceOf l1 l2 :: SymBool + let expected = con $ isSubsequenceOf l1 l2 + actual @?= expected, + testCase "symbolic int" $ do + let actual = + symIsSubsequenceOf [aint, bint] [cint, dint, eint, fint] + actual + @?= symIte + (aint .== cint) + (bint .== dint .|| (bint .== eint .|| bint .== fint)) + ( symIte + (aint .== dint) + (bint .== eint .|| bint .== fint) + (aint .== eint .&& bint .== fint) + ), + testCase "symbolic int, not long enough" $ do + let actual = symIsSubsequenceOf [cint, dint, eint] [aint, bint] + actual @?= con False + ], + testGroup + "mrgLookup" + [ testProperty "concrete int" $ + \v l -> ioProperty $ do + let actual = mrgLookup (v :: Integer) l :: UnionM (Maybe Integer) + let expected = mrgPure $ lookup v l + actual @?= expected, + testCase "symbolic int" $ do + let actual = + mrgLookup + aint + [ (bint, Just cint), + (dint, Nothing), + (fint, Just eint) + ] :: + UnionM (Maybe (Maybe SymInteger)) + let expected = + mrgIf + ((aint ./= bint .&& aint ./= dint) .&& aint ./= fint) + (return Nothing) + $ mrgIf (aint .== bint) (return $ Just $ Just cint) + $ mrgIf + (aint .== dint) + (return $ Just Nothing) + (return $ Just $ Just eint) + actual @?= expected + ], + testGroup + "mrgFilter" + [ testProperty "concrete int" $ + \l -> ioProperty $ do + let actual = mrgFilter (.== 0) l :: UnionM [Integer] + let expected = mrgPure $ filter (== 0) l + actual @?= expected, + testCase "symbolic int" $ do + let actual = + mrgFilter (.== 0) [aint, bint] :: UnionM [SymInteger] + let expected = + mrgIf (symNot $ aint .== 0 .|| bint .== 0) (return []) $ + mrgIf + (symNot $ aint .== 0 .&& bint .== 0) + (return [symIte (aint .== 0) aint bint]) + (return [aint, bint]) + actual @?= expected + ], + testGroup + "mrgPartition" + [ testProperty "concrete int" $ + \l -> ioProperty $ do + let actual = + mrgPartition (.== 0) l :: + UnionM ([Integer], [Integer]) + let expected = mrgPure $ partition (== 0) l + actual @?= expected, + testCase "symbolic int" $ do + let actual = + mrgPartition (.== 0) [aint, bint] :: + UnionM ([SymInteger], [SymInteger]) + let expected = + mrgIf + (symNot $ aint .== 0 .|| bint .== 0) + (return ([], [aint, bint])) + $ mrgIf + (symNot $ aint .== 0 .&& bint .== 0) + ( return + ( [symIte (aint .== 0) aint bint], + [symIte (aint .== 0) bint aint] + ) + ) + (return ([aint, bint], [])) + actual @?= expected + ], + testGroup + ".!?" + [ testProperty "concrete int" $ + \l (i :: Int) -> ioProperty $ do + let actual = l .!? i :: UnionM (Maybe Integer) + let expected = + mrgPure $ + if i < 0 || i >= length l then Nothing else Just $ l !! i + actual @?= expected, + testCase "symbolic int" $ do + let actual = + [aint, bint, cint] .!? dint :: UnionM (Maybe SymInteger) + let expected = + mrgIf + (symNot (dint .== 0 .|| dint .== 1 .|| dint .== 2)) + (return Nothing) + ( return $ + Just $ + symIte (dint .== 0) aint $ + symIte (dint .== 1) bint cint + ) + actual @?= expected + ], + testGroup + "mrgElemIndex" + [ testProperty "concrete int" $ + \(v :: Integer) l -> ioProperty $ do + let actual = mrgElemIndex v l :: UnionM (Maybe Int) + let expected = mrgPure $ elemIndex v l + actual @?= expected, + testCase "symbolic int" $ do + let actual = + mrgElemIndex aint [bint, cint, dint] :: + UnionM (Maybe SymInteger) + let expected = + mrgIf + (symNot $ aint .== bint .|| aint .== cint .|| aint .== dint) + (mrgPure Nothing) + ( mrgPure $ + Just $ + symIte (aint .== bint) 0 (symIte (aint .== cint) 1 2) + ) + actual @?= expected + ], + testGroup + "mrgElemIndices" + [ testProperty "concrete int" $ + \(v :: Integer) l -> ioProperty $ do + let actual = mrgElemIndices v l :: UnionM [Int] + let expected = mrgPure $ elemIndices v l + actual @?= expected + ], + testGroup + "mrgFindIndex" + [ testProperty "concrete int" $ + \(l :: [Integer]) -> ioProperty $ do + let actual = mrgFindIndex (.== 0) l :: UnionM (Maybe Int) + let expected = mrgPure $ findIndex (== 0) l + actual @?= expected, + testCase "symbolic int" $ do + let actual = + mrgFindIndex (.== 0) [aint, bint, cint] :: + UnionM (Maybe SymInteger) + let expected = + mrgIf + (symNot $ aint .== 0 .|| bint .== 0 .|| cint .== 0) + (mrgPure Nothing) + ( mrgPure $ + Just $ + symIte (aint .== 0) 0 (symIte (bint .== 0) 1 2) + ) + actual @?= expected + ], + testGroup + "mrgFindIndices" + [ testProperty "concrete int" $ + \(l :: [Integer]) -> ioProperty $ do + let actual = mrgFindIndices (.== 0) l :: UnionM [Int] + let expected = mrgPure $ findIndices (== 0) l + actual @?= expected + ], + testGroup + "mrgNub" + [ testProperty "concrete int" $ + \l -> ioProperty $ do + let actual = mrgNub l :: UnionM [Integer] + let expected = mrgPure $ nub l + actual @?= expected, + testCase "symbolic int" $ do + let actual = mrgNub [aint, bint, cint] :: UnionM [SymInteger] + let expected = + mrgIf + (bint .== aint .&& cint .== aint) + (return [aint]) + $ mrgIf + (bint .== aint .|| cint .== bint .|| cint .== aint) + (return [aint, symIte (bint .== aint) cint bint]) + (return [aint, bint, cint]) + actual @?= expected + ], + testGroup + "mrgDelete" + [ testProperty "concrete int" $ + \i l -> ioProperty $ do + let actual = mrgDelete i l :: UnionM [Integer] + let expected = mrgPure $ delete i l + actual @?= expected, + testCase "symbolic int" $ do + let actual = + mrgDelete aint [bint, cint, dint] :: UnionM [SymInteger] + let expected = + mrgIf + (aint .== bint .|| aint .== cint .|| aint .== dint) + ( return + [ symIte (aint .== bint) cint bint, + symIte (aint .== bint .|| aint .== cint) dint cint + ] + ) + (return [bint, cint, dint]) + actual @?= expected + ], + testGroup + ".\\\\" + [ testProperty "concrete int" $ + \l1 l2 -> ioProperty $ do + let actual = l1 .\\ l2 :: UnionM [Integer] + let expected = mrgPure $ l1 \\ l2 + actual @?= expected + ], + testGroup + "mrgUnion" + [ testProperty "concrete int" $ + \l1 l2 -> ioProperty $ do + let actual = mrgUnion l1 l2 :: UnionM [Integer] + let expected = mrgPure $ union l1 l2 + actual @?= expected + ], + testGroup + "mrgIntersect" + [ testProperty "concrete int" $ + \l1 l2 -> ioProperty $ do + let actual = mrgIntersect l1 l2 :: UnionM [Integer] + let expected = mrgPure $ intersect l1 l2 + actual @?= expected, + testCase "symbolic int" $ do + let actual = + mrgIntersect [aint, bint] [cint, dint] :: UnionM [SymInteger] + let expected = + mrgIf + ( symNot $ + (bint .== cint .|| bint .== dint) + .|| (aint .== cint .|| aint .== dint) + ) + (return []) + ( mrgIf + ( symNot $ + (bint .== cint .|| bint .== dint) + .&& (aint .== cint .|| aint .== dint) + ) + ( return + [symIte (bint .== cint .|| bint .== dint) bint aint] + ) + (return [aint, bint]) + ) + actual @?= expected + ], + testGroup + "mrgNubBy" + [ testProperty "concrete int" $ + \l -> ioProperty $ do + let actual = mrgNubBy (.==) l :: UnionM [Integer] + let expected = mrgPure $ nubBy (==) l + actual @?= expected, + testCase "symbolic int" $ do + let actual = + mrgNubBy (.==) [aint, bint, cint] :: UnionM [SymInteger] + let expected = + mrgIf + (bint .== aint .&& cint .== aint) + (return [aint]) + $ mrgIf + (bint .== aint .|| cint .== bint .|| cint .== aint) + (return [aint, symIte (bint .== aint) cint bint]) + (return [aint, bint, cint]) + actual @?= expected + ], + testGroup + "mrgDeleteBy" + [ testProperty "concrete int" $ + \i l -> ioProperty $ do + let actual = mrgDeleteBy (./=) i l :: UnionM [Integer] + let expected = mrgPure $ deleteBy (/=) i l + actual @?= expected, + testCase "symbolic int" $ do + let actual = + mrgDeleteBy (./=) aint [bint, cint, dint] :: + UnionM [SymInteger] + let expected = + mrgIf + ( symNot $ + aint .== bint .&& aint .== cint .&& aint .== dint + ) + ( return + [ symIte (aint .== bint) bint cint, + symIte (aint .== bint .&& aint .== cint) cint dint + ] + ) + (return [bint, cint, dint]) + actual @?= expected + ], + testGroup + "mrgDeleteFirstsBy" + [ testProperty "concrete int" $ + \l1 l2 -> ioProperty $ do + let actual = mrgDeleteFirstsBy (./=) l1 l2 :: UnionM [Integer] + let expected = mrgPure $ deleteFirstsBy (/=) l1 l2 + actual @?= expected + ], + testGroup + "mrgUnionBy" + [ testProperty "concrete int" $ + \l1 l2 -> ioProperty $ do + let actual = mrgUnionBy (.==) l1 l2 :: UnionM [Integer] + let expected = mrgPure $ unionBy (==) l1 l2 + actual @?= expected + ], + testGroup + "mrgIntersectBy" + [ testProperty "concrete int" $ + \l1 l2 -> ioProperty $ do + let actual = mrgIntersectBy (.==) l1 l2 :: UnionM [Integer] + let expected = mrgPure $ intersectBy (==) l1 l2 + actual @?= expected, + testCase "symbolic int" $ do + let actual = + mrgIntersectBy (.==) [aint, bint] [cint, dint] :: + UnionM [SymInteger] + let expected = + mrgIf + ( symNot $ + (bint .== cint .|| bint .== dint) + .|| (aint .== cint .|| aint .== dint) + ) + (return []) + ( mrgIf + ( symNot $ + (bint .== cint .|| bint .== dint) + .&& (aint .== cint .|| aint .== dint) + ) + ( return + [symIte (bint .== cint .|| bint .== dint) bint aint] + ) + (return [aint, bint]) + ) + actual @?= expected + ], + testGroup + "mrgGroupBy" + [ testProperty "concrete int" $ + \l -> ioProperty $ do + let actual = mrgGroupBy (.==) l :: UnionM [[Integer]] + let expected = mrgPure $ groupBy (==) l + actual @?= expected, + testCase "symbolic int" $ do + let actual = + mrgGroupBy (.==) [aint, bint, cint] :: UnionM [[SymInteger]] + let expected = + mrgIf + (aint .== bint .&& aint .== cint) + (return [[aint, bint, cint]]) + $ mrgIf + (aint .== bint .|| bint .== cint) + ( mrgIf (aint .== bint) (return [[aint, bint], [cint]]) $ + return [[aint], [bint, cint]] + ) + $ return [[aint], [bint], [cint]] + + actual @?= expected + ], + testGroup + "mrgInsert" + [ testProperty "concrete int" $ + \i l -> ioProperty $ do + let actual = mrgInsert i l :: UnionM [Integer] + let expected = mrgPure $ insert i l + actual @?= expected, + testCase "symbolic int" $ do + let actual = + mrgInsert aint [bint, cint, dint] :: UnionM [SymInteger] + let expected = + mrgPure + [ symIte (aint .<= bint) aint bint, + symIte (aint .<= bint) bint $ + symIte (aint .<= cint) aint cint, + symIte (aint .<= bint .|| aint .<= cint) cint $ + symIte (aint .<= dint) aint dint, + symIte + (aint .<= bint .|| aint .<= cint .|| aint .<= dint) + dint + aint + ] + actual @?= expected + ], + testGroup + "mrgInsertBy" + [ testProperty "concrete int" $ + \i l -> ioProperty $ do + let actual = mrgInsertBy symCompare i l :: UnionM [Integer] + let expected = mrgPure $ insertBy compare i l + actual @?= expected + ] + ] diff --git a/test/Grisette/Lib/Data/TraversableTests.hs b/test/Grisette/Lib/Data/TraversableTests.hs --- a/test/Grisette/Lib/Data/TraversableTests.hs +++ b/test/Grisette/Lib/Data/TraversableTests.hs @@ -5,23 +5,31 @@ import Control.Monad.Except ( ExceptT (ExceptT), MonadError (throwError), - runExceptT, ) -import Grisette.Core.Control.Monad.UnionM (UnionM) -import Grisette.Core.Data.Class.SimpleMergeable - ( UnionLike (unionIf), +import Grisette + ( UnionM, + UnionMergeable1 (mrgIfPropagatedStrategy), mrgIf, mrgSingle, ) +import Grisette.Lib.Control.Monad (mrgReturn) import Grisette.Lib.Data.Traversable ( mrgFor, + mrgForAccumM, mrgForM, + mrgMapAccumM, mrgMapM, mrgSequence, mrgSequenceA, mrgTraverse, ) -import Test.Framework (Test, testGroup) +import Grisette.TestUtil.NoMerge (oneNotMerged) +import Test.Framework + ( Test, + TestOptions' (topt_timeout), + plusTestOptions, + testGroup, + ) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit ((@?=)) @@ -29,84 +37,137 @@ traversableFunctionTests = testGroup "Traversable" - [ testCase "mrgTraverse" $ do - runExceptT - ( mrgTraverse - (\(c, d, x, y, z) -> ExceptT $ unionIf c (return $ Left x) (unionIf d (return $ Right y) (return $ Right z))) - [("a", "c", 3, 4, 5), ("b", "d", 2, 3, 6)] :: - ExceptT Integer UnionM [Integer] - ) - @?= runExceptT - ( do - a <- mrgIf "a" (throwError 3) (mrgIf "c" (return 4) (return 5)) - b <- mrgIf "b" (throwError 2) (mrgIf "d" (return 3) (return 6)) - mrgSingle [a, b] - ), - testCase "mrgSequenceA" $ do - runExceptT - ( mrgSequenceA - [ ExceptT $ unionIf "a" (return $ Left 3) (unionIf "c" (return $ Right 4) (return $ Right 5)), - ExceptT $ unionIf "b" (return $ Left 2) (unionIf "d" (return $ Right 3) (return $ Right 6)) - ] :: - ExceptT Integer UnionM [Integer] - ) - @?= runExceptT - ( do - a <- mrgIf "a" (throwError 3) (mrgIf "c" (return 4) (return 5)) - b <- mrgIf "b" (throwError 2) (mrgIf "d" (return 3) (return 6)) - mrgSingle [a, b] - ), - testCase "mrgMapM" $ do - runExceptT - ( mrgMapM - (\(c, d, x, y, z) -> ExceptT $ unionIf c (return $ Left x) (unionIf d (return $ Right y) (return $ Right z))) - [("a", "c", 3, 4, 5), ("b", "d", 2, 3, 6)] :: - ExceptT Integer UnionM [Integer] - ) - @?= runExceptT - ( do - a <- mrgIf "a" (throwError 3) (mrgIf "c" (return 4) (return 5)) - b <- mrgIf "b" (throwError 2) (mrgIf "d" (return 3) (return 6)) - mrgSingle [a, b] - ), - testCase "mrgSequence" $ do - runExceptT - ( mrgSequence - [ ExceptT $ unionIf "a" (return $ Left 3) (unionIf "c" (return $ Right 4) (return $ Right 5)), - ExceptT $ unionIf "b" (return $ Left 2) (unionIf "d" (return $ Right 3) (return $ Right 6)) - ] :: - ExceptT Integer UnionM [Integer] - ) - @?= runExceptT - ( do - a <- mrgIf "a" (throwError 3) (mrgIf "c" (return 4) (return 5)) - b <- mrgIf "b" (throwError 2) (mrgIf "d" (return 3) (return 6)) - mrgSingle [a, b] - ), - testCase "mrgFor" $ do - runExceptT - ( mrgFor - [("a", "c", 3, 4, 5), ("b", "d", 2, 3, 6)] - (\(c, d, x, y, z) -> ExceptT $ unionIf c (return $ Left x) (unionIf d (return $ Right y) (return $ Right z))) :: - ExceptT Integer UnionM [Integer] - ) - @?= runExceptT - ( do - a <- mrgIf "a" (throwError 3) (mrgIf "c" (return 4) (return 5)) - b <- mrgIf "b" (throwError 2) (mrgIf "d" (return 3) (return 6)) - mrgSingle [a, b] - ), - testCase "mrgForM" $ do - runExceptT - ( mrgForM - [("a", "c", 3, 4, 5), ("b", "d", 2, 3, 6)] - (\(c, d, x, y, z) -> ExceptT $ unionIf c (return $ Left x) (unionIf d (return $ Right y) (return $ Right z))) :: - ExceptT Integer UnionM [Integer] - ) - @?= runExceptT - ( do - a <- mrgIf "a" (throwError 3) (mrgIf "c" (return 4) (return 5)) - b <- mrgIf "b" (throwError 2) (mrgIf "d" (return 3) (return 6)) - mrgSingle [a, b] - ) + [ plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $ + testGroup "mrgTraverse, mrgMapM, mrgFor, mrgForM" $ do + (name, func0, func1) <- + [ ("mrgTraverse", mrgTraverse, mrgTraverse), + ("mrgMapM", mrgMapM, mrgMapM), + ("mrgFor", flip mrgFor, flip mrgFor), + ("mrgForM", flip mrgForM, flip mrgForM) + ] + return $ + testGroup + name + [ testCase "semantics" $ do + let actual = + func0 + ( \(c, d, x, y, z) -> + ExceptT $ + mrgIfPropagatedStrategy + c + (return $ Left x) + ( mrgIfPropagatedStrategy + d + (return $ Right y) + (return $ Right z) + ) + ) + [("a", "c", 3, 4, 5), ("b", "d", 2, 3, 6)] :: + ExceptT Integer UnionM [Integer] + let expected = do + a <- + mrgIf + "a" + (throwError 3) + (mrgIf "c" (return 4) (return 5)) + b <- + mrgIf + "b" + (throwError 2) + (mrgIf "d" (return 3) (return 6)) + mrgSingle [a, b] + actual @?= expected, + testCase "merge intermediate" $ do + let actual = func1 (const oneNotMerged) [1 .. 1000] + let expected = mrgReturn $ replicate 1000 1 + actual @?= expected + ], + plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $ + testGroup "mrgSequenceA, mrgSequence" $ do + (name, func0, func1) <- + [ ("mrgSequenceA", mrgSequenceA, mrgSequenceA), + ("mrgSequence", mrgSequence, mrgSequence) + ] + return $ + testGroup + name + [ testCase "semantics" $ do + let actual = + func0 + [ ExceptT $ + mrgIfPropagatedStrategy + "a" + (return $ Left 3) + ( mrgIfPropagatedStrategy + "c" + (return $ Right 4) + (return $ Right 5) + ), + ExceptT $ + mrgIfPropagatedStrategy + "b" + (return $ Left 2) + ( mrgIfPropagatedStrategy + "d" + (return $ Right 3) + (return $ Right 6) + ) + ] :: + ExceptT Integer UnionM [Integer] + let expected = do + a <- + mrgIf + "a" + (throwError 3) + (mrgIf "c" (return 4) (return 5)) + b <- + mrgIf + "b" + (throwError 2) + (mrgIf "d" (return 3) (return 6)) + mrgSingle [a, b] + actual @?= expected, + testCase "merge intermediate" $ do + let actual = func1 (replicate 1000 oneNotMerged) + let expected = mrgReturn $ replicate 1000 1 + actual @?= expected + ], + plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $ + testGroup "mrgMapAccumM, mrgForAccumM" $ do + (name, func0, func1) <- + [ ("mrgMapAccumM", mrgMapAccumM, mrgMapAccumM), + ( "mrgForAccumM", + \f s t -> mrgForAccumM s t f, + \f s t -> mrgForAccumM s t f + ) + ] + return $ + testGroup + name + [ testCase "semantics" $ do + let actual = + func0 (\a b -> mrgSingle (a + b, a - b)) 0 [1 .. 1000] + let expected = + mrgReturn + ( 500500, + [(i - 1) * i `div` 2 - i | i <- [1 .. 1000]] + ) :: + UnionM (Integer, [Integer]) + actual @?= expected, + testCase "merge intermediate" $ do + let actual = + func1 + ( \_ _ -> + mrgIfPropagatedStrategy + "a" + (return (1, 1)) + (return (1, 1)) + ) + 0 + [1 .. 1000] + let expected = + mrgReturn (1, replicate 1000 1) :: + UnionM (Integer, [Integer]) + actual @?= expected + ] ] diff --git a/test/Grisette/SymPrim/Prim/BVTests.hs b/test/Grisette/SymPrim/Prim/BVTests.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/SymPrim/Prim/BVTests.hs @@ -0,0 +1,924 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Grisette.SymPrim.Prim.BVTests (bvTests) where + +import Data.Proxy (Proxy (Proxy)) +import GHC.TypeNats (KnownNat, type (+), type (<=)) +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.Prim.Term + ( PEvalBVSignConversionTerm + ( pevalBVToSignedTerm, + pevalBVToUnsignedTerm + ), + PEvalBVTerm + ( pevalBVConcatTerm, + pevalBVExtendTerm, + pevalBVSelectTerm + ), + Term, + bvconcatTerm, + bvextendTerm, + bvselectTerm, + conTerm, + ssymTerm, + toSignedTerm, + toUnsignedTerm, + ) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@?=)) + +data ToSignedTest = ToSignedTest + { toSignedTestName :: String, + toSignedTestTerm :: Term (WordN 4), + toSignedTestExpected :: Term (IntN 4) + } + +data ToUnsignedTest = ToUnsignedTest + { toUnsignedTestName :: String, + toUnsignedTestTerm :: Term (IntN 4), + toUnsignedTestExpected :: Term (WordN 4) + } + +data BVSelectTest where + BVSelectTest :: + forall ix w n bv. + ( PEvalBVTerm bv, + KnownNat ix, + 1 <= n, + KnownNat w, + 1 <= w, + KnownNat n, + ix + w <= n + ) => + { bvSelectTestName :: String, + bvSelectIx :: Proxy ix, + bvSelectW :: Proxy w, + bvSelectTestTerm :: Term (bv n), + bvSelectTestExpected :: Term (bv w) + } -> + BVSelectTest + +data BVExtendTest where + BVExtendTest :: + forall l r bv. + ( PEvalBVTerm bv, + KnownNat l, + 1 <= l, + KnownNat r, + 1 <= r, + l <= r + ) => + { bvExtendTestName :: String, + bvExtendSigned :: Bool, + bvExtendR :: Proxy r, + bvExtendTestTerm :: Term (bv l), + bvExtendExpected :: Term (bv r) + } -> + BVExtendTest + +data BVConcatTest where + BVConcatTest :: + forall l r bv. + ( PEvalBVTerm bv, + KnownNat l, + KnownNat r, + KnownNat (l + r), + 1 <= l, + 1 <= r, + 1 <= l + r + ) => + { bvConcatTestName :: String, + bvConcatTestLhs :: Term (bv l), + bvConcatTestRhs :: Term (bv r), + bvConcatTestExpected :: Term (bv (l + r)) + } -> + BVConcatTest + +bvTests :: Test +bvTests = + testGroup + "BV" + [ testGroup "pevalBVToSignedTerm" $ do + ToSignedTest name term expected <- + [ ToSignedTest + { toSignedTestName = "concrete", + toSignedTestTerm = conTerm 6, + toSignedTestExpected = conTerm 6 + }, + ToSignedTest + { toSignedTestName = "symbolic", + toSignedTestTerm = ssymTerm "a", + toSignedTestExpected = toSignedTerm $ ssymTerm "a" + }, + ToSignedTest + { toSignedTestName = "toUnsigned", + toSignedTestTerm = toUnsignedTerm $ ssymTerm "a", + toSignedTestExpected = ssymTerm "a" + }, + ToSignedTest + { toSignedTestName = "bvConcat", + toSignedTestTerm = + bvconcatTerm + (ssymTerm "a" :: Term (WordN 2)) + (ssymTerm "b" :: Term (WordN 2)), + toSignedTestExpected = + bvconcatTerm + (toSignedTerm (ssymTerm "a" :: Term (WordN 2))) + (toSignedTerm (ssymTerm "b" :: Term (WordN 2))) + }, + ToSignedTest + { toSignedTestName = "bvExtend", + toSignedTestTerm = + bvextendTerm True (Proxy @4) (ssymTerm "a" :: Term (WordN 2)), + toSignedTestExpected = + bvextendTerm + True + (Proxy @4) + (toSignedTerm (ssymTerm "a" :: Term (WordN 2))) + } + ] + return $ testCase name $ do + let actual = pevalBVToSignedTerm term + actual @?= expected, + testGroup "pevalBVToUnsignedTerm" $ do + ToUnsignedTest name term expected <- + [ ToUnsignedTest + { toUnsignedTestName = "concrete", + toUnsignedTestTerm = conTerm 6, + toUnsignedTestExpected = conTerm 6 + }, + ToUnsignedTest + { toUnsignedTestName = "symbolic", + toUnsignedTestTerm = ssymTerm "a", + toUnsignedTestExpected = toUnsignedTerm $ ssymTerm "a" + }, + ToUnsignedTest + { toUnsignedTestName = "toSigned", + toUnsignedTestTerm = toSignedTerm $ ssymTerm "a", + toUnsignedTestExpected = ssymTerm "a" + }, + ToUnsignedTest + { toUnsignedTestName = "bvConcat", + toUnsignedTestTerm = + bvconcatTerm + (ssymTerm "a" :: Term (IntN 2)) + (ssymTerm "b" :: Term (IntN 2)), + toUnsignedTestExpected = + bvconcatTerm + (toUnsignedTerm (ssymTerm "a" :: Term (IntN 2))) + (toUnsignedTerm (ssymTerm "b" :: Term (IntN 2))) + }, + ToUnsignedTest + { toUnsignedTestName = "bvExtend", + toUnsignedTestTerm = + bvextendTerm True (Proxy @4) (ssymTerm "a" :: Term (IntN 2)), + toUnsignedTestExpected = + bvextendTerm + True + (Proxy @4) + (toUnsignedTerm (ssymTerm "a" :: Term (IntN 2))) + } + ] + return $ testCase name $ do + let actual = pevalBVToUnsignedTerm term + actual @?= expected, + testGroup "pevalBVSelectTerm" $ do + BVSelectTest name ix w term expected <- + [ BVSelectTest + { bvSelectTestName = "concrete 0 1", + bvSelectIx = Proxy @0, + bvSelectW = Proxy @1, + bvSelectTestTerm = conTerm 6 :: Term (WordN 4), + bvSelectTestExpected = conTerm 0 + }, + BVSelectTest + { bvSelectTestName = "concrete 1 1", + bvSelectIx = Proxy @1, + bvSelectW = Proxy @1, + bvSelectTestTerm = conTerm 6 :: Term (WordN 4), + bvSelectTestExpected = conTerm 1 + }, + BVSelectTest + { bvSelectTestName = "concrete 2 1", + bvSelectIx = Proxy @2, + bvSelectW = Proxy @1, + bvSelectTestTerm = conTerm 6 :: Term (WordN 4), + bvSelectTestExpected = conTerm 1 + }, + BVSelectTest + { bvSelectTestName = "concrete 3 1", + bvSelectIx = Proxy @3, + bvSelectW = Proxy @1, + bvSelectTestTerm = conTerm 6 :: Term (WordN 4), + bvSelectTestExpected = conTerm 0 + }, + BVSelectTest + { bvSelectTestName = "concrete 0 2", + bvSelectIx = Proxy @0, + bvSelectW = Proxy @2, + bvSelectTestTerm = conTerm 6 :: Term (WordN 4), + bvSelectTestExpected = conTerm 2 + }, + BVSelectTest + { bvSelectTestName = "concrete 1 2", + bvSelectIx = Proxy @1, + bvSelectW = Proxy @2, + bvSelectTestTerm = conTerm 6 :: Term (WordN 4), + bvSelectTestExpected = conTerm 3 + }, + BVSelectTest + { bvSelectTestName = "concrete 0 4", + bvSelectIx = Proxy @0, + bvSelectW = Proxy @4, + bvSelectTestTerm = conTerm 6 :: Term (WordN 4), + bvSelectTestExpected = conTerm 6 + }, + BVSelectTest + { bvSelectTestName = "symbolic", + bvSelectIx = Proxy @2, + bvSelectW = Proxy @1, + bvSelectTestTerm = ssymTerm "a" :: Term (WordN 4), + bvSelectTestExpected = + bvselectTerm + (Proxy @2) + (Proxy @1) + (ssymTerm "a" :: Term (WordN 4)) + }, + BVSelectTest + { bvSelectTestName = "On ToSigned", + bvSelectIx = Proxy @2, + bvSelectW = Proxy @1, + bvSelectTestTerm = + toSignedTerm (ssymTerm "a" :: Term (WordN 4)), + bvSelectTestExpected = + toSignedTerm + ( bvselectTerm + (Proxy @2) + (Proxy @1) + (ssymTerm "a" :: Term (WordN 4)) + ) + }, + BVSelectTest + { bvSelectTestName = "On ToUnsigned", + bvSelectIx = Proxy @2, + bvSelectW = Proxy @1, + bvSelectTestTerm = + toUnsignedTerm (ssymTerm "a" :: Term (IntN 4)), + bvSelectTestExpected = + toUnsignedTerm + ( bvselectTerm + (Proxy @2) + (Proxy @1) + (ssymTerm "a" :: Term (IntN 4)) + ) + }, + BVSelectTest + { bvSelectTestName = "On BVSelect", + bvSelectIx = Proxy @3, + bvSelectW = Proxy @2, + bvSelectTestTerm = + bvselectTerm + (Proxy @2) + (Proxy @6) + (ssymTerm "a" :: Term (WordN 16)), + bvSelectTestExpected = + bvselectTerm + (Proxy @5) + (Proxy @2) + (ssymTerm "a" :: Term (WordN 16)) + }, + BVSelectTest + { bvSelectTestName = "Whole vector", + bvSelectIx = Proxy @0, + bvSelectW = Proxy @4, + bvSelectTestTerm = ssymTerm "a" :: Term (WordN 4), + bvSelectTestExpected = ssymTerm "a" + }, + BVSelectTest + { bvSelectTestName = "bvConcat only lower part", + bvSelectIx = Proxy @1, + bvSelectW = Proxy @2, + bvSelectTestTerm = + bvconcatTerm + (ssymTerm "a" :: Term (WordN 4)) + (ssymTerm "b" :: Term (WordN 4)), + bvSelectTestExpected = + bvselectTerm + (Proxy @1) + (Proxy @2) + (ssymTerm "b" :: Term (WordN 4)) + }, + BVSelectTest + { bvSelectTestName = "bvConcat whole lower part", + bvSelectIx = Proxy @0, + bvSelectW = Proxy @4, + bvSelectTestTerm = + bvconcatTerm + (ssymTerm "a" :: Term (WordN 4)) + (ssymTerm "b" :: Term (WordN 4)), + bvSelectTestExpected = ssymTerm "b" :: Term (WordN 4) + }, + BVSelectTest + { bvSelectTestName = "bvConcat only higher part", + bvSelectIx = Proxy @5, + bvSelectW = Proxy @2, + bvSelectTestTerm = + bvconcatTerm + (ssymTerm "a" :: Term (WordN 4)) + (ssymTerm "b" :: Term (WordN 4)), + bvSelectTestExpected = + bvselectTerm + (Proxy @1) + (Proxy @2) + (ssymTerm "a" :: Term (WordN 4)) + }, + BVSelectTest + { bvSelectTestName = "bvConcat whole higher part", + bvSelectIx = Proxy @4, + bvSelectW = Proxy @4, + bvSelectTestTerm = + bvconcatTerm + (ssymTerm "a" :: Term (WordN 4)) + (ssymTerm "b" :: Term (WordN 4)), + bvSelectTestExpected = ssymTerm "a" :: Term (WordN 4) + }, + BVSelectTest + { bvSelectTestName = "bvConcat cross border", + bvSelectIx = Proxy @3, + bvSelectW = Proxy @4, + bvSelectTestTerm = + bvconcatTerm + (ssymTerm "a" :: Term (WordN 4)) + (ssymTerm "b" :: Term (WordN 4)), + bvSelectTestExpected = + bvconcatTerm + ( bvselectTerm + (Proxy @0) + (Proxy @3) + (ssymTerm "a" :: Term (WordN 4)) + ) + ( bvselectTerm + (Proxy @3) + (Proxy @1) + (ssymTerm "b" :: Term (WordN 4)) + ) + }, + BVSelectTest + { bvSelectTestName = "bvExtend only lower part", + bvSelectIx = Proxy @1, + bvSelectW = Proxy @2, + bvSelectTestTerm = + bvextendTerm True (Proxy @8) (ssymTerm "a" :: Term (WordN 4)), + bvSelectTestExpected = + bvselectTerm + (Proxy @1) + (Proxy @2) + (ssymTerm "a" :: Term (WordN 4)) + }, + BVSelectTest + { bvSelectTestName = "bvExtend whole lower part", + bvSelectIx = Proxy @0, + bvSelectW = Proxy @4, + bvSelectTestTerm = + bvextendTerm True (Proxy @8) (ssymTerm "a" :: Term (WordN 4)), + bvSelectTestExpected = ssymTerm "a" :: Term (WordN 4) + }, + BVSelectTest + { bvSelectTestName = "bvExtend cross boarder", + bvSelectIx = Proxy @3, + bvSelectW = Proxy @4, + bvSelectTestTerm = + bvextendTerm True (Proxy @8) (ssymTerm "a" :: Term (WordN 4)), + bvSelectTestExpected = + bvextendTerm True (Proxy @4) $ + bvselectTerm + (Proxy @3) + (Proxy @1) + (ssymTerm "a" :: Term (WordN 4)) + } + ] + return . testCase name $ + pevalBVSelectTerm ix w term @?= expected, + testGroup "pevalBVExtendTerm" $ do + BVExtendTest name signed pr term expected <- + [ BVExtendTest + { bvExtendTestName = "Concrete zext on negative", + bvExtendSigned = False, + bvExtendR = Proxy @6, + bvExtendTestTerm = conTerm 15 :: Term (WordN 4), + bvExtendExpected = conTerm 15 :: Term (WordN 6) + }, + BVExtendTest + { bvExtendTestName = "Concrete sext on negative", + bvExtendSigned = True, + bvExtendR = Proxy @6, + bvExtendTestTerm = conTerm 15 :: Term (WordN 4), + bvExtendExpected = conTerm 63 :: Term (WordN 6) + }, + BVExtendTest + { bvExtendTestName = "Concrete zext on positive", + bvExtendSigned = False, + bvExtendR = Proxy @6, + bvExtendTestTerm = conTerm 7 :: Term (WordN 4), + bvExtendExpected = conTerm 7 :: Term (WordN 6) + }, + BVExtendTest + { bvExtendTestName = "Concrete sext on positive", + bvExtendSigned = True, + bvExtendR = Proxy @6, + bvExtendTestTerm = conTerm 7 :: Term (WordN 4), + bvExtendExpected = conTerm 7 :: Term (WordN 6) + }, + BVExtendTest + { bvExtendTestName = "Same width", + bvExtendSigned = False, + bvExtendR = Proxy @4, + bvExtendTestTerm = ssymTerm "a" :: Term (WordN 4), + bvExtendExpected = ssymTerm "a" :: Term (WordN 4) + }, + BVExtendTest + { bvExtendTestName = "Symbolic zext", + bvExtendSigned = False, + bvExtendR = Proxy @6, + bvExtendTestTerm = ssymTerm "a" :: Term (WordN 4), + bvExtendExpected = + bvconcatTerm + (conTerm 0 :: Term (WordN 2)) + (ssymTerm "a" :: Term (WordN 4)) + }, + BVExtendTest + { bvExtendTestName = "Symbolic sext on sext", + bvExtendSigned = True, + bvExtendR = Proxy @6, + bvExtendTestTerm = + pevalBVExtendTerm + True + (Proxy @4) + (ssymTerm "a" :: Term (WordN 2)), + bvExtendExpected = + bvextendTerm True (Proxy @6) (ssymTerm "a" :: Term (WordN 2)) + } + ] + return . testCase name $ + pevalBVExtendTerm signed pr term @?= expected, + testGroup "pevalBVConcatTerm" $ do + BVConcatTest name lhs rhs expected <- + [ BVConcatTest + { bvConcatTestName = "[c1 c2] -> c1c2", + bvConcatTestLhs = conTerm 3 :: Term (WordN 4), + bvConcatTestRhs = conTerm 5 :: Term (WordN 3), + bvConcatTestExpected = conTerm 29 + }, + BVConcatTest + { bvConcatTestName = "[c1 (c2 s)] -> (c1c2 s)", + bvConcatTestLhs = conTerm 3 :: Term (WordN 4), + bvConcatTestRhs = + bvconcatTerm + (conTerm 5 :: Term (WordN 3)) + (ssymTerm "b" :: Term (WordN 3)), + bvConcatTestExpected = + bvconcatTerm + (conTerm 29 :: Term (WordN 7)) + ( ssymTerm "b" :: Term (WordN 3) + ) + }, + BVConcatTest + { bvConcatTestName = "[c1 (s c2)] -> (c1 (s c2))", + bvConcatTestLhs = conTerm 3 :: Term (WordN 4), + bvConcatTestRhs = + bvconcatTerm + (ssymTerm "b" :: Term (WordN 3)) + (conTerm 5 :: Term (WordN 3)), + bvConcatTestExpected = + bvconcatTerm + (conTerm 3 :: Term (WordN 4)) + ( bvconcatTerm + (ssymTerm "b" :: Term (WordN 3)) + (conTerm 5 :: Term (WordN 3)) + ) + }, + BVConcatTest + { bvConcatTestName = "[c1 (c2 (s c3))] -> (c1c2 (s c3))", + bvConcatTestLhs = conTerm 3 :: Term (WordN 4), + bvConcatTestRhs = + bvconcatTerm (conTerm 5 :: Term (WordN 5)) $ + bvconcatTerm + (ssymTerm "b" :: Term (WordN 6)) + (conTerm 7 :: Term (WordN 7)), + bvConcatTestExpected = + bvconcatTerm + (conTerm 101 :: Term (WordN 9)) + ( bvconcatTerm + (ssymTerm "b" :: Term (WordN 6)) + (conTerm 7 :: Term (WordN 7)) + ) + }, + BVConcatTest + { bvConcatTestName = "[c s] -> (c s)", + bvConcatTestLhs = conTerm 3 :: Term (WordN 4), + bvConcatTestRhs = ssymTerm "b" :: Term (WordN 3), + bvConcatTestExpected = + bvconcatTerm + (conTerm 3 :: Term (WordN 4)) + (ssymTerm "b" :: Term (WordN 3)) + }, + BVConcatTest + { bvConcatTestName = "[(c1 s) c2] -> (c1 (s c2))", + bvConcatTestLhs = + bvconcatTerm + (conTerm 3 :: Term (WordN 4)) + (ssymTerm "a" :: Term (WordN 4)), + bvConcatTestRhs = conTerm 5 :: Term (WordN 3), + bvConcatTestExpected = + bvconcatTerm + (conTerm 3 :: Term (WordN 4)) + ( bvconcatTerm + (ssymTerm "a" :: Term (WordN 4)) + ( conTerm 5 :: Term (WordN 3) + ) + ) + }, + BVConcatTest + { bvConcatTestName = "[(c1 s1) (c2 s2)] -> (c1 (s1 (c2 s2)))", + bvConcatTestLhs = + bvconcatTerm + (conTerm 3 :: Term (WordN 4)) + (ssymTerm "a" :: Term (WordN 4)), + bvConcatTestRhs = + bvconcatTerm + (conTerm 5 :: Term (WordN 4)) + (ssymTerm "b" :: Term (WordN 4)), + bvConcatTestExpected = + bvconcatTerm + (conTerm 3 :: Term (WordN 4)) + ( bvconcatTerm + (ssymTerm "a" :: Term (WordN 4)) + ( bvconcatTerm + (conTerm 5 :: Term (WordN 4)) + (ssymTerm "b" :: Term (WordN 4)) + ) + ) + }, + BVConcatTest + { bvConcatTestName = "[(c1 s1) (s2 c2)] -> (c1 ((s1 s2) c2))", + bvConcatTestLhs = + bvconcatTerm + (conTerm 3 :: Term (WordN 4)) + (ssymTerm "a" :: Term (WordN 4)), + bvConcatTestRhs = + bvconcatTerm + (ssymTerm "b" :: Term (WordN 4)) + (conTerm 5 :: Term (WordN 4)), + bvConcatTestExpected = + bvconcatTerm + (conTerm 3 :: Term (WordN 4)) + ( bvconcatTerm + ( bvconcatTerm + (ssymTerm "a" :: Term (WordN 4)) + (ssymTerm "b" :: Term (WordN 4)) + ) + (conTerm 5 :: Term (WordN 4)) + ) + }, + BVConcatTest + { bvConcatTestName = + "[(c1 s1) (c2 (s2 c3))] -> (c1 (((s1 c2) s2)) c3))", + bvConcatTestLhs = + bvconcatTerm + (conTerm 3 :: Term (WordN 4)) + (ssymTerm "a" :: Term (WordN 4)), + bvConcatTestRhs = + bvconcatTerm + (conTerm 5 :: Term (WordN 4)) + ( bvconcatTerm + (ssymTerm "b" :: Term (WordN 4)) + (conTerm 7 :: Term (WordN 4)) + ), + bvConcatTestExpected = + bvconcatTerm + (conTerm 3 :: Term (WordN 4)) + ( bvconcatTerm + ( bvconcatTerm + ( bvconcatTerm + (ssymTerm "a" :: Term (WordN 4)) + (conTerm 5 :: Term (WordN 4)) + ) + (ssymTerm "b" :: Term (WordN 4)) + ) + (conTerm 7 :: Term (WordN 4)) + ) + }, + BVConcatTest + { bvConcatTestName = "[(c s1) s2] -> (c (s1 s2))", + bvConcatTestLhs = + bvconcatTerm + (conTerm 3 :: Term (WordN 4)) + (ssymTerm "a" :: Term (WordN 4)), + bvConcatTestRhs = ssymTerm "b" :: Term (WordN 3), + bvConcatTestExpected = + bvconcatTerm + (conTerm 3 :: Term (WordN 4)) + ( bvconcatTerm + (ssymTerm "a" :: Term (WordN 4)) + (ssymTerm "b" :: Term (WordN 3)) + ) + }, + BVConcatTest + { bvConcatTestName = "[(s c1) c2] -> (s c1c2)", + bvConcatTestLhs = + bvconcatTerm + (ssymTerm "a" :: Term (WordN 4)) + (conTerm 5 :: Term (WordN 3)), + bvConcatTestRhs = conTerm 3 :: Term (WordN 4), + bvConcatTestExpected = + bvconcatTerm + (ssymTerm "a" :: Term (WordN 4)) + (conTerm 83 :: Term (WordN 7)) + }, + BVConcatTest + { bvConcatTestName = "[(s1 c1) (c2 s2)] -> (s1 (c1c2 s2))", + bvConcatTestLhs = + bvconcatTerm + (ssymTerm "a" :: Term (WordN 4)) + (conTerm 5 :: Term (WordN 4)), + bvConcatTestRhs = + bvconcatTerm + (conTerm 3 :: Term (WordN 4)) + (ssymTerm "b" :: Term (WordN 4)), + bvConcatTestExpected = + bvconcatTerm + (ssymTerm "a" :: Term (WordN 4)) + ( bvconcatTerm + (conTerm 83 :: Term (WordN 8)) + (ssymTerm "b" :: Term (WordN 4)) + ) + }, + BVConcatTest + { bvConcatTestName = "[(s1 c1) (s2 c2)] -> (((s1 c1) s2) c2)", + bvConcatTestLhs = + bvconcatTerm + (ssymTerm "a" :: Term (WordN 4)) + (conTerm 5 :: Term (WordN 4)), + bvConcatTestRhs = + bvconcatTerm + (ssymTerm "b" :: Term (WordN 4)) + (conTerm 3 :: Term (WordN 4)), + bvConcatTestExpected = + bvconcatTerm + ( bvconcatTerm + ( bvconcatTerm + (ssymTerm "a" :: Term (WordN 4)) + (conTerm 5 :: Term (WordN 4)) + ) + (ssymTerm "b" :: Term (WordN 4)) + ) + (conTerm 3 :: Term (WordN 4)) + }, + BVConcatTest + { bvConcatTestName = + "[(s1 c1) (c2 (s2 c3))] -> (((s1 c1c2) s2) c3)", + bvConcatTestLhs = + bvconcatTerm + (ssymTerm "a" :: Term (WordN 4)) + (conTerm 5 :: Term (WordN 4)), + bvConcatTestRhs = + bvconcatTerm + (conTerm 3 :: Term (WordN 4)) + ( bvconcatTerm + (ssymTerm "b" :: Term (WordN 4)) + (conTerm 7 :: Term (WordN 4)) + ), + bvConcatTestExpected = + bvconcatTerm + ( bvconcatTerm + ( bvconcatTerm + (ssymTerm "a" :: Term (WordN 4)) + (conTerm 83 :: Term (WordN 8)) + ) + ( ssymTerm "b" :: Term (WordN 4) + ) + ) + (conTerm 7 :: Term (WordN 4)) + }, + BVConcatTest + { bvConcatTestName = "[(s1 c1) s2] -> ((s1 c1) s2)", + bvConcatTestLhs = + bvconcatTerm + (ssymTerm "a" :: Term (WordN 4)) + (conTerm 5 :: Term (WordN 4)), + bvConcatTestRhs = ssymTerm "b" :: Term (WordN 3), + bvConcatTestExpected = + bvconcatTerm + ( bvconcatTerm + (ssymTerm "a" :: Term (WordN 4)) + (conTerm 5 :: Term (WordN 4)) + ) + (ssymTerm "b" :: Term (WordN 3)) + }, + BVConcatTest + { bvConcatTestName = "[(c1 (s1 c2)) c3] -> (c1 (s1 c2c3))", + bvConcatTestLhs = + bvconcatTerm + (conTerm 3 :: Term (WordN 4)) + ( bvconcatTerm + (ssymTerm "a" :: Term (WordN 4)) + (conTerm 5 :: Term (WordN 4)) + ), + bvConcatTestRhs = conTerm 7 :: Term (WordN 4), + bvConcatTestExpected = + bvconcatTerm + (conTerm 3 :: Term (WordN 4)) + ( bvconcatTerm + (ssymTerm "a" :: Term (WordN 4)) + (conTerm 87 :: Term (WordN 8)) + ) + }, + BVConcatTest + { bvConcatTestName = + "[(c1 (s1 c2)) (c3 s3)] -> (c1 (s1 (c2c3 s3)))", + bvConcatTestLhs = + bvconcatTerm + (conTerm 3 :: Term (WordN 4)) + ( bvconcatTerm + (ssymTerm "a" :: Term (WordN 4)) + (conTerm 5 :: Term (WordN 4)) + ), + bvConcatTestRhs = + bvconcatTerm + (conTerm 7 :: Term (WordN 4)) + (ssymTerm "b" :: Term (WordN 4)), + bvConcatTestExpected = + bvconcatTerm + (conTerm 3 :: Term (WordN 4)) + ( bvconcatTerm + (ssymTerm "a" :: Term (WordN 4)) + ( bvconcatTerm + (conTerm 87 :: Term (WordN 8)) + ( ssymTerm "b" :: Term (WordN 4) + ) + ) + ) + }, + BVConcatTest + { bvConcatTestName = + "[(c1 (s1 c2)) (s2 c3)] -> (c1 (((s1 c2) s2) c3))", + bvConcatTestLhs = + bvconcatTerm + (conTerm 3 :: Term (WordN 4)) + ( bvconcatTerm + (ssymTerm "a" :: Term (WordN 4)) + (conTerm 5 :: Term (WordN 4)) + ), + bvConcatTestRhs = + bvconcatTerm + (ssymTerm "b" :: Term (WordN 4)) + (conTerm 7 :: Term (WordN 4)), + bvConcatTestExpected = + bvconcatTerm + (conTerm 3 :: Term (WordN 4)) + ( bvconcatTerm + ( bvconcatTerm + ( bvconcatTerm + (ssymTerm "a" :: Term (WordN 4)) + (conTerm 5 :: Term (WordN 4)) + ) + (ssymTerm "b" :: Term (WordN 4)) + ) + (conTerm 7 :: Term (WordN 4)) + ) + }, + BVConcatTest + { bvConcatTestName = + "[(c1 (s1 c2)) (c3 (s2 c4))] -> (c1 (((s1 c2c3) s2) c4))", + bvConcatTestLhs = + bvconcatTerm + (conTerm 3 :: Term (WordN 4)) + ( bvconcatTerm + (ssymTerm "a" :: Term (WordN 4)) + (conTerm 5 :: Term (WordN 4)) + ), + bvConcatTestRhs = + bvconcatTerm + (conTerm 7 :: Term (WordN 4)) + ( bvconcatTerm + (ssymTerm "b" :: Term (WordN 4)) + (conTerm 9 :: Term (WordN 4)) + ), + bvConcatTestExpected = + bvconcatTerm + (conTerm 3 :: Term (WordN 4)) + ( bvconcatTerm + ( bvconcatTerm + ( bvconcatTerm + (ssymTerm "a" :: Term (WordN 4)) + (conTerm 87 :: Term (WordN 8)) + ) + (ssymTerm "b" :: Term (WordN 4)) + ) + (conTerm 9 :: Term (WordN 4)) + ) + }, + BVConcatTest + { bvConcatTestName = "[(c1 (s1 c2)) s2] -> (c1 ((s1 c2) s2))", + bvConcatTestLhs = + bvconcatTerm + (conTerm 3 :: Term (WordN 4)) + ( bvconcatTerm + (ssymTerm "a" :: Term (WordN 4)) + (conTerm 5 :: Term (WordN 4)) + ), + bvConcatTestRhs = ssymTerm "b" :: Term (WordN 3), + bvConcatTestExpected = + bvconcatTerm + (conTerm 3 :: Term (WordN 4)) + ( bvconcatTerm + ( bvconcatTerm + (ssymTerm "a" :: Term (WordN 4)) + (conTerm 5 :: Term (WordN 4)) + ) + ( ssymTerm "b" :: Term (WordN 3) + ) + ) + }, + BVConcatTest + { bvConcatTestName = "[s c] -> (s c)", + bvConcatTestLhs = ssymTerm "a" :: Term (WordN 4), + bvConcatTestRhs = conTerm 5 :: Term (WordN 4), + bvConcatTestExpected = + bvconcatTerm + (ssymTerm "a" :: Term (WordN 4)) + (conTerm 5 :: Term (WordN 4)) + }, + BVConcatTest + { bvConcatTestName = "[s (c s)] -> (s (c s))", + bvConcatTestLhs = ssymTerm "a" :: Term (WordN 4), + bvConcatTestRhs = + bvconcatTerm + (conTerm 5 :: Term (WordN 4)) + (ssymTerm "b" :: Term (WordN 4)), + bvConcatTestExpected = + bvconcatTerm + (ssymTerm "a" :: Term (WordN 4)) + ( bvconcatTerm + (conTerm 5 :: Term (WordN 4)) + (ssymTerm "b" :: Term (WordN 4)) + ) + }, + BVConcatTest + { bvConcatTestName = "[s (s c)] -> ((s s) c))", + bvConcatTestLhs = ssymTerm "a" :: Term (WordN 4), + bvConcatTestRhs = + bvconcatTerm + (ssymTerm "b" :: Term (WordN 4)) + (conTerm 5 :: Term (WordN 4)), + bvConcatTestExpected = + bvconcatTerm + ( bvconcatTerm + (ssymTerm "a" :: Term (WordN 4)) + (ssymTerm "b" :: Term (WordN 4)) + ) + (conTerm 5 :: Term (WordN 4)) + }, + BVConcatTest + { bvConcatTestName = "[s (c (s c))] -> (((s c) s)) c)", + bvConcatTestLhs = ssymTerm "a" :: Term (WordN 4), + bvConcatTestRhs = + bvconcatTerm + (conTerm 5 :: Term (WordN 4)) + ( bvconcatTerm + (ssymTerm "b" :: Term (WordN 4)) + (conTerm 7 :: Term (WordN 4)) + ), + bvConcatTestExpected = + bvconcatTerm + ( bvconcatTerm + ( bvconcatTerm + (ssymTerm "a" :: Term (WordN 4)) + (conTerm 5 :: Term (WordN 4)) + ) + (ssymTerm "b" :: Term (WordN 4)) + ) + (conTerm 7 :: Term (WordN 4)) + }, + BVConcatTest + { bvConcatTestName = "[s1 s2] -> (s1 s2)", + bvConcatTestLhs = ssymTerm "a" :: Term (WordN 4), + bvConcatTestRhs = ssymTerm "b" :: Term (WordN 3), + bvConcatTestExpected = + bvconcatTerm + (ssymTerm "a" :: Term (WordN 4)) + (ssymTerm "b" :: Term (WordN 3)) + } + ] + return . testCase name $ + pevalBVConcatTerm lhs rhs @?= expected + ] diff --git a/test/Grisette/SymPrim/Prim/BitsTests.hs b/test/Grisette/SymPrim/Prim/BitsTests.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/SymPrim/Prim/BitsTests.hs @@ -0,0 +1,318 @@ +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Grisette.SymPrim.Prim.BitsTests (bitsTests) where + +import Data.Bits (Bits (rotateL, rotateR), FiniteBits) +import Grisette + ( IntN, + SymRotate, + WordN, + ) +import Grisette.Internal.SymPrim.Prim.Term + ( PEvalBitwiseTerm + ( pevalAndBitsTerm, + pevalComplementBitsTerm, + pevalOrBitsTerm, + pevalXorBitsTerm + ), + PEvalRotateTerm + ( pevalRotateLeftTerm, + pevalRotateRightTerm + ), + PEvalShiftTerm + ( pevalShiftLeftTerm, + pevalShiftRightTerm + ), + Term, + andBitsTerm, + complementBitsTerm, + conTerm, + orBitsTerm, + rotateLeftTerm, + rotateRightTerm, + shiftLeftTerm, + shiftRightTerm, + ssymTerm, + xorBitsTerm, + ) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.HUnit ((@=?)) +import Test.QuickCheck (Property, discard, ioProperty) + +bitsTests :: Test +bitsTests = + testGroup + "Bits" + [ testGroup + "AndBits" + [ testCase "On both concrete" $ do + pevalAndBitsTerm + (conTerm 3 :: Term (WordN 4)) + (conTerm 5) + @=? conTerm 1, + testCase "On zeroBits" $ do + pevalAndBitsTerm + (conTerm 0 :: Term (WordN 4)) + (ssymTerm "a") + @=? conTerm 0 + pevalAndBitsTerm + (ssymTerm "a") + (conTerm 0 :: Term (WordN 4)) + @=? conTerm 0, + testCase "On all one bits" $ do + pevalAndBitsTerm + (conTerm 15 :: Term (WordN 4)) + (ssymTerm "a") + @=? ssymTerm "a" + pevalAndBitsTerm + (ssymTerm "a") + (conTerm 15 :: Term (WordN 4)) + @=? ssymTerm "a", + testCase "On symbolic" $ do + pevalAndBitsTerm + (ssymTerm "a" :: Term (WordN 4)) + (ssymTerm "b") + @=? andBitsTerm + (ssymTerm "a" :: Term (WordN 4)) + (ssymTerm "b" :: Term (WordN 4)) + ], + testGroup + "OrBits" + [ testCase "On both concrete" $ do + pevalOrBitsTerm + (conTerm 3 :: Term (WordN 4)) + (conTerm 5) + @=? conTerm 7, + testCase "On zeroBits" $ do + pevalOrBitsTerm + (conTerm 0 :: Term (WordN 4)) + (ssymTerm "a") + @=? ssymTerm "a" + pevalOrBitsTerm + (ssymTerm "a") + (conTerm 0 :: Term (WordN 4)) + @=? ssymTerm "a", + testCase "On all one bits" $ do + pevalOrBitsTerm + (conTerm 15 :: Term (WordN 4)) + (ssymTerm "a") + @=? conTerm 15 + pevalOrBitsTerm + (ssymTerm "a") + (conTerm 15 :: Term (WordN 4)) + @=? conTerm 15, + testCase "On symbolic" $ do + pevalOrBitsTerm + (ssymTerm "a" :: Term (WordN 4)) + (ssymTerm "b") + @=? orBitsTerm + (ssymTerm "a" :: Term (WordN 4)) + (ssymTerm "b" :: Term (WordN 4)) + ], + testGroup + "XorBits" + [ testCase "On both concrete" $ do + pevalXorBitsTerm + (conTerm 3 :: Term (WordN 4)) + (conTerm 5) + @=? conTerm 6, + testCase "On zeroBits" $ do + pevalXorBitsTerm + (conTerm 0 :: Term (WordN 4)) + (ssymTerm "a") + @=? ssymTerm "a" + pevalXorBitsTerm + (ssymTerm "a") + (conTerm 0 :: Term (WordN 4)) + @=? ssymTerm "a", + testCase "On all one bits" $ do + pevalXorBitsTerm + (conTerm 15 :: Term (WordN 4)) + (ssymTerm "a") + @=? pevalComplementBitsTerm (ssymTerm "a") + pevalXorBitsTerm + (ssymTerm "a") + (conTerm 15 :: Term (WordN 4)) + @=? pevalComplementBitsTerm (ssymTerm "a"), + testCase "On single complement" $ do + pevalXorBitsTerm + (pevalComplementBitsTerm $ ssymTerm "a" :: Term (WordN 4)) + (ssymTerm "b") + @=? pevalComplementBitsTerm (pevalXorBitsTerm (ssymTerm "a") (ssymTerm "b")) + pevalXorBitsTerm + (ssymTerm "a" :: Term (WordN 4)) + (pevalComplementBitsTerm $ ssymTerm "b") + @=? pevalComplementBitsTerm (pevalXorBitsTerm (ssymTerm "a") (ssymTerm "b")), + testCase "On both complement" $ do + pevalXorBitsTerm + (pevalComplementBitsTerm $ ssymTerm "a" :: Term (WordN 4)) + (pevalComplementBitsTerm $ ssymTerm "b") + @=? pevalXorBitsTerm (ssymTerm "a") (ssymTerm "b"), + testCase "On symbolic" $ do + pevalXorBitsTerm + (ssymTerm "a" :: Term (WordN 4)) + (ssymTerm "b") + @=? xorBitsTerm + (ssymTerm "a" :: Term (WordN 4)) + (ssymTerm "b" :: Term (WordN 4)) + ], + testGroup + "ComplementBits" + [ testCase "On concrete" $ do + pevalComplementBitsTerm (conTerm 5 :: Term (WordN 4)) @=? conTerm 10, + testCase "On complement" $ do + pevalComplementBitsTerm (pevalComplementBitsTerm (ssymTerm "a") :: Term (WordN 4)) @=? ssymTerm "a", + testCase "On symbolic" $ do + pevalComplementBitsTerm (ssymTerm "a" :: Term (WordN 4)) + @=? complementBitsTerm (ssymTerm "a" :: Term (WordN 4)) + ], + testGroup + "ShiftLeft" + [ testCase "On concrete" $ do + pevalShiftLeftTerm (conTerm 15 :: Term (WordN 4)) (conTerm 2) @=? conTerm 12 + pevalShiftLeftTerm (conTerm 15 :: Term (IntN 4)) (conTerm 2) @=? conTerm 12, + testCase "shift 0" $ do + pevalShiftLeftTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 0) @=? ssymTerm "a" + pevalShiftLeftTerm (ssymTerm "a" :: Term (IntN 4)) (conTerm 0) @=? ssymTerm "a", + testCase "shift greater or equal to left bitsize" $ do + pevalShiftLeftTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 4) @=? conTerm 0 + pevalShiftLeftTerm (ssymTerm "a" :: Term (IntN 4)) (conTerm 4) @=? conTerm 0 + pevalShiftLeftTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 5) @=? conTerm 0 + pevalShiftLeftTerm (ssymTerm "a" :: Term (IntN 4)) (conTerm 5) @=? conTerm 0, + testCase "shift negative amount is undefined on for IntN" $ do + pevalShiftLeftTerm (conTerm 15 :: Term (IntN 4)) (conTerm $ -1) + @=? shiftLeftTerm (conTerm 15) (conTerm $ -1) + pevalShiftLeftTerm (conTerm 15 :: Term (IntN 4)) (conTerm $ -8) + @=? shiftLeftTerm (conTerm 15) (conTerm $ -8), + testCase "shift symbolic" $ do + pevalShiftLeftTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 2) + @=? shiftLeftTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 2), + testCase "Regression: shift by very large number" $ do + pevalShiftLeftTerm (conTerm 15 :: Term (IntN 128)) (conTerm maxBound) @=? conTerm 0 + pevalShiftLeftTerm (conTerm 15 :: Term (WordN 128)) (conTerm maxBound) @=? conTerm 0 + ], + testGroup + "ShiftRight" + [ testCase "On concrete, should perform arithmetic shifting on IntN" $ do + pevalShiftRightTerm (conTerm 7 :: Term (IntN 4)) (conTerm 2) @=? conTerm 1 + pevalShiftRightTerm (conTerm 15 :: Term (IntN 4)) (conTerm 2) @=? conTerm 15, + testCase "On concrete, should perform logical shifting on WordN" $ do + pevalShiftRightTerm (conTerm 7 :: Term (WordN 4)) (conTerm 2) @=? conTerm 1 + pevalShiftRightTerm (conTerm 15 :: Term (WordN 4)) (conTerm 2) @=? conTerm 3, + testCase "shift 0" $ do + pevalShiftRightTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 0) @=? ssymTerm "a" + pevalShiftRightTerm (ssymTerm "a" :: Term (IntN 4)) (conTerm 0) @=? ssymTerm "a", + testCase "shift greater or equal to left bitsize on WordN" $ do + pevalShiftRightTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 4) @=? conTerm 0 + pevalShiftRightTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 5) @=? conTerm 0, + testCase "shift greater or equal to left bitsize on IntN will not be reduced" $ do + pevalShiftRightTerm (ssymTerm "a" :: Term (IntN 4)) (conTerm 5) + @=? shiftRightTerm (ssymTerm "a") (conTerm 5) + pevalShiftRightTerm (ssymTerm "a" :: Term (IntN 4)) (conTerm 4) + @=? shiftRightTerm (ssymTerm "a") (conTerm 4), + testCase "shift negative amount is undefined on for IntN" $ do + pevalShiftRightTerm (conTerm 15 :: Term (IntN 4)) (conTerm $ -1) + @=? shiftRightTerm (conTerm 15) (conTerm $ -1) + pevalShiftRightTerm (conTerm 15 :: Term (IntN 4)) (conTerm $ -8) + @=? shiftRightTerm (conTerm 15) (conTerm $ -8), + testCase "shift symbolic" $ do + pevalShiftRightTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 2) + @=? shiftRightTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 2), + testCase "Regression: shift by very large number" $ do + pevalShiftRightTerm (conTerm 15 :: Term (IntN 128)) (conTerm maxBound) @=? conTerm 0 + pevalShiftRightTerm (conTerm 15 :: Term (WordN 128)) (conTerm maxBound) @=? conTerm 0 + ], + testGroup + "RotateLeft" + [ testCase "On concrete" $ do + pevalRotateLeftTerm (conTerm 0b10100101 :: Term (WordN 8)) (conTerm 2) @=? conTerm 0b10010110 + pevalRotateLeftTerm (conTerm 0b10100101 :: Term (IntN 8)) (conTerm 2) @=? conTerm 0b10010110, + testCase "rotate 0" $ do + pevalRotateLeftTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 0) @=? ssymTerm "a" + pevalRotateLeftTerm (ssymTerm "a" :: Term (IntN 4)) (conTerm 0) @=? ssymTerm "a", + testCase "rotate bitsize" $ do + pevalRotateLeftTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 4) + @=? ssymTerm "a" + pevalRotateLeftTerm (ssymTerm "a" :: Term (IntN 4)) (conTerm 4) + @=? ssymTerm "a", + testCase "rotate greater than left bitsize" $ do + pevalRotateLeftTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 5) + @=? rotateLeftTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 1) + pevalRotateLeftTerm (ssymTerm "a" :: Term (IntN 4)) (conTerm 5) + @=? rotateLeftTerm (ssymTerm "a" :: Term (IntN 4)) (conTerm 1), + testCase "rotate negative amount is undefined on for IntN" $ do + pevalRotateLeftTerm (conTerm 15 :: Term (IntN 4)) (conTerm $ -1) + @=? rotateLeftTerm (conTerm 15) (conTerm $ -1) + pevalRotateLeftTerm (conTerm 15 :: Term (IntN 4)) (conTerm $ -8) + @=? rotateLeftTerm (conTerm 15) (conTerm $ -8), + testCase "rotate symbolic" $ do + pevalRotateLeftTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 2) + @=? rotateLeftTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 2), + testCase "Regression: rotate by very large number" $ do + pevalRotateLeftTerm (conTerm 15 :: Term (IntN 128)) (conTerm maxBound) @=? conTerm (rotateR 15 1) + pevalRotateLeftTerm (conTerm 15 :: Term (WordN 128)) (conTerm maxBound) @=? conTerm (rotateR 15 1) + ], + testGroup + "RotateRight" + [ testProperty "On concrete WordN 1" $ + concreteSmallRotateRightCorrect @(WordN 1), + testProperty "On concrete WordN 2" $ + concreteSmallRotateRightCorrect @(WordN 2), + testProperty "On concrete WordN 3" $ + concreteSmallRotateRightCorrect @(WordN 3), + testProperty "On concrete WordN 4" $ + concreteSmallRotateRightCorrect @(WordN 4), + testProperty "On concrete WordN 8" $ + concreteSmallRotateRightCorrect @(WordN 8), + testProperty "On concrete IntN 1" $ + concreteSmallRotateRightCorrect @(IntN 1), + testProperty "On concrete IntN 2" $ + concreteSmallRotateRightCorrect @(IntN 2), + testProperty "On concrete IntN 3" $ + concreteSmallRotateRightCorrect @(IntN 3), + testProperty "On concrete IntN 4" $ + concreteSmallRotateRightCorrect @(IntN 4), + testProperty "On concrete IntN 8" $ + concreteSmallRotateRightCorrect @(IntN 8), + testCase "rotate 0" $ do + pevalRotateRightTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 0) @=? ssymTerm "a" + pevalRotateRightTerm (ssymTerm "a" :: Term (IntN 4)) (conTerm 0) @=? ssymTerm "a", + testCase "rotate bitsize" $ do + pevalRotateRightTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 4) + @=? ssymTerm "a" + pevalRotateRightTerm (ssymTerm "a" :: Term (IntN 4)) (conTerm 4) + @=? ssymTerm "a", + testCase "rotate greater than left bitsize" $ do + pevalRotateRightTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 5) + @=? rotateRightTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 1) + pevalRotateRightTerm (ssymTerm "a" :: Term (IntN 4)) (conTerm 5) + @=? rotateRightTerm (ssymTerm "a" :: Term (IntN 4)) (conTerm 1), + testCase "rotate negative amount is undefined on for IntN" $ do + pevalRotateRightTerm (conTerm 15 :: Term (IntN 4)) (conTerm $ -1) + @=? rotateRightTerm (conTerm 15) (conTerm $ -1) + pevalRotateRightTerm (conTerm 15 :: Term (IntN 4)) (conTerm $ -8) + @=? rotateRightTerm (conTerm 15) (conTerm $ -8), + testCase "rotate symbolic" $ do + pevalRotateRightTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 2) + @=? rotateRightTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 2), + testCase "Regression: rotate by very large number" $ do + pevalRotateRightTerm (conTerm 15 :: Term (IntN 128)) (conTerm maxBound) @=? conTerm (rotateL 15 1) + pevalRotateRightTerm (conTerm 15 :: Term (WordN 128)) (conTerm maxBound) @=? conTerm (rotateL 15 1) + ] + ] + +concreteSmallRotateRightCorrect :: + (PEvalRotateTerm a, Integral a, FiniteBits a, SymRotate a) => + a -> + a -> + Property +concreteSmallRotateRightCorrect _ b | b < 0 = discard +concreteSmallRotateRightCorrect a b = ioProperty $ do + pevalRotateRightTerm (conTerm a) (conTerm b) + @=? conTerm (rotateR a (fromIntegral b)) diff --git a/test/Grisette/SymPrim/Prim/BoolTests.hs b/test/Grisette/SymPrim/Prim/BoolTests.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/SymPrim/Prim/BoolTests.hs @@ -0,0 +1,734 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Grisette.SymPrim.Prim.BoolTests (boolTests) where + +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.Prim.Term + ( PEvalNumTerm (pevalAddNumTerm), + SupportedPrim (pevalITETerm), + Term, + andTerm, + conTerm, + eqTerm, + notTerm, + orTerm, + pevalAndTerm, + pevalEqTerm, + pevalImplyTerm, + pevalNEqTerm, + pevalNotTerm, + pevalOrTerm, + pevalXorTerm, + ssymTerm, + ) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@=?)) + +boolTests :: Test +boolTests = + testGroup + "Bool" + [ testGroup + "Not" + [ testCase "On concrete" $ do + pevalNotTerm (conTerm True) @=? conTerm False + pevalNotTerm (conTerm True) @=? conTerm False, + testCase "On general symbolic" $ do + pevalNotTerm (ssymTerm "a") @=? notTerm (ssymTerm "a" :: Term Bool), + testCase "On Not" $ do + pevalNotTerm (pevalNotTerm (ssymTerm "a")) @=? ssymTerm "a", + testCase "On Or Not" $ do + pevalNotTerm (pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")) + @=? pevalAndTerm (ssymTerm "a") (pevalNotTerm (ssymTerm "b")) + pevalNotTerm (pevalOrTerm (ssymTerm "a") (pevalNotTerm (ssymTerm "b"))) + @=? pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b"), + testCase "On And Not" $ do + pevalNotTerm (pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")) + @=? pevalOrTerm (ssymTerm "a") (pevalNotTerm (ssymTerm "b")) + pevalNotTerm (pevalAndTerm (ssymTerm "a") (pevalNotTerm (ssymTerm "b"))) + @=? pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b") + ], + testGroup + "Eqv & NEqv" + [ testCase "Eqv on both concrete" $ do + pevalEqTerm (conTerm True) (conTerm True) @=? conTerm True + pevalEqTerm (conTerm True) (conTerm False) @=? conTerm False + pevalEqTerm (conTerm False) (conTerm True) @=? conTerm False + pevalEqTerm (conTerm False) (conTerm False) @=? conTerm True + pevalEqTerm (conTerm (1 :: Integer)) (conTerm 1) @=? conTerm True + pevalEqTerm (conTerm (1 :: Integer)) (conTerm 2) @=? conTerm False + pevalEqTerm (conTerm (1 :: IntN 4)) (conTerm 1) @=? conTerm True + pevalEqTerm (conTerm (1 :: IntN 4)) (conTerm 2) @=? conTerm False + pevalEqTerm (conTerm (1 :: WordN 4)) (conTerm 1) @=? conTerm True + pevalEqTerm (conTerm (1 :: WordN 4)) (conTerm 2) @=? conTerm False, + testCase "Eqv on single concrete always put concrete ones in the right" $ do + pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1) + @=? eqTerm (ssymTerm "a" :: Term Integer) (conTerm 1 :: Term Integer) + pevalEqTerm (conTerm 1) (ssymTerm "a" :: Term Integer) + @=? eqTerm (ssymTerm "a" :: Term Integer) (conTerm 1 :: Term Integer), + testCase "Eqv on general symbolic" $ do + pevalEqTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b") + @=? eqTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b" :: Term Integer), + testCase "Eqv on Bool with single concrete" $ do + pevalEqTerm (conTerm True) (ssymTerm "a") @=? ssymTerm "a" + pevalEqTerm (ssymTerm "a") (conTerm True) @=? ssymTerm "a" + pevalEqTerm (conTerm False) (ssymTerm "a") @=? pevalNotTerm (ssymTerm "a") + pevalEqTerm (ssymTerm "a") (conTerm False) @=? pevalNotTerm (ssymTerm "a"), + testCase "NEqv on general symbolic" $ do + pevalNEqTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b") + @=? pevalNotTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b")), + testCase "Eqv(Not(x), x) / Eqv(x, Not(x))" $ do + pevalEqTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "a") @=? conTerm False + pevalEqTerm (ssymTerm "a") (pevalNotTerm (ssymTerm "a")) @=? conTerm False, + testCase "Eqv(n1+x, n2)" $ do + pevalEqTerm (pevalAddNumTerm (conTerm 1 :: Term Integer) (ssymTerm "a")) (conTerm 3) + @=? pevalEqTerm (ssymTerm "a") (conTerm 2 :: Term Integer) + pevalEqTerm (pevalAddNumTerm (conTerm 1 :: Term (IntN 4)) (ssymTerm "a")) (conTerm 3) + @=? pevalEqTerm (ssymTerm "a") (conTerm 2 :: Term (IntN 4)) + pevalEqTerm (pevalAddNumTerm (conTerm 1 :: Term (WordN 4)) (ssymTerm "a")) (conTerm 3) + @=? pevalEqTerm (ssymTerm "a") (conTerm 2 :: Term (WordN 4)), + testCase "Eqv(n1, n2+x)" $ do + pevalEqTerm (conTerm 3) (pevalAddNumTerm (conTerm 1 :: Term Integer) (ssymTerm "a")) + @=? pevalEqTerm (ssymTerm "a") (conTerm 2 :: Term Integer) + pevalEqTerm (conTerm 3) (pevalAddNumTerm (conTerm 1 :: Term (IntN 4)) (ssymTerm "a")) + @=? pevalEqTerm (ssymTerm "a") (conTerm 2 :: Term (IntN 4)) + pevalEqTerm (conTerm 3) (pevalAddNumTerm (conTerm 1 :: Term (WordN 4)) (ssymTerm "a")) + @=? pevalEqTerm (ssymTerm "a") (conTerm 2 :: Term (WordN 4)), + testCase "Eqv(l, ITE(c, l, f)) / Eqv(l, ITE(c, t, l) / Eqv(ITE(c, r, f), r) / Eqv(ITE(c, t, r), r)" $ do + pevalEqTerm (ssymTerm "a" :: Term Integer) (pevalITETerm (ssymTerm "b") (ssymTerm "a") (ssymTerm "c")) + @=? pevalOrTerm (ssymTerm "b") (pevalEqTerm (ssymTerm "a") (ssymTerm "c" :: Term Integer)) + pevalEqTerm (ssymTerm "a" :: Term Integer) (pevalITETerm (ssymTerm "b") (ssymTerm "c") (ssymTerm "a")) + @=? pevalOrTerm (pevalNotTerm $ ssymTerm "b") (pevalEqTerm (ssymTerm "a") (ssymTerm "c" :: Term Integer)) + pevalEqTerm (pevalITETerm (ssymTerm "b") (ssymTerm "a") (ssymTerm "c")) (ssymTerm "a" :: Term Integer) + @=? pevalOrTerm (ssymTerm "b") (pevalEqTerm (ssymTerm "c") (ssymTerm "a" :: Term Integer)) + pevalEqTerm (pevalITETerm (ssymTerm "b") (ssymTerm "c") (ssymTerm "a")) (ssymTerm "a" :: Term Integer) + @=? pevalOrTerm (pevalNotTerm $ ssymTerm "b") (pevalEqTerm (ssymTerm "c") (ssymTerm "a" :: Term Integer)) + ], + testGroup + "Or" + [ testCase "On both concrete" $ do + pevalOrTerm (conTerm True) (conTerm True) @=? conTerm True + pevalOrTerm (conTerm True) (conTerm False) @=? conTerm True + pevalOrTerm (conTerm False) (conTerm True) @=? conTerm True + pevalOrTerm (conTerm False) (conTerm False) @=? conTerm False, + testCase "On general symbolic" $ do + pevalOrTerm (ssymTerm "a") (ssymTerm "b") + @=? orTerm (ssymTerm "a" :: Term Bool) (ssymTerm "b" :: Term Bool), + testCase "Or(x, y) -> True" $ do + pevalOrTerm (conTerm True) (ssymTerm "b") @=? conTerm True + pevalOrTerm (ssymTerm "a") (conTerm True) @=? conTerm True + pevalOrTerm + (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) + @=? conTerm True + pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "a") @=? conTerm True + pevalOrTerm (ssymTerm "a") (pevalNotTerm (ssymTerm "a")) @=? conTerm True, + testCase "Or(x, y) -> x" $ do + pevalOrTerm (ssymTerm "a") (conTerm False) @=? ssymTerm "a" + pevalOrTerm + (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) + @=? pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1) + pevalOrTerm (ssymTerm "a") (ssymTerm "a") @=? ssymTerm "a", + testCase "Or(x, y) -> y" $ do + pevalOrTerm (conTerm False) (ssymTerm "a") @=? ssymTerm "a" + pevalOrTerm + (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) + (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + @=? pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1), + testCase "Or(x, Or(y1, y2)) -> True" $ do + pevalOrTerm (pevalNotTerm (ssymTerm "a")) (pevalOrTerm (ssymTerm "a") (ssymTerm "b")) @=? conTerm True + pevalOrTerm (ssymTerm "a") (pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")) @=? conTerm True + pevalOrTerm + (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalOrTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) + @=? conTerm True + + pevalOrTerm (pevalNotTerm (ssymTerm "a")) (pevalOrTerm (ssymTerm "b") (ssymTerm "a")) @=? conTerm True + pevalOrTerm (ssymTerm "a") (pevalOrTerm (ssymTerm "b") (pevalNotTerm (ssymTerm "a"))) @=? conTerm True + pevalOrTerm + (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalOrTerm (ssymTerm "b") (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) + @=? conTerm True, + testCase "Or(x, Or(y1, y2)) -> Or(x, y2)" $ do + pevalOrTerm + (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalOrTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) + @=? pevalOrTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"), + testCase "Or(x, Or(y1, y2)) -> Or(x, y1)" $ do + pevalOrTerm + (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalOrTerm (ssymTerm "b") (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) + @=? pevalOrTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"), + testCase "Or(x, y@Or(y1, y2)) -> y" $ do + pevalOrTerm (ssymTerm "a") (pevalOrTerm (ssymTerm "a") (ssymTerm "b")) + @=? pevalOrTerm (ssymTerm "a") (ssymTerm "b") + pevalOrTerm + (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) + (pevalOrTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b")) + @=? pevalOrTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b") + pevalOrTerm (ssymTerm "a") (pevalOrTerm (ssymTerm "b") (ssymTerm "a")) + @=? pevalOrTerm (ssymTerm "b") (ssymTerm "a") + pevalOrTerm + (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) + (pevalOrTerm (ssymTerm "b") (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1))) + @=? pevalOrTerm (ssymTerm "b") (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)), + testCase "Or(Or(x1, x2), y) -> True" $ do + pevalOrTerm (pevalOrTerm (ssymTerm "a") (ssymTerm "b")) (pevalNotTerm (ssymTerm "a")) @=? conTerm True + pevalOrTerm (pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")) (ssymTerm "a") @=? conTerm True + pevalOrTerm + (pevalOrTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) + (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + @=? conTerm True + + pevalOrTerm (pevalOrTerm (ssymTerm "b") (ssymTerm "a")) (pevalNotTerm (ssymTerm "a")) @=? conTerm True + pevalOrTerm (pevalOrTerm (ssymTerm "b") (pevalNotTerm (ssymTerm "a"))) (ssymTerm "a") @=? conTerm True + pevalOrTerm + (pevalOrTerm (ssymTerm "b") (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) + (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + @=? conTerm True, + testCase "Or(x@Or(x1, x2), y) -> x" $ do + pevalOrTerm (pevalOrTerm (ssymTerm "a") (ssymTerm "b")) (ssymTerm "a") + @=? pevalOrTerm (ssymTerm "a") (ssymTerm "b") + pevalOrTerm + (pevalOrTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b")) + (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) + @=? pevalOrTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b") + pevalOrTerm (pevalOrTerm (ssymTerm "b") (ssymTerm "a")) (ssymTerm "a") + @=? pevalOrTerm (ssymTerm "b") (ssymTerm "a") + pevalOrTerm + (pevalOrTerm (ssymTerm "b") (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1))) + (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) + @=? pevalOrTerm (ssymTerm "b") (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)), + testCase "Or(Or(x1, x2), y) -> Or(x2, y)" $ do + pevalOrTerm + (pevalOrTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) + (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + @=? pevalOrTerm (ssymTerm "b") (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)), + testCase "Or(Or(x1, x2), y) -> Or(x1, y)" $ do + pevalOrTerm + (pevalOrTerm (ssymTerm "b") (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) + (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + @=? pevalOrTerm (ssymTerm "b") (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)), + testCase "Or(x, And(y1, y2)) -> x" $ do + pevalOrTerm + (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalAndTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) + @=? pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1) + pevalOrTerm + (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalAndTerm (ssymTerm "b") (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) + @=? pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1), + testCase "Or(x, And(y1, y2)) -> Or(x, y2)" $ do + pevalOrTerm (ssymTerm "a") (pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")) + @=? pevalOrTerm (ssymTerm "a") (ssymTerm "b") + pevalOrTerm (pevalNotTerm (ssymTerm "a")) (pevalAndTerm (ssymTerm "a") (ssymTerm "b")) + @=? pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b") + pevalOrTerm + (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalAndTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) + @=? pevalOrTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"), + testCase "Or(And(x1, x2), y) -> y" $ do + pevalOrTerm + (pevalAndTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) + (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + @=? pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1) + pevalOrTerm + (pevalAndTerm (ssymTerm "b") (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) + (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + @=? pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1), + testCase "Or(x, And(y1, y2)) -> Or(x, y1)" $ do + pevalOrTerm (ssymTerm "a") (pevalAndTerm (ssymTerm "b") (pevalNotTerm (ssymTerm "a"))) + @=? pevalOrTerm (ssymTerm "a") (ssymTerm "b") + pevalOrTerm (pevalNotTerm (ssymTerm "a")) (pevalAndTerm (ssymTerm "b") (ssymTerm "a")) + @=? pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b") + pevalOrTerm + (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalAndTerm (ssymTerm "b") (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) + @=? pevalOrTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"), + testCase "Or(Not(x), Not(y)) -> Not(And(x, y))" $ do + pevalOrTerm (pevalNotTerm (ssymTerm "a")) (pevalNotTerm (ssymTerm "b")) + @=? pevalNotTerm (pevalAndTerm (ssymTerm "a") (ssymTerm "b")) + ], + testGroup + "And" + [ testCase "Oith both concrete" $ do + pevalAndTerm (conTerm True) (conTerm True) @=? conTerm True + pevalAndTerm (conTerm True) (conTerm False) @=? conTerm False + pevalAndTerm (conTerm False) (conTerm True) @=? conTerm False + pevalAndTerm (conTerm False) (conTerm False) @=? conTerm False, + testCase "On general symbolic" $ do + pevalAndTerm (ssymTerm "a") (ssymTerm "b") + @=? andTerm (ssymTerm "a" :: Term Bool) (ssymTerm "b" :: Term Bool), + testCase "And(x, y) -> False" $ do + pevalAndTerm (conTerm False) (ssymTerm "b") @=? conTerm False + pevalAndTerm (ssymTerm "a") (conTerm False) @=? conTerm False + pevalAndTerm + (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) + @=? conTerm False + pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "a") @=? conTerm False + pevalAndTerm (ssymTerm "a") (pevalNotTerm (ssymTerm "a")) @=? conTerm False, + testCase "And(x, y) -> x" $ do + pevalAndTerm (ssymTerm "a") (conTerm True) @=? ssymTerm "a" + pevalAndTerm + (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) + @=? pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1) + pevalAndTerm (ssymTerm "a") (ssymTerm "a") @=? ssymTerm "a", + testCase "And(x, y) -> y" $ do + pevalAndTerm (conTerm True) (ssymTerm "a") @=? ssymTerm "a" + pevalAndTerm + (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) + (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + @=? pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1), + testCase "And(x, And(y1, y2)) -> False" $ do + pevalAndTerm (pevalNotTerm (ssymTerm "a")) (pevalAndTerm (ssymTerm "a") (ssymTerm "b")) @=? conTerm False + pevalAndTerm (ssymTerm "a") (pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")) @=? conTerm False + pevalAndTerm + (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalAndTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) + @=? conTerm False + + pevalAndTerm (pevalNotTerm (ssymTerm "a")) (pevalAndTerm (ssymTerm "b") (ssymTerm "a")) @=? conTerm False + pevalAndTerm (ssymTerm "a") (pevalAndTerm (ssymTerm "b") (pevalNotTerm (ssymTerm "a"))) @=? conTerm False + pevalAndTerm + (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalAndTerm (ssymTerm "b") (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) + @=? conTerm False, + testCase "And(x, And(y1, y2)) -> And(x, y2)" $ do + pevalAndTerm + (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalAndTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) + @=? pevalAndTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"), + testCase "And(x, And(y1, y2)) -> And(x, y1)" $ do + pevalAndTerm + (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalAndTerm (ssymTerm "b") (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) + @=? pevalAndTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"), + testCase "And(x, y@And(y1, y2)) -> y" $ do + pevalAndTerm (ssymTerm "a") (pevalAndTerm (ssymTerm "a") (ssymTerm "b")) + @=? pevalAndTerm (ssymTerm "a") (ssymTerm "b") + pevalAndTerm + (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) + (pevalAndTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b")) + @=? pevalAndTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b") + pevalAndTerm (ssymTerm "a") (pevalAndTerm (ssymTerm "b") (ssymTerm "a")) + @=? pevalAndTerm (ssymTerm "b") (ssymTerm "a") + pevalAndTerm + (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) + (pevalAndTerm (ssymTerm "b") (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1))) + @=? pevalAndTerm (ssymTerm "b") (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)), + testCase "And(And(x1, x2), y) -> False" $ do + pevalAndTerm (pevalAndTerm (ssymTerm "a") (ssymTerm "b")) (pevalNotTerm (ssymTerm "a")) @=? conTerm False + pevalAndTerm (pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")) (ssymTerm "a") @=? conTerm False + pevalAndTerm + (pevalAndTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) + (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + @=? conTerm False + + pevalAndTerm (pevalAndTerm (ssymTerm "b") (ssymTerm "a")) (pevalNotTerm (ssymTerm "a")) @=? conTerm False + pevalAndTerm (pevalAndTerm (ssymTerm "b") (pevalNotTerm (ssymTerm "a"))) (ssymTerm "a") @=? conTerm False + pevalAndTerm + (pevalAndTerm (ssymTerm "b") (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) + (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + @=? conTerm False, + testCase "And(x@And(x1, x2), y) -> x" $ do + pevalAndTerm (pevalAndTerm (ssymTerm "a") (ssymTerm "b")) (ssymTerm "a") + @=? pevalAndTerm (ssymTerm "a") (ssymTerm "b") + pevalAndTerm + (pevalAndTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b")) + (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) + @=? pevalAndTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b") + pevalAndTerm (pevalAndTerm (ssymTerm "b") (ssymTerm "a")) (ssymTerm "a") + @=? pevalAndTerm (ssymTerm "b") (ssymTerm "a") + pevalAndTerm + (pevalAndTerm (ssymTerm "b") (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1))) + (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) + @=? pevalAndTerm (ssymTerm "b") (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)), + testCase "And(And(x1, x2), y) -> And(x2, y)" $ do + pevalAndTerm + (pevalAndTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) + (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + @=? pevalAndTerm (ssymTerm "b") (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)), + testCase "And(And(x1, x2), y) -> And(x1, y)" $ do + pevalAndTerm + (pevalAndTerm (ssymTerm "b") (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) + (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + @=? pevalAndTerm (ssymTerm "b") (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)), + testCase "And(x, Or(y1, y2)) -> x" $ do + pevalAndTerm + (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalOrTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) + @=? pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1) + pevalAndTerm + (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalOrTerm (ssymTerm "b") (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) + @=? pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1), + testCase "And(x, Or(y1, y2)) -> And(x, y2)" $ do + pevalAndTerm (ssymTerm "a") (pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")) + @=? pevalAndTerm (ssymTerm "a") (ssymTerm "b") + pevalAndTerm (pevalNotTerm (ssymTerm "a")) (pevalOrTerm (ssymTerm "a") (ssymTerm "b")) + @=? pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b") + pevalAndTerm + (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalOrTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) + @=? pevalAndTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"), + testCase "And(Or(x1, x2), y) -> y" $ do + pevalAndTerm + (pevalOrTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) + (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + @=? pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1) + pevalAndTerm + (pevalOrTerm (ssymTerm "b") (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) + (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + @=? pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1), + testCase "And(x, Or(y1, y2)) -> And(x, y1)" $ do + pevalAndTerm (ssymTerm "a") (pevalOrTerm (ssymTerm "b") (pevalNotTerm (ssymTerm "a"))) + @=? pevalAndTerm (ssymTerm "a") (ssymTerm "b") + pevalAndTerm (pevalNotTerm (ssymTerm "a")) (pevalOrTerm (ssymTerm "b") (ssymTerm "a")) + @=? pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b") + pevalAndTerm + (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalOrTerm (ssymTerm "b") (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) + @=? pevalAndTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"), + testCase "And(Not(x), Not(y)) -> Not(Or(x, y))" $ do + pevalAndTerm (pevalNotTerm (ssymTerm "a")) (pevalNotTerm (ssymTerm "b")) + @=? pevalNotTerm (pevalOrTerm (ssymTerm "a") (ssymTerm "b")) + ], + testGroup + "ITE" + [ testCase "On concrete condition" $ do + pevalITETerm (conTerm True) (ssymTerm "a" :: Term Integer) (ssymTerm "b") + @=? ssymTerm "a" + pevalITETerm (conTerm False) (ssymTerm "a" :: Term Integer) (ssymTerm "b") + @=? ssymTerm "b", + testCase "On same branches" $ do + pevalITETerm (ssymTerm "c") (ssymTerm "a" :: Term Integer) (ssymTerm "a") + @=? ssymTerm "a", + testCase "On both not" $ do + pevalITETerm (ssymTerm "c") (pevalNotTerm $ ssymTerm "a") (pevalNotTerm $ ssymTerm "b") + @=? pevalNotTerm (pevalITETerm (ssymTerm "c") (ssymTerm "a") (ssymTerm "b")), + testCase "On not in condition" $ do + pevalITETerm (pevalNotTerm $ ssymTerm "c") (ssymTerm "a" :: Term Integer) (ssymTerm "b") + @=? pevalITETerm (ssymTerm "c") (ssymTerm "b") (ssymTerm "a"), + testCase "On all arguments as ITE with same conditions" $ do + pevalITETerm + (pevalITETerm (ssymTerm "a") (ssymTerm "b") (ssymTerm "c")) + (pevalITETerm (ssymTerm "a") (ssymTerm "d" :: Term Integer) (ssymTerm "e")) + (pevalITETerm (ssymTerm "a") (ssymTerm "f" :: Term Integer) (ssymTerm "g")) + @=? pevalITETerm + (ssymTerm "a") + (pevalITETerm (ssymTerm "b") (ssymTerm "d") (ssymTerm "f")) + (pevalITETerm (ssymTerm "c") (ssymTerm "e") (ssymTerm "g")), + testCase "On with true branch as ITE" $ do + pevalITETerm + (ssymTerm "a") + (pevalITETerm (ssymTerm "a") (ssymTerm "b" :: Term Integer) (ssymTerm "c")) + (ssymTerm "d") + @=? pevalITETerm (ssymTerm "a") (ssymTerm "b") (ssymTerm "d") + pevalITETerm + (ssymTerm "a") + (pevalITETerm (ssymTerm "b") (ssymTerm "c" :: Term Integer) (ssymTerm "d")) + (ssymTerm "c") + @=? pevalITETerm + (pevalOrTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b")) + (ssymTerm "c") + (ssymTerm "d") + pevalITETerm + (ssymTerm "a") + (pevalITETerm (ssymTerm "b") (ssymTerm "c" :: Term Integer) (ssymTerm "d")) + (ssymTerm "d") + @=? pevalITETerm + (pevalAndTerm (ssymTerm "a") (ssymTerm "b")) + (ssymTerm "c") + (ssymTerm "d"), + testCase "On false branch as ITE" $ do + pevalITETerm + (ssymTerm "a") + (ssymTerm "b") + (pevalITETerm (ssymTerm "a") (ssymTerm "c" :: Term Integer) (ssymTerm "d")) + @=? pevalITETerm (ssymTerm "a") (ssymTerm "b") (ssymTerm "d") + pevalITETerm + (ssymTerm "a") + (ssymTerm "b") + (pevalITETerm (ssymTerm "c") (ssymTerm "b" :: Term Integer) (ssymTerm "d")) + @=? pevalITETerm + (pevalOrTerm (ssymTerm "a") (ssymTerm "c")) + (ssymTerm "b") + (ssymTerm "d") + pevalITETerm + (ssymTerm "a") + (ssymTerm "b") + (pevalITETerm (ssymTerm "c") (ssymTerm "d" :: Term Integer) (ssymTerm "b")) + @=? pevalITETerm + (pevalOrTerm (ssymTerm "a") (pevalNotTerm $ ssymTerm "c")) + (ssymTerm "b") + (ssymTerm "d"), + testCase "On both And" $ do + pevalITETerm + (ssymTerm "a") + (pevalAndTerm (ssymTerm "b") (ssymTerm "c")) + (pevalAndTerm (ssymTerm "b") (ssymTerm "d")) + @=? pevalAndTerm (ssymTerm "b") (pevalITETerm (ssymTerm "a") (ssymTerm "c") (ssymTerm "d")) + pevalITETerm + (ssymTerm "a") + (pevalAndTerm (ssymTerm "c") (ssymTerm "b")) + (pevalAndTerm (ssymTerm "b") (ssymTerm "d")) + @=? pevalAndTerm (ssymTerm "b") (pevalITETerm (ssymTerm "a") (ssymTerm "c") (ssymTerm "d")) + pevalITETerm + (ssymTerm "a") + (pevalAndTerm (ssymTerm "b") (ssymTerm "c")) + (pevalAndTerm (ssymTerm "d") (ssymTerm "b")) + @=? pevalAndTerm (ssymTerm "b") (pevalITETerm (ssymTerm "a") (ssymTerm "c") (ssymTerm "d")) + pevalITETerm + (ssymTerm "a") + (pevalAndTerm (ssymTerm "c") (ssymTerm "b")) + (pevalAndTerm (ssymTerm "d") (ssymTerm "b")) + @=? pevalAndTerm (ssymTerm "b") (pevalITETerm (ssymTerm "a") (ssymTerm "c") (ssymTerm "d")), + testCase "On left And" $ do + pevalITETerm + (ssymTerm "a") + (pevalAndTerm (ssymTerm "b") (ssymTerm "c")) + (ssymTerm "b") + @=? pevalAndTerm (ssymTerm "b") (pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "c")) + pevalITETerm + (ssymTerm "a") + (pevalAndTerm (ssymTerm "b") (ssymTerm "c")) + (ssymTerm "c") + @=? pevalAndTerm (ssymTerm "c") (pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")) + pevalITETerm + (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalAndTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) + (ssymTerm "c") + @=? pevalAndTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "c") + pevalITETerm + (ssymTerm "a") + (pevalAndTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b")) + (ssymTerm "c") + @=? pevalAndTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "c") + pevalITETerm + (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalAndTerm (ssymTerm "b") (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) + (ssymTerm "c") + @=? pevalAndTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "c") + pevalITETerm + (ssymTerm "a") + (pevalAndTerm (ssymTerm "b") (pevalNotTerm $ ssymTerm "a")) + (ssymTerm "c") + @=? pevalAndTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "c") + pevalITETerm + (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalAndTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) + (ssymTerm "c") + @=? pevalITETerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b") (ssymTerm "c") + pevalITETerm + (ssymTerm "a") + (pevalAndTerm (ssymTerm "a") (ssymTerm "b")) + (ssymTerm "c") + @=? pevalITETerm (ssymTerm "a") (ssymTerm "b") (ssymTerm "c") + pevalITETerm + (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalAndTerm (ssymTerm "b") (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) + (ssymTerm "c") + @=? pevalITETerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b") (ssymTerm "c") + pevalITETerm + (ssymTerm "a") + (pevalAndTerm (ssymTerm "b") (ssymTerm "a")) + (ssymTerm "c") + @=? pevalITETerm (ssymTerm "a") (ssymTerm "b") (ssymTerm "c"), + testCase "On right And" $ do + pevalITETerm + (ssymTerm "a") + (ssymTerm "b") + (pevalAndTerm (ssymTerm "b") (ssymTerm "c")) + @=? pevalAndTerm (ssymTerm "b") (pevalOrTerm (ssymTerm "a") (ssymTerm "c")) + pevalITETerm + (ssymTerm "a") + (ssymTerm "c") + (pevalAndTerm (ssymTerm "b") (ssymTerm "c")) + @=? pevalAndTerm (ssymTerm "c") (pevalOrTerm (ssymTerm "a") (ssymTerm "b")), + testCase "On both Or" $ do + pevalITETerm + (ssymTerm "a") + (pevalOrTerm (ssymTerm "b") (ssymTerm "c")) + (pevalOrTerm (ssymTerm "b") (ssymTerm "d")) + @=? pevalOrTerm (ssymTerm "b") (pevalITETerm (ssymTerm "a") (ssymTerm "c") (ssymTerm "d")) + pevalITETerm + (ssymTerm "a") + (pevalOrTerm (ssymTerm "c") (ssymTerm "b")) + (pevalOrTerm (ssymTerm "b") (ssymTerm "d")) + @=? pevalOrTerm (ssymTerm "b") (pevalITETerm (ssymTerm "a") (ssymTerm "c") (ssymTerm "d")) + pevalITETerm + (ssymTerm "a") + (pevalOrTerm (ssymTerm "b") (ssymTerm "c")) + (pevalOrTerm (ssymTerm "d") (ssymTerm "b")) + @=? pevalOrTerm (ssymTerm "b") (pevalITETerm (ssymTerm "a") (ssymTerm "c") (ssymTerm "d")) + pevalITETerm + (ssymTerm "a") + (pevalOrTerm (ssymTerm "c") (ssymTerm "b")) + (pevalOrTerm (ssymTerm "d") (ssymTerm "b")) + @=? pevalOrTerm (ssymTerm "b") (pevalITETerm (ssymTerm "a") (ssymTerm "c") (ssymTerm "d")), + testCase "On left Or" $ do + pevalITETerm + (ssymTerm "a") + (pevalOrTerm (ssymTerm "b") (ssymTerm "c")) + (ssymTerm "b") + @=? pevalOrTerm (ssymTerm "b") (pevalAndTerm (ssymTerm "a") (ssymTerm "c")) + pevalITETerm + (ssymTerm "a") + (pevalOrTerm (ssymTerm "b") (ssymTerm "c")) + (ssymTerm "c") + @=? pevalOrTerm (ssymTerm "c") (pevalAndTerm (ssymTerm "a") (ssymTerm "b")) + pevalITETerm + (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalOrTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) + (ssymTerm "c") + @=? pevalITETerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b") (ssymTerm "c") + pevalITETerm + (ssymTerm "a") + (pevalOrTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b")) + (ssymTerm "c") + @=? pevalITETerm (ssymTerm "a") (ssymTerm "b") (ssymTerm "c") + pevalITETerm + (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalOrTerm (ssymTerm "b") (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) + (ssymTerm "c") + @=? pevalITETerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b") (ssymTerm "c") + pevalITETerm + (ssymTerm "a") + (pevalOrTerm (ssymTerm "b") (pevalNotTerm $ ssymTerm "a")) + (ssymTerm "c") + @=? pevalITETerm (ssymTerm "a") (ssymTerm "b") (ssymTerm "c") + pevalITETerm + (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalOrTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) + (ssymTerm "c") + @=? pevalOrTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "c") + pevalITETerm + (ssymTerm "a") + (pevalOrTerm (ssymTerm "a") (ssymTerm "b")) + (ssymTerm "c") + @=? pevalOrTerm (ssymTerm "a") (ssymTerm "c") + pevalITETerm + (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalOrTerm (ssymTerm "b") (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) + (ssymTerm "c") + @=? pevalOrTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "c") + pevalITETerm + (ssymTerm "a") + (pevalOrTerm (ssymTerm "b") (ssymTerm "a")) + (ssymTerm "c") + @=? pevalOrTerm (ssymTerm "a") (ssymTerm "c"), + testCase "On right Or" $ do + pevalITETerm + (ssymTerm "a") + (ssymTerm "b") + (pevalOrTerm (ssymTerm "b") (ssymTerm "c")) + @=? pevalOrTerm (ssymTerm "b") (pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "c")) + pevalITETerm + (ssymTerm "a") + (ssymTerm "c") + (pevalOrTerm (ssymTerm "b") (ssymTerm "c")) + @=? pevalOrTerm (ssymTerm "c") (pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")), + testCase "On const boolean in branches" $ do + pevalITETerm + (ssymTerm "a") + (conTerm True) + (ssymTerm "b") + @=? pevalOrTerm (ssymTerm "a") (ssymTerm "b") + pevalITETerm + (ssymTerm "a") + (conTerm False) + (ssymTerm "b") + @=? pevalAndTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b") + pevalITETerm + (ssymTerm "a") + (ssymTerm "b") + (conTerm True) + @=? pevalOrTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b") + pevalITETerm + (ssymTerm "a") + (ssymTerm "b") + (conTerm False) + @=? pevalAndTerm (ssymTerm "a") (ssymTerm "b"), + testCase "On condition equal to some branch" $ do + pevalITETerm + (ssymTerm "a") + (ssymTerm "a") + (ssymTerm "b") + @=? pevalOrTerm (ssymTerm "a") (ssymTerm "b") + pevalITETerm + (ssymTerm "a") + (ssymTerm "b") + (ssymTerm "a") + @=? pevalAndTerm (ssymTerm "a") (ssymTerm "b"), + testCase "On left Not" $ do + pevalITETerm (ssymTerm "a") (pevalNotTerm (ssymTerm "a")) (ssymTerm "b") + @=? pevalAndTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b"), + testCase "On right Not" $ do + pevalITETerm (ssymTerm "a") (ssymTerm "b") (pevalNotTerm (ssymTerm "a")) + @=? pevalOrTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b"), + testCase "On left Not And" $ do + pevalITETerm + (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalNotTerm (pevalAndTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b"))) + (ssymTerm "c") + @=? pevalOrTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "c") + pevalITETerm + (ssymTerm "a") + (pevalNotTerm (pevalAndTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b"))) + (ssymTerm "c") + @=? pevalOrTerm (ssymTerm "a") (ssymTerm "c") + pevalITETerm + (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalNotTerm (pevalAndTerm (ssymTerm "b") (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)))) + (ssymTerm "c") + @=? pevalOrTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "c") + pevalITETerm + (ssymTerm "a") + (pevalNotTerm (pevalAndTerm (ssymTerm "b") (pevalNotTerm $ ssymTerm "a"))) + (ssymTerm "c") + @=? pevalOrTerm (ssymTerm "a") (ssymTerm "c") + pevalITETerm + (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalNotTerm (pevalAndTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b"))) + (ssymTerm "c") + @=? pevalITETerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (pevalNotTerm $ ssymTerm "b") (ssymTerm "c") + pevalITETerm + (ssymTerm "a") + (pevalNotTerm (pevalAndTerm (ssymTerm "a") (ssymTerm "b"))) + (ssymTerm "c") + @=? pevalITETerm (ssymTerm "a") (pevalNotTerm $ ssymTerm "b") (ssymTerm "c") + pevalITETerm + (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) + (pevalNotTerm (pevalAndTerm (ssymTerm "b") (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)))) + (ssymTerm "c") + @=? pevalITETerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (pevalNotTerm $ ssymTerm "b") (ssymTerm "c") + pevalITETerm + (ssymTerm "a") + (pevalNotTerm (pevalAndTerm (ssymTerm "b") (ssymTerm "a"))) + (ssymTerm "c") + @=? pevalITETerm (ssymTerm "a") (pevalNotTerm $ ssymTerm "b") (ssymTerm "c") + ], + testGroup + "Imply" + [ testCase "pevalImplyTerm" $ do + ssymTerm "a" + `pevalImplyTerm` ssymTerm "b" + @=? pevalOrTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b") + ], + testGroup + "Xor" + [ testCase "pevalXorTerm" $ do + ssymTerm "a" + `pevalXorTerm` ssymTerm "b" + @=? pevalOrTerm + (pevalAndTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b")) + (pevalAndTerm (ssymTerm "a") (pevalNotTerm $ ssymTerm "b")) + ] + ] diff --git a/test/Grisette/SymPrim/Prim/IntegralTests.hs b/test/Grisette/SymPrim/Prim/IntegralTests.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/SymPrim/Prim/IntegralTests.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Grisette.SymPrim.Prim.IntegralTests (integralTests) where + +import Control.DeepSeq (NFData (rnf), force) +import Control.Exception (ArithException, catch, evaluate) +import Data.Proxy (Proxy (Proxy)) +import Grisette.Internal.SymPrim.BV (IntN (IntN), WordN (WordN)) +import Grisette.Internal.SymPrim.Prim.Term + ( PEvalDivModIntegralTerm + ( pevalDivIntegralTerm, + pevalModIntegralTerm, + pevalQuotIntegralTerm, + pevalRemIntegralTerm + ), + Term, + conTerm, + divIntegralTerm, + modIntegralTerm, + quotIntegralTerm, + remIntegralTerm, + ssymTerm, + ) +import Test.Framework (Test, TestName, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.HUnit ((@=?)) +import Test.QuickCheck (Arbitrary, ioProperty) + +newtype AEWrapper = AEWrapper ArithException deriving (Eq) + +instance Show AEWrapper where + show (AEWrapper x) = show x + +instance NFData AEWrapper where + rnf (AEWrapper x) = x `seq` () + +sameDivPeval :: + forall t. + (Num t, Eq t, PEvalDivModIntegralTerm t) => + t -> + t -> + (Term t -> Term t -> Term t) -> + (t -> t -> t) -> + (Term t -> Term t -> Term t) -> + IO () +sameDivPeval i j pf cf consf = do + cx <- evaluate (force $ Right $ cf i j) `catch` \(_ :: ArithException) -> return $ Left AEWrapper + case cx of + Left _ -> pf (conTerm i) (conTerm j) @=? consf (conTerm i) (conTerm j) + Right t -> pf (conTerm i) (conTerm j) @=? conTerm t + +divisionPevalBoundedTests :: + forall p t. + (Num t, Eq t, Bounded t, PEvalDivModIntegralTerm t) => + p t -> + TestName -> + (Term t -> Term t -> Term t) -> + (t -> t -> t) -> + (Term t -> Term t -> Term t) -> + Test +divisionPevalBoundedTests _ name pf cf consf = + testGroup + name + [ testCase "On concrete min divide by -1" $ + sameDivPeval minBound (-1) pf cf consf + ] + +divisionPevalTests :: + forall p t0 t. + (Num t, Eq t, Arbitrary t0, Show t0, PEvalDivModIntegralTerm t) => + p t -> + TestName -> + (t0 -> t) -> + (Term t -> Term t -> Term t) -> + (t -> t -> t) -> + (Term t -> Term t -> Term t) -> + Test +divisionPevalTests _ name transform pf cf consf = + testGroup + name + [ testProperty "On concrete prop" $ + ioProperty . \(i0 :: t0, j0 :: t0) -> do + let i = transform i0 + let j = transform j0 + sameDivPeval i j pf cf consf, + testProperty "On concrete divide by 0" $ + ioProperty . \(i0 :: t0) -> do + let i = transform i0 + sameDivPeval i 0 pf cf consf, + testCase "divide by 1" $ do + pf (ssymTerm "a" :: Term t) (conTerm 1) @=? ssymTerm "a", + testCase "On symbolic" $ do + pf (ssymTerm "a" :: Term t) (ssymTerm "b") + @=? consf (ssymTerm "a" :: Term t) (ssymTerm "b" :: Term t) + ] + +divisionPevalBoundedTestGroup :: + TestName -> + (forall t. (PEvalDivModIntegralTerm t) => Term t -> Term t -> Term t) -> + (forall t. (Bounded t, Integral t) => t -> t -> t) -> + (forall t. (PEvalDivModIntegralTerm t) => Term t -> Term t -> Term t) -> + Test +divisionPevalBoundedTestGroup name pf cf consf = + testGroup + name + [ divisionPevalTests (Proxy @(IntN 4)) "IntN" IntN pf cf consf, + divisionPevalBoundedTests (Proxy @(IntN 4)) "IntN Bounded" pf cf consf + ] + +divisionPevalUnboundedTestGroup :: + TestName -> + (forall t. (PEvalDivModIntegralTerm t) => Term t -> Term t -> Term t) -> + (forall t. (Integral t) => t -> t -> t) -> + (forall t. (PEvalDivModIntegralTerm t) => Term t -> Term t -> Term t) -> + Test +divisionPevalUnboundedTestGroup name pf cf consf = + testGroup + name + [ divisionPevalTests (Proxy @Integer) "Integer" id pf cf consf, + divisionPevalTests (Proxy @(WordN 4)) "WordN" WordN pf cf consf, + divisionPevalBoundedTests (Proxy @(WordN 4)) "WordN Bounded" pf cf consf + ] + +moduloPevalTests :: + forall p t0 t. + (Num t, Eq t, Arbitrary t0, Show t0, PEvalDivModIntegralTerm t) => + p t -> + TestName -> + (t0 -> t) -> + (Term t -> Term t -> Term t) -> + (t -> t -> t) -> + (Term t -> Term t -> Term t) -> + Test +moduloPevalTests _ name transform pf cf consf = + testGroup + name + [ testProperty "On concrete" $ + ioProperty . \(i0 :: t0, j0 :: t0) -> do + let i = transform i0 + let j = transform j0 + sameDivPeval i j pf cf consf, + testProperty "On concrete divide by 0" $ + ioProperty . \(i0 :: t0) -> do + let i = transform i0 + sameDivPeval i 0 pf cf consf, + testCase "mod by 1" $ do + pf (ssymTerm "a" :: Term t) (conTerm 1) @=? conTerm 0, + testCase "mod by -1" $ do + pf (ssymTerm "a" :: Term t) (conTerm $ -1) @=? conTerm 0, + testCase "On symbolic" $ do + pf (ssymTerm "a" :: Term t) (ssymTerm "b") + @=? consf (ssymTerm "a" :: Term t) (ssymTerm "b" :: Term t) + ] + +moduloPevalTestGroup :: + TestName -> + (forall t. (PEvalDivModIntegralTerm t) => Term t -> Term t -> Term t) -> + (forall t. (Integral t) => t -> t -> t) -> + (forall t. (PEvalDivModIntegralTerm t) => Term t -> Term t -> Term t) -> + Test +moduloPevalTestGroup name pf cf consf = + testGroup + name + [ moduloPevalTests (Proxy @Integer) "Integer" id pf cf consf, + moduloPevalTests (Proxy @(IntN 4)) "IntN" IntN pf cf consf, + moduloPevalTests (Proxy @(WordN 4)) "WordN" WordN pf cf consf + ] + +integralTests :: Test +integralTests = + testGroup + "Integral" + [ divisionPevalUnboundedTestGroup "Div unbounded" pevalDivIntegralTerm div divIntegralTerm, + divisionPevalUnboundedTestGroup "Quot unbounded" pevalQuotIntegralTerm quot quotIntegralTerm, + divisionPevalBoundedTestGroup "Div bounded" pevalDivIntegralTerm div divIntegralTerm, + divisionPevalBoundedTestGroup "Quot bounded" pevalQuotIntegralTerm quot quotIntegralTerm, + moduloPevalTestGroup "Mod" pevalModIntegralTerm mod modIntegralTerm, + moduloPevalTestGroup "Rem" pevalRemIntegralTerm rem remIntegralTerm + ] diff --git a/test/Grisette/SymPrim/Prim/ModelTests.hs b/test/Grisette/SymPrim/Prim/ModelTests.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/SymPrim/Prim/ModelTests.hs @@ -0,0 +1,276 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Grisette.SymPrim.Prim.ModelTests (modelTests) where + +import qualified Data.HashMap.Strict as M +import qualified Data.HashSet as S +import Grisette + ( IntN, + ModelOps + ( emptyModel, + exact, + exceptFor, + extendTo, + insertValue, + restrictTo, + valueOf + ), + ModelRep (buildModel), + TypedSymbol, + WordN, + ) +import Grisette.Internal.SymPrim.Prim.Model + ( Model (Model), + ModelValuePair ((::=)), + SymbolSet (SymbolSet), + equation, + evaluateTerm, + ) +import Grisette.Internal.SymPrim.Prim.ModelValue (toModelValue) +import Grisette.Internal.SymPrim.Prim.Term + ( PEvalNumTerm (pevalAddNumTerm, pevalNegNumTerm), + SupportedPrim (pevalITETerm), + Term, + conTerm, + pevalEqTerm, + someTypedSymbol, + ssymTerm, + ) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@=?)) + +modelTests :: Test +modelTests = + let asymbol :: TypedSymbol Integer = "a" + bsymbol :: TypedSymbol Bool = "b" + csymbol :: TypedSymbol Integer = "c" + dsymbol :: TypedSymbol Bool = "d" + esymbol :: TypedSymbol (WordN 4) = "e" + fsymbol :: TypedSymbol (IntN 4) = "f" + gsymbol :: TypedSymbol (WordN 16) = "g" + hsymbol :: TypedSymbol (IntN 16) = "h" + m1 = emptyModel + m2 = insertValue asymbol 1 m1 + m3 = insertValue bsymbol True m2 + in testGroup + "Model" + [ testCase "empty model is really empty" $ do + emptyModel @=? Model M.empty, + testCase "inserting to model" $ do + m3 + @=? Model + ( M.fromList + [ (someTypedSymbol asymbol, toModelValue (1 :: Integer)), + (someTypedSymbol bsymbol, toModelValue True) + ] + ), + testCase "equation" $ do + equation asymbol m3 @=? Just (pevalEqTerm (ssymTerm "a") (conTerm 1 :: Term Integer)) + equation bsymbol m3 @=? Just (pevalEqTerm (ssymTerm "b") (conTerm True)) + equation csymbol m3 @=? Nothing, + testCase "valueOf" $ do + valueOf asymbol m3 @=? Just (1 :: Integer) + valueOf bsymbol m3 @=? Just True + valueOf csymbol m3 @=? (Nothing :: Maybe Integer), + testCase "exceptFor" $ do + exceptFor (SymbolSet $ S.fromList [someTypedSymbol asymbol]) m3 + @=? Model + ( M.fromList + [ (someTypedSymbol bsymbol, toModelValue True) + ] + ), + testCase "restrictTo" $ do + restrictTo (SymbolSet $ S.fromList [someTypedSymbol asymbol]) m3 + @=? Model + ( M.fromList + [ (someTypedSymbol asymbol, toModelValue (1 :: Integer)) + ] + ), + testCase "extendTo" $ do + extendTo + ( SymbolSet $ + S.fromList + [ someTypedSymbol csymbol, + someTypedSymbol dsymbol, + someTypedSymbol esymbol, + someTypedSymbol fsymbol + ] + ) + m3 + @=? Model + ( M.fromList + [ (someTypedSymbol asymbol, toModelValue (1 :: Integer)), + (someTypedSymbol bsymbol, toModelValue True), + (someTypedSymbol csymbol, toModelValue (0 :: Integer)), + (someTypedSymbol dsymbol, toModelValue False), + (someTypedSymbol esymbol, toModelValue (0 :: WordN 4)), + (someTypedSymbol fsymbol, toModelValue (0 :: IntN 4)) + ] + ), + testCase "exact" $ do + exact + ( SymbolSet $ + S.fromList + [ someTypedSymbol asymbol, + someTypedSymbol csymbol + ] + ) + m3 + @=? Model + ( M.fromList + [ (someTypedSymbol asymbol, toModelValue (1 :: Integer)), + (someTypedSymbol csymbol, toModelValue (0 :: Integer)) + ] + ), + testCase "evaluateTerm" $ do + evaluateTerm False m3 (conTerm (1 :: Integer)) @=? conTerm 1 + evaluateTerm True m3 (conTerm (1 :: Integer)) @=? conTerm 1 + evaluateTerm False m3 (ssymTerm "a" :: Term Integer) @=? conTerm 1 + evaluateTerm True m3 (ssymTerm "a" :: Term Integer) @=? conTerm 1 + evaluateTerm False m3 (ssymTerm "x" :: Term Integer) @=? ssymTerm "x" + evaluateTerm True m3 (ssymTerm "x" :: Term Integer) @=? conTerm 0 + evaluateTerm False m3 (ssymTerm "y" :: Term Bool) @=? ssymTerm "y" + evaluateTerm True m3 (ssymTerm "y" :: Term Bool) @=? conTerm False + evaluateTerm False m3 (ssymTerm "z" :: Term (WordN 4)) @=? ssymTerm "z" + evaluateTerm True m3 (ssymTerm "z" :: Term (WordN 4)) @=? conTerm 0 + evaluateTerm False m3 (pevalNegNumTerm $ ssymTerm "a" :: Term Integer) @=? conTerm (-1) + evaluateTerm True m3 (pevalNegNumTerm $ ssymTerm "a" :: Term Integer) @=? conTerm (-1) + evaluateTerm False m3 (pevalNegNumTerm $ ssymTerm "x" :: Term Integer) @=? pevalNegNumTerm (ssymTerm "x") + evaluateTerm True m3 (pevalNegNumTerm $ ssymTerm "x" :: Term Integer) @=? conTerm 0 + evaluateTerm False m3 (pevalAddNumTerm (ssymTerm "a") (ssymTerm "a") :: Term Integer) @=? conTerm 2 + evaluateTerm True m3 (pevalAddNumTerm (ssymTerm "a") (ssymTerm "a") :: Term Integer) @=? conTerm 2 + evaluateTerm False m3 (pevalAddNumTerm (ssymTerm "x") (ssymTerm "a") :: Term Integer) @=? pevalAddNumTerm (conTerm 1) (ssymTerm "x") + evaluateTerm True m3 (pevalAddNumTerm (ssymTerm "x") (ssymTerm "a") :: Term Integer) @=? conTerm 1 + evaluateTerm False m3 (pevalAddNumTerm (ssymTerm "x") (ssymTerm "y") :: Term Integer) @=? pevalAddNumTerm (ssymTerm "x") (ssymTerm "y") + evaluateTerm True m3 (pevalAddNumTerm (ssymTerm "x") (ssymTerm "y") :: Term Integer) @=? conTerm 0 + evaluateTerm False m3 (pevalITETerm (ssymTerm "b") (pevalAddNumTerm (ssymTerm "a") (ssymTerm "a")) (ssymTerm "a") :: Term Integer) + @=? conTerm 2 + evaluateTerm True m3 (pevalITETerm (ssymTerm "b") (pevalAddNumTerm (ssymTerm "a") (ssymTerm "a")) (ssymTerm "a") :: Term Integer) + @=? conTerm 2 + evaluateTerm False m3 (pevalITETerm (ssymTerm "x") (pevalAddNumTerm (ssymTerm "a") (ssymTerm "a")) (ssymTerm "a") :: Term Integer) + @=? pevalITETerm (ssymTerm "x") (conTerm 2) (conTerm 1) + evaluateTerm True m3 (pevalITETerm (ssymTerm "x") (pevalAddNumTerm (ssymTerm "a") (ssymTerm "a")) (ssymTerm "a") :: Term Integer) + @=? conTerm 1 + evaluateTerm False m3 (pevalITETerm (ssymTerm "b") (ssymTerm "x") (pevalAddNumTerm (conTerm 1) (ssymTerm "y")) :: Term Integer) + @=? ssymTerm "x" + evaluateTerm True m3 (pevalITETerm (ssymTerm "b") (ssymTerm "x") (pevalAddNumTerm (conTerm 1) (ssymTerm "y")) :: Term Integer) + @=? conTerm 0 + evaluateTerm False m3 (pevalITETerm (ssymTerm "z") (ssymTerm "x") (pevalAddNumTerm (conTerm 1) (ssymTerm "y")) :: Term Integer) + @=? pevalITETerm (ssymTerm "z") (ssymTerm "x") (pevalAddNumTerm (conTerm 1) (ssymTerm "y")) + evaluateTerm True m3 (pevalITETerm (ssymTerm "z") (ssymTerm "x") (pevalAddNumTerm (conTerm 1) (ssymTerm "y")) :: Term Integer) + @=? conTerm 1, + testCase "construction from ModelValuePair" $ do + buildModel (asymbol ::= 1) @=? Model (M.singleton (someTypedSymbol asymbol) (toModelValue (1 :: Integer))) + buildModel (asymbol ::= 1, bsymbol ::= True) + @=? Model + ( M.fromList + [ (someTypedSymbol asymbol, toModelValue (1 :: Integer)), + (someTypedSymbol bsymbol, toModelValue True) + ] + ) + buildModel + ( asymbol ::= 1, + bsymbol ::= True, + csymbol ::= 2 + ) + @=? Model + ( M.fromList + [ (someTypedSymbol asymbol, toModelValue (1 :: Integer)), + (someTypedSymbol bsymbol, toModelValue True), + (someTypedSymbol csymbol, toModelValue (2 :: Integer)) + ] + ) + buildModel + ( asymbol ::= 1, + bsymbol ::= True, + csymbol ::= 2, + dsymbol ::= False + ) + @=? Model + ( M.fromList + [ (someTypedSymbol asymbol, toModelValue (1 :: Integer)), + (someTypedSymbol bsymbol, toModelValue True), + (someTypedSymbol csymbol, toModelValue (2 :: Integer)), + (someTypedSymbol dsymbol, toModelValue False) + ] + ) + buildModel + ( asymbol ::= 1, + bsymbol ::= True, + csymbol ::= 2, + dsymbol ::= False, + esymbol ::= 3 + ) + @=? Model + ( M.fromList + [ (someTypedSymbol asymbol, toModelValue (1 :: Integer)), + (someTypedSymbol bsymbol, toModelValue True), + (someTypedSymbol csymbol, toModelValue (2 :: Integer)), + (someTypedSymbol dsymbol, toModelValue False), + (someTypedSymbol esymbol, toModelValue (3 :: WordN 4)) + ] + ) + buildModel + ( asymbol ::= 1, + bsymbol ::= True, + csymbol ::= 2, + dsymbol ::= False, + esymbol ::= 3, + fsymbol ::= 4 + ) + @=? Model + ( M.fromList + [ (someTypedSymbol asymbol, toModelValue (1 :: Integer)), + (someTypedSymbol bsymbol, toModelValue True), + (someTypedSymbol csymbol, toModelValue (2 :: Integer)), + (someTypedSymbol dsymbol, toModelValue False), + (someTypedSymbol esymbol, toModelValue (3 :: WordN 4)), + (someTypedSymbol fsymbol, toModelValue (4 :: IntN 4)) + ] + ) + buildModel + ( asymbol ::= 1, + bsymbol ::= True, + csymbol ::= 2, + dsymbol ::= False, + esymbol ::= 3, + fsymbol ::= 4, + gsymbol ::= 5 + ) + @=? Model + ( M.fromList + [ (someTypedSymbol asymbol, toModelValue (1 :: Integer)), + (someTypedSymbol bsymbol, toModelValue True), + (someTypedSymbol csymbol, toModelValue (2 :: Integer)), + (someTypedSymbol dsymbol, toModelValue False), + (someTypedSymbol esymbol, toModelValue (3 :: WordN 4)), + (someTypedSymbol fsymbol, toModelValue (4 :: IntN 4)), + (someTypedSymbol gsymbol, toModelValue (5 :: WordN 16)) + ] + ) + buildModel + ( asymbol ::= 1, + bsymbol ::= True, + csymbol ::= 2, + dsymbol ::= False, + esymbol ::= 3, + fsymbol ::= 4, + gsymbol ::= 5, + hsymbol ::= 6 + ) + @=? Model + ( M.fromList + [ (someTypedSymbol asymbol, toModelValue (1 :: Integer)), + (someTypedSymbol bsymbol, toModelValue True), + (someTypedSymbol csymbol, toModelValue (2 :: Integer)), + (someTypedSymbol dsymbol, toModelValue False), + (someTypedSymbol esymbol, toModelValue (3 :: WordN 4)), + (someTypedSymbol fsymbol, toModelValue (4 :: IntN 4)), + (someTypedSymbol gsymbol, toModelValue (5 :: WordN 16)), + (someTypedSymbol hsymbol, toModelValue (6 :: IntN 16)) + ] + ) + ] diff --git a/test/Grisette/SymPrim/Prim/NumTests.hs b/test/Grisette/SymPrim/Prim/NumTests.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/SymPrim/Prim/NumTests.hs @@ -0,0 +1,405 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Grisette.SymPrim.Prim.NumTests (numTests) where + +import Grisette (IntN, WordN) +import Grisette.Internal.SymPrim.Prim.Term + ( PEvalNumTerm + ( pevalAbsNumTerm, + pevalAddNumTerm, + pevalMulNumTerm, + pevalNegNumTerm, + pevalSignumNumTerm + ), + PEvalOrdTerm (pevalLeOrdTerm, pevalLtOrdTerm), + SupportedPrim (pevalITETerm), + Term, + absNumTerm, + addNumTerm, + conTerm, + leOrdTerm, + ltOrdTerm, + mulNumTerm, + negNumTerm, + pevalGeOrdTerm, + pevalGtOrdTerm, + pevalSubNumTerm, + signumNumTerm, + ssymTerm, + ) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@=?)) + +numTests :: Test +numTests = + testGroup + "Num" + [ testGroup + "Add" + [ testCase "On concrete" $ do + pevalAddNumTerm (conTerm 1 :: Term Integer) (conTerm 2) @=? conTerm 3 + pevalAddNumTerm (conTerm 1 :: Term (WordN 3)) (conTerm 2) @=? conTerm 3 + pevalAddNumTerm (conTerm 1 :: Term (IntN 3)) (conTerm 2) @=? conTerm 3, + testCase "On left 0" $ do + pevalAddNumTerm (conTerm 0 :: Term Integer) (ssymTerm "a") @=? ssymTerm "a", + testCase "On right 0" $ do + pevalAddNumTerm (ssymTerm "a") (conTerm 0 :: Term Integer) @=? ssymTerm "a", + testCase "On left concrete" $ do + pevalAddNumTerm (conTerm 1 :: Term Integer) (ssymTerm "a") + @=? addNumTerm (conTerm 1 :: Term Integer) (ssymTerm "a" :: Term Integer), + testCase "On right concrete" $ do + pevalAddNumTerm (ssymTerm "a") (conTerm 1 :: Term Integer) + @=? addNumTerm (conTerm 1 :: Term Integer) (ssymTerm "a" :: Term Integer), + testCase "On no concrete" $ do + pevalAddNumTerm (ssymTerm "a") (ssymTerm "b" :: Term Integer) + @=? addNumTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b" :: Term Integer), + testCase "On left concrete and right add concrete value" $ do + pevalAddNumTerm (conTerm 1 :: Term Integer) (pevalAddNumTerm (conTerm 2 :: Term Integer) (ssymTerm "a")) + @=? pevalAddNumTerm (conTerm 3 :: Term Integer) (ssymTerm "a"), + testCase "On right concrete and left add concrete value" $ do + pevalAddNumTerm (pevalAddNumTerm (conTerm 2 :: Term Integer) (ssymTerm "a")) (conTerm 1 :: Term Integer) + @=? pevalAddNumTerm (conTerm 3 :: Term Integer) (ssymTerm "a"), + testCase "On left add concrete" $ do + pevalAddNumTerm (pevalAddNumTerm (conTerm 2 :: Term Integer) (ssymTerm "a")) (ssymTerm "b") + @=? pevalAddNumTerm (conTerm 2 :: Term Integer) (pevalAddNumTerm (ssymTerm "a") (ssymTerm "b")), + testCase "On right add concrete" $ do + pevalAddNumTerm (ssymTerm "b") (pevalAddNumTerm (conTerm 2 :: Term Integer) (ssymTerm "a")) + @=? pevalAddNumTerm (conTerm 2 :: Term Integer) (pevalAddNumTerm (ssymTerm "b") (ssymTerm "a")), + testCase "On both neg" $ do + pevalAddNumTerm (pevalNegNumTerm $ ssymTerm "a" :: Term Integer) (pevalNegNumTerm $ ssymTerm "b") + @=? pevalNegNumTerm (pevalAddNumTerm (ssymTerm "a") (ssymTerm "b")), + testCase "On both mul the same concrete" $ do + pevalAddNumTerm + (pevalMulNumTerm (conTerm 3) (ssymTerm "a") :: Term Integer) + (pevalMulNumTerm (conTerm 3) (ssymTerm "b")) + @=? pevalMulNumTerm (conTerm 3) (pevalAddNumTerm (ssymTerm "a") (ssymTerm "b")), + testCase "On both mul the same symbolic" $ do + pevalAddNumTerm + (pevalMulNumTerm (conTerm 3) (ssymTerm "a") :: Term Integer) + (pevalMulNumTerm (conTerm 3) (ssymTerm "a")) + @=? pevalMulNumTerm (conTerm 6) (ssymTerm "a") + pevalAddNumTerm + (pevalMulNumTerm (conTerm 3) (ssymTerm "a") :: Term Integer) + (pevalMulNumTerm (conTerm 4) (ssymTerm "a")) + @=? pevalMulNumTerm (conTerm 7) (ssymTerm "a"), + testCase "Unfold 1" $ do + pevalAddNumTerm + (conTerm 3) + (pevalITETerm (ssymTerm "a") (conTerm 1 :: Term Integer) (ssymTerm "a")) + @=? pevalITETerm (ssymTerm "a") (conTerm 4) (pevalAddNumTerm (conTerm 3) (ssymTerm "a")) + pevalAddNumTerm + (pevalITETerm (ssymTerm "a") (conTerm 1 :: Term Integer) (ssymTerm "a")) + (conTerm 3) + @=? pevalITETerm (ssymTerm "a") (conTerm 4) (pevalAddNumTerm (ssymTerm "a") (conTerm 3)) + ], + testGroup + "sub" + [ testCase "sub num should be delegated to add and neg" $ do + pevalSubNumTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b") + @=? pevalAddNumTerm (ssymTerm "a") (pevalNegNumTerm $ ssymTerm "b") + ], + testGroup + "Neg" + [ testCase "On concrete" $ do + pevalNegNumTerm (conTerm 1 :: Term Integer) @=? conTerm (-1) + pevalNegNumTerm (conTerm 1 :: Term (WordN 3)) @=? conTerm (-1), + testCase "On Neg" $ do + pevalNegNumTerm (pevalNegNumTerm (ssymTerm "a" :: Term Integer)) @=? ssymTerm "a", + testCase "On Add concrete" $ do + pevalNegNumTerm (pevalAddNumTerm (conTerm 1) (ssymTerm "a" :: Term Integer)) + @=? pevalAddNumTerm (conTerm $ -1) (pevalNegNumTerm $ ssymTerm "a"), + testCase "On Add neg" $ do + pevalNegNumTerm (pevalAddNumTerm (pevalNegNumTerm $ ssymTerm "a") (ssymTerm "b" :: Term Integer)) + @=? pevalAddNumTerm (ssymTerm "a") (pevalNegNumTerm $ ssymTerm "b") + pevalNegNumTerm (pevalAddNumTerm (ssymTerm "a") (pevalNegNumTerm $ ssymTerm "b" :: Term Integer)) + @=? pevalAddNumTerm (pevalNegNumTerm $ ssymTerm "a") (ssymTerm "b"), + testCase "On Mul concrete" $ do + pevalNegNumTerm (pevalMulNumTerm (conTerm 3) (ssymTerm "a" :: Term Integer)) + @=? pevalMulNumTerm (conTerm $ -3) (ssymTerm "a"), + testCase "On symbolic" $ do + pevalNegNumTerm (ssymTerm "a" :: Term Integer) + @=? negNumTerm (ssymTerm "a") + ], + testGroup + "Mul" + [ testCase "On both concrete" $ do + pevalMulNumTerm (conTerm 3 :: Term Integer) (conTerm 5) + @=? conTerm 15, + testCase "On left 0" $ do + pevalMulNumTerm (conTerm 0 :: Term Integer) (ssymTerm "a") + @=? conTerm 0, + testCase "On right 0" $ do + pevalMulNumTerm (ssymTerm "a") (conTerm 0 :: Term Integer) + @=? conTerm 0, + testCase "On left 1" $ do + pevalMulNumTerm (conTerm 1 :: Term Integer) (ssymTerm "a") + @=? ssymTerm "a", + testCase "On right 1" $ do + pevalMulNumTerm (ssymTerm "a") (conTerm 1 :: Term Integer) + @=? ssymTerm "a", + testCase "On left -1" $ do + pevalMulNumTerm (conTerm $ -1 :: Term Integer) (ssymTerm "a") + @=? pevalNegNumTerm (ssymTerm "a"), + testCase "On right -1" $ do + pevalMulNumTerm (ssymTerm "a") (conTerm $ -1 :: Term Integer) + @=? pevalNegNumTerm (ssymTerm "a"), + testCase "On left concrete and right mul concrete symbolics" $ do + pevalMulNumTerm (conTerm 3) (pevalMulNumTerm (conTerm 5 :: Term Integer) (ssymTerm "a")) + @=? pevalMulNumTerm (conTerm 15) (ssymTerm "a"), + testCase "On right concrete and left mul concrete symbolics" $ do + pevalMulNumTerm (pevalMulNumTerm (conTerm 5 :: Term Integer) (ssymTerm "a")) (conTerm 3) + @=? pevalMulNumTerm (conTerm 15) (ssymTerm "a"), + testCase "On left concrete and right add concrete symbolics" $ do + pevalMulNumTerm (conTerm 3) (pevalAddNumTerm (conTerm 5 :: Term Integer) (ssymTerm "a")) + @=? pevalAddNumTerm (conTerm 15) (pevalMulNumTerm (conTerm 3) (ssymTerm "a")), + testCase "On right concrete and left add concrete symbolics" $ do + pevalMulNumTerm (pevalAddNumTerm (conTerm 5 :: Term Integer) (ssymTerm "a")) (conTerm 3) + @=? pevalAddNumTerm (conTerm 15) (pevalMulNumTerm (conTerm 3) (ssymTerm "a")), + testCase "On left concrete and right neg" $ do + pevalMulNumTerm (conTerm 3 :: Term Integer) (pevalNegNumTerm (ssymTerm "a")) + @=? pevalMulNumTerm (conTerm $ -3) (ssymTerm "a"), + testCase "On left mul concrete symbolics" $ do + pevalMulNumTerm (pevalMulNumTerm (conTerm 3 :: Term Integer) (ssymTerm "a")) (ssymTerm "b") + @=? pevalMulNumTerm (conTerm 3) (pevalMulNumTerm (ssymTerm "a") (ssymTerm "b")), + testCase "On right mul concrete symbolics" $ do + pevalMulNumTerm (ssymTerm "b") (pevalMulNumTerm (conTerm 3 :: Term Integer) (ssymTerm "a")) + @=? pevalMulNumTerm (conTerm 3) (pevalMulNumTerm (ssymTerm "b") (ssymTerm "a")), + testCase "On left neg" $ do + pevalMulNumTerm (pevalNegNumTerm $ ssymTerm "a") (ssymTerm "b" :: Term Integer) + @=? pevalNegNumTerm (pevalMulNumTerm (ssymTerm "a") (ssymTerm "b")), + testCase "On right neg" $ do + pevalMulNumTerm (ssymTerm "a") (pevalNegNumTerm $ ssymTerm "b" :: Term Integer) + @=? pevalNegNumTerm (pevalMulNumTerm (ssymTerm "a") (ssymTerm "b")), + testCase "On right concrete and left neg" $ do + pevalMulNumTerm (pevalNegNumTerm (ssymTerm "a")) (conTerm 3 :: Term Integer) + @=? pevalMulNumTerm (conTerm $ -3) (ssymTerm "a"), + testCase "On left concrete" $ do + pevalMulNumTerm (conTerm 3 :: Term Integer) (ssymTerm "a") + @=? mulNumTerm + (conTerm 3 :: Term Integer) + (ssymTerm "a" :: Term Integer), + testCase "On right concrete" $ do + pevalMulNumTerm (ssymTerm "a") (conTerm 3 :: Term Integer) + @=? mulNumTerm + (conTerm 3 :: Term Integer) + (ssymTerm "a" :: Term Integer), + testCase "On no concrete" $ do + pevalMulNumTerm (ssymTerm "a") (ssymTerm "b" :: Term Integer) + @=? mulNumTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b" :: Term Integer), + testCase "Unfold 1" $ do + pevalMulNumTerm + (conTerm 3) + (pevalITETerm (ssymTerm "a") (conTerm 5 :: Term Integer) (ssymTerm "a")) + @=? pevalITETerm (ssymTerm "a") (conTerm 15) (pevalMulNumTerm (conTerm 3) (ssymTerm "a")) + pevalMulNumTerm + (pevalITETerm (ssymTerm "a") (conTerm 5 :: Term Integer) (ssymTerm "a")) + (conTerm 3) + @=? pevalITETerm (ssymTerm "a") (conTerm 15) (pevalMulNumTerm (ssymTerm "a") (conTerm 3)) + ], + testGroup + "Abs" + [ testCase "On concrete" $ do + pevalAbsNumTerm (conTerm 10 :: Term Integer) @=? conTerm 10 + pevalAbsNumTerm (conTerm $ -10 :: Term Integer) @=? conTerm 10, + testCase "On Neg Integer" $ do + pevalAbsNumTerm (pevalNegNumTerm $ ssymTerm "a" :: Term Integer) @=? pevalAbsNumTerm (ssymTerm "a"), + testCase "On Neg BV" $ do + pevalAbsNumTerm (pevalNegNumTerm $ ssymTerm "a" :: Term (IntN 5)) @=? pevalAbsNumTerm (ssymTerm "a") + pevalAbsNumTerm (pevalNegNumTerm $ ssymTerm "a" :: Term (WordN 5)) @=? negNumTerm (ssymTerm "a"), + testCase "On Abs Integer" $ do + pevalAbsNumTerm (pevalAbsNumTerm $ ssymTerm "a" :: Term Integer) @=? pevalAbsNumTerm (ssymTerm "a"), + testCase "On Abs BV" $ do + pevalAbsNumTerm (pevalAbsNumTerm $ ssymTerm "a" :: Term (IntN 5)) @=? pevalAbsNumTerm (ssymTerm "a") + pevalAbsNumTerm (pevalAbsNumTerm $ ssymTerm "a" :: Term (WordN 5)) @=? ssymTerm "a", + testCase "On Mul Integer" $ do + pevalAbsNumTerm (pevalMulNumTerm (ssymTerm "a") (ssymTerm "b") :: Term Integer) + @=? pevalMulNumTerm (pevalAbsNumTerm (ssymTerm "a")) (pevalAbsNumTerm (ssymTerm "b")), + testCase "On Mul BV" $ do + pevalAbsNumTerm (pevalMulNumTerm (ssymTerm "a") (ssymTerm "b") :: Term (IntN 5)) + @=? absNumTerm (pevalMulNumTerm (ssymTerm "a") (ssymTerm "b") :: Term (IntN 5)) + pevalAbsNumTerm (pevalMulNumTerm (ssymTerm "a") (ssymTerm "b") :: Term (WordN 5)) + @=? pevalMulNumTerm (ssymTerm "a") (ssymTerm "b"), + testCase "On symbolic Integer" $ do + pevalAbsNumTerm (ssymTerm "a" :: Term Integer) + @=? absNumTerm (ssymTerm "a"), + testCase "On symbolic BV" $ do + pevalAbsNumTerm (ssymTerm "a" :: Term (IntN 5)) @=? absNumTerm (ssymTerm "a") + pevalAbsNumTerm (ssymTerm "a" :: Term (WordN 5)) @=? ssymTerm "a" + ], + testGroup + "Signum" + [ testCase "On concrete" $ do + pevalSignumNumTerm (conTerm 10 :: Term Integer) @=? conTerm 1 + pevalSignumNumTerm (conTerm 0 :: Term Integer) @=? conTerm 0 + pevalSignumNumTerm (conTerm $ -10 :: Term Integer) @=? conTerm (-1), + testCase "On Neg Integer" $ do + pevalSignumNumTerm (pevalNegNumTerm $ ssymTerm "a" :: Term Integer) + @=? pevalNegNumTerm (pevalSignumNumTerm $ ssymTerm "a"), + testCase "On Neg BV" $ do + pevalSignumNumTerm (pevalNegNumTerm $ ssymTerm "a" :: Term (IntN 5)) + @=? signumNumTerm (pevalNegNumTerm $ ssymTerm "a" :: Term (IntN 5)) + pevalSignumNumTerm (pevalNegNumTerm $ ssymTerm "a" :: Term (WordN 5)) + @=? signumNumTerm (pevalNegNumTerm $ ssymTerm "a" :: Term (WordN 5)), + testCase "On Mul Integer" $ do + pevalSignumNumTerm (pevalMulNumTerm (ssymTerm "a") (ssymTerm "b") :: Term Integer) + @=? pevalMulNumTerm (pevalSignumNumTerm $ ssymTerm "a") (pevalSignumNumTerm $ ssymTerm "b"), + testCase "On Mul BV" $ do + pevalSignumNumTerm (pevalMulNumTerm (ssymTerm "a") (ssymTerm "b") :: Term (IntN 5)) + @=? signumNumTerm (pevalMulNumTerm (ssymTerm "a") (ssymTerm "b") :: Term (IntN 5)) + pevalSignumNumTerm (pevalMulNumTerm (ssymTerm "a") (ssymTerm "b") :: Term (WordN 5)) + @=? signumNumTerm (pevalMulNumTerm (ssymTerm "a") (ssymTerm "b") :: Term (WordN 5)), + testCase "On symbolics" $ do + pevalSignumNumTerm (ssymTerm "a" :: Term Integer) + @=? signumNumTerm (ssymTerm "a") + ], + let concSignedBV :: Integer -> Term (IntN 5) = conTerm . fromInteger + concUnsignedBV :: Integer -> Term (WordN 5) = conTerm . fromInteger + in testGroup + "Lt" + [ testCase "On both concrete" $ do + pevalLtOrdTerm (conTerm 1 :: Term Integer) (conTerm 2) @=? conTerm True + pevalLtOrdTerm (conTerm 2 :: Term Integer) (conTerm 2) @=? conTerm False + pevalLtOrdTerm (conTerm 3 :: Term Integer) (conTerm 2) @=? conTerm False + pevalLtOrdTerm (conTerm 1 :: Term (IntN 2)) (conTerm 0) @=? conTerm False + pevalLtOrdTerm (conTerm 2 :: Term (IntN 2)) (conTerm 0) @=? conTerm True + pevalLtOrdTerm (conTerm 3 :: Term (IntN 2)) (conTerm 0) @=? conTerm True + pevalLtOrdTerm (conTerm 1 :: Term (WordN 2)) (conTerm 2) @=? conTerm True + pevalLtOrdTerm (conTerm 2 :: Term (WordN 2)) (conTerm 2) @=? conTerm False + pevalLtOrdTerm (conTerm 3 :: Term (WordN 2)) (conTerm 2) @=? conTerm False, + testCase "On left constant and right add concrete Integers" $ do + pevalLtOrdTerm (conTerm 1 :: Term Integer) (pevalAddNumTerm (conTerm 2) (ssymTerm "a")) + @=? pevalLtOrdTerm (conTerm $ -1 :: Term Integer) (ssymTerm "a"), + testCase "On right constant left add concrete Integers" $ do + pevalLtOrdTerm (pevalAddNumTerm (conTerm 2) (ssymTerm "a")) (conTerm 1 :: Term Integer) + @=? pevalLtOrdTerm (conTerm 1 :: Term Integer) (pevalNegNumTerm $ ssymTerm "a"), + testCase "On right constant Integers" $ do + pevalLtOrdTerm (ssymTerm "a") (conTerm 1 :: Term Integer) + @=? pevalLtOrdTerm (conTerm $ -1 :: Term Integer) (pevalNegNumTerm $ ssymTerm "a"), + testCase "On right constant and left neg Integers" $ do + pevalLtOrdTerm (pevalNegNumTerm $ ssymTerm "a") (conTerm 1 :: Term Integer) + @=? pevalLtOrdTerm (conTerm $ -1 :: Term Integer) (ssymTerm "a"), + testCase "On left add concrete Integers" $ do + pevalLtOrdTerm (pevalAddNumTerm (conTerm 2) (ssymTerm "a")) (ssymTerm "b" :: Term Integer) + @=? pevalLtOrdTerm (conTerm 2 :: Term Integer) (pevalAddNumTerm (ssymTerm "b") (pevalNegNumTerm $ ssymTerm "a")), + testCase "On right add concrete Integers" $ do + pevalLtOrdTerm (ssymTerm "b" :: Term Integer) (pevalAddNumTerm (conTerm 2) (ssymTerm "a")) + @=? pevalLtOrdTerm (conTerm $ -2 :: Term Integer) (pevalAddNumTerm (ssymTerm "a") (pevalNegNumTerm $ ssymTerm "b")), + testCase "On left constant and right add concrete BVs should not be simplified" $ do + pevalLtOrdTerm (concSignedBV 1) (pevalAddNumTerm (conTerm 2) (ssymTerm "a")) + @=? ltOrdTerm (concSignedBV 1) (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a")) + pevalLtOrdTerm (concUnsignedBV 1) (pevalAddNumTerm (conTerm 2) (ssymTerm "a")) + @=? ltOrdTerm (concUnsignedBV 1) (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")), + testCase "On right constant and left add concrete BVs should not be simplified" $ do + pevalLtOrdTerm (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a")) (conTerm 1) + @=? ltOrdTerm (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a")) (concSignedBV 1) + pevalLtOrdTerm (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")) (conTerm 1) + @=? ltOrdTerm (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")) (concUnsignedBV 1), + testCase "On right constant BVs should not be simplified" $ do + pevalLtOrdTerm (ssymTerm "a") (concSignedBV 1) + @=? ltOrdTerm (ssymTerm "a" :: Term (IntN 5)) (concSignedBV 1) + pevalLtOrdTerm (ssymTerm "a") (concUnsignedBV 1) + @=? ltOrdTerm (ssymTerm "a" :: Term (WordN 5)) (concUnsignedBV 1), + testCase "On right constant and left neg BVs should not be simplified" $ do + pevalLtOrdTerm (pevalNegNumTerm $ ssymTerm "a") (concSignedBV 1) + @=? ltOrdTerm (pevalNegNumTerm $ ssymTerm "a" :: Term (IntN 5)) (concSignedBV 1) + pevalLtOrdTerm (pevalNegNumTerm $ ssymTerm "a") (concUnsignedBV 1) + @=? ltOrdTerm (pevalNegNumTerm $ ssymTerm "a" :: Term (WordN 5)) (concUnsignedBV 1), + testCase "On left add concrete BVs should not be simplified" $ do + pevalLtOrdTerm (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a")) (ssymTerm "b") + @=? ltOrdTerm (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a")) (ssymTerm "b" :: Term (IntN 5)) + pevalLtOrdTerm (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")) (ssymTerm "b") + @=? ltOrdTerm (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")) (ssymTerm "b" :: Term (WordN 5)), + testCase "On right add concrete BVs should not be simplified" $ do + pevalLtOrdTerm (ssymTerm "b") (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a")) + @=? ltOrdTerm + (ssymTerm "b" :: Term (IntN 5)) + (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a")) + pevalLtOrdTerm (ssymTerm "b") (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")) + @=? ltOrdTerm + (ssymTerm "b" :: Term (WordN 5)) + (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")), + testCase "On symbolic" $ do + pevalLtOrdTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b") + @=? ltOrdTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b" :: Term Integer) + ], + let concSignedBV :: Integer -> Term (IntN 5) = conTerm . fromInteger + concUnsignedBV :: Integer -> Term (WordN 5) = conTerm . fromInteger + in testGroup + "Le" + [ testCase "On both concrete" $ do + pevalLeOrdTerm (conTerm 1 :: Term Integer) (conTerm 2) @=? conTerm True + pevalLeOrdTerm (conTerm 2 :: Term Integer) (conTerm 2) @=? conTerm True + pevalLeOrdTerm (conTerm 3 :: Term Integer) (conTerm 2) @=? conTerm False + pevalLeOrdTerm (conTerm 0 :: Term (IntN 2)) (conTerm 0) @=? conTerm True + pevalLeOrdTerm (conTerm 1 :: Term (IntN 2)) (conTerm 0) @=? conTerm False + pevalLeOrdTerm (conTerm 2 :: Term (IntN 2)) (conTerm 0) @=? conTerm True + pevalLeOrdTerm (conTerm 3 :: Term (IntN 2)) (conTerm 0) @=? conTerm True + pevalLeOrdTerm (conTerm 1 :: Term (WordN 2)) (conTerm 2) @=? conTerm True + pevalLeOrdTerm (conTerm 2 :: Term (WordN 2)) (conTerm 2) @=? conTerm True + pevalLeOrdTerm (conTerm 3 :: Term (WordN 2)) (conTerm 2) @=? conTerm False, + testCase "On left constant and right add concrete Integers" $ do + pevalLeOrdTerm (conTerm 1 :: Term Integer) (pevalAddNumTerm (conTerm 2) (ssymTerm "a")) + @=? pevalLeOrdTerm (conTerm $ -1 :: Term Integer) (ssymTerm "a"), + testCase "On right constant and left add concrete Integers" $ do + pevalLeOrdTerm (pevalAddNumTerm (conTerm 2) (ssymTerm "a")) (conTerm 1 :: Term Integer) + @=? pevalLeOrdTerm (conTerm 1 :: Term Integer) (pevalNegNumTerm $ ssymTerm "a"), + testCase "On right constant Integers" $ do + pevalLeOrdTerm (ssymTerm "a") (conTerm 1 :: Term Integer) + @=? pevalLeOrdTerm (conTerm $ -1 :: Term Integer) (pevalNegNumTerm $ ssymTerm "a"), + testCase "On right constant left neg Integers" $ do + pevalLeOrdTerm (pevalNegNumTerm $ ssymTerm "a") (conTerm 1 :: Term Integer) + @=? pevalLeOrdTerm (conTerm $ -1 :: Term Integer) (ssymTerm "a"), + testCase "On left add concrete Integers" $ do + pevalLeOrdTerm (pevalAddNumTerm (conTerm 2) (ssymTerm "a")) (ssymTerm "b" :: Term Integer) + @=? pevalLeOrdTerm (conTerm 2 :: Term Integer) (pevalAddNumTerm (ssymTerm "b") (pevalNegNumTerm $ ssymTerm "a")), + testCase "On right add concrete Integers" $ do + pevalLeOrdTerm (ssymTerm "b" :: Term Integer) (pevalAddNumTerm (conTerm 2) (ssymTerm "a")) + @=? pevalLeOrdTerm (conTerm $ -2 :: Term Integer) (pevalAddNumTerm (ssymTerm "a") (pevalNegNumTerm $ ssymTerm "b")), + testCase "On left constant and right add concrete BVs should not be simplified" $ do + pevalLeOrdTerm (concSignedBV 1) (pevalAddNumTerm (conTerm 2) (ssymTerm "a")) + @=? leOrdTerm (concSignedBV 1) (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a")) + pevalLeOrdTerm (concUnsignedBV 1) (pevalAddNumTerm (conTerm 2) (ssymTerm "a")) + @=? leOrdTerm (concUnsignedBV 1) (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")), + testCase "On right constant and left add concrete BVs should not be simplified" $ do + pevalLeOrdTerm (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a")) (conTerm 1) + @=? leOrdTerm (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a")) (concSignedBV 1) + pevalLeOrdTerm (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")) (conTerm 1) + @=? leOrdTerm (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")) (concUnsignedBV 1), + testCase "On right constant BVs should not be simplified" $ do + pevalLeOrdTerm (ssymTerm "a") (concSignedBV 1) + @=? leOrdTerm (ssymTerm "a" :: Term (IntN 5)) (concSignedBV 1) + pevalLeOrdTerm (ssymTerm "a") (concUnsignedBV 1) + @=? leOrdTerm (ssymTerm "a" :: Term (WordN 5)) (concUnsignedBV 1), + testCase "On right constant and left neg BVs should not be simplified" $ do + pevalLeOrdTerm (pevalNegNumTerm $ ssymTerm "a") (concSignedBV 1) + @=? leOrdTerm (pevalNegNumTerm $ ssymTerm "a" :: Term (IntN 5)) (concSignedBV 1) + pevalLeOrdTerm (pevalNegNumTerm $ ssymTerm "a") (concUnsignedBV 1) + @=? leOrdTerm (pevalNegNumTerm $ ssymTerm "a" :: Term (WordN 5)) (concUnsignedBV 1), + testCase "On left add concrete BVs should not be simplified" $ do + pevalLeOrdTerm (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a")) (ssymTerm "b") + @=? leOrdTerm (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a")) (ssymTerm "b" :: Term (IntN 5)) + pevalLeOrdTerm (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")) (ssymTerm "b") + @=? leOrdTerm (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")) (ssymTerm "b" :: Term (WordN 5)), + testCase "Lt on right add concrete BVs should not be simplified" $ do + pevalLeOrdTerm (ssymTerm "b") (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a")) + @=? leOrdTerm + (ssymTerm "b" :: Term (IntN 5)) + (pevalAddNumTerm (concSignedBV 2) (ssymTerm "a")) + pevalLeOrdTerm (ssymTerm "b") (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")) + @=? leOrdTerm + (ssymTerm "b" :: Term (WordN 5)) + (pevalAddNumTerm (concUnsignedBV 2) (ssymTerm "a")), + testCase "On symbolic" $ do + pevalLeOrdTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b") + @=? leOrdTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b" :: Term Integer) + ], + testCase "Gt should be delegated to Lt" $ + pevalGtOrdTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b") + @=? pevalLtOrdTerm (ssymTerm "b" :: Term Integer) (ssymTerm "a"), + testCase "Ge should be delegated to Le" $ do + pevalGeOrdTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b") + @=? pevalLeOrdTerm (ssymTerm "b" :: Term Integer) (ssymTerm "a") + ] diff --git a/test/Grisette/SymPrim/Prim/TabularFunTests.hs b/test/Grisette/SymPrim/Prim/TabularFunTests.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/SymPrim/Prim/TabularFunTests.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Grisette.SymPrim.Prim.TabularFunTests (tabularFunTests) where + +import Grisette + ( type (=->) (TabularFun), + ) +import Grisette.Internal.SymPrim.Prim.Term + ( PEvalApplyTerm (pevalApplyTerm), + SupportedPrim (pevalITETerm), + Term, + applyTerm, + conTerm, + pevalEqTerm, + ssymTerm, + ) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@=?)) + +tabularFunTests :: Test +tabularFunTests = + testGroup + "TabularFun" + [ testGroup + "Apply" + [ testCase "On concrete" $ do + let f :: Integer =-> Integer = + TabularFun [(1, 2), (3, 4)] 5 + pevalApplyTerm (conTerm f) (conTerm 0) @=? conTerm 5 + pevalApplyTerm (conTerm f) (conTerm 1) @=? conTerm 2 + pevalApplyTerm (conTerm f) (conTerm 2) @=? conTerm 5 + pevalApplyTerm (conTerm f) (conTerm 3) @=? conTerm 4 + pevalApplyTerm (conTerm f) (conTerm 4) @=? conTerm 5, + testCase "On concrete function" $ do + let f :: Integer =-> Integer = + TabularFun [(1, 2), (3, 4)] 5 + pevalApplyTerm (conTerm f) (ssymTerm "b") + @=? pevalITETerm + (pevalEqTerm (conTerm 1 :: Term Integer) (ssymTerm "b")) + (conTerm 2) + ( pevalITETerm + (pevalEqTerm (conTerm 3 :: Term Integer) (ssymTerm "b")) + (conTerm 4) + (conTerm 5) + ), + testCase "On symbolic" $ do + pevalApplyTerm (ssymTerm "f" :: Term (Integer =-> Integer)) (ssymTerm "a") + @=? applyTerm + (ssymTerm "f" :: Term (Integer =-> Integer)) + (ssymTerm "a" :: Term Integer) + ] + ] diff --git a/test/Grisette/SymPrim/SymPrimTests.hs b/test/Grisette/SymPrim/SymPrimTests.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/SymPrim/SymPrimTests.hs @@ -0,0 +1,1048 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module Grisette.SymPrim.SymPrimTests (symPrimTests) where + +import Control.DeepSeq (NFData (rnf), force) +import Control.Exception + ( ArithException (DivideByZero, Overflow, Underflow), + catch, + evaluate, + ) +import Control.Monad.Except (ExceptT, MonadError (throwError)) +import Data.Bits + ( Bits + ( bit, + bitSizeMaybe, + complement, + isSigned, + popCount, + rotate, + shift, + testBit, + xor, + (.&.), + (.|.) + ), + ) +import qualified Data.HashMap.Strict as M +import qualified Data.HashSet as S +import Data.Int (Int8) +import Data.Proxy (Proxy (Proxy)) +import Data.Word (Word8) +import Grisette + ( Apply (apply), + BV (bv), + EvaluateSym (evaluateSym), + ExtractSymbolics (extractSymbolics), + Function ((#)), + ITEOp (symIte), + LogicalOp (symImplies, symNot, symXor, (.&&), (.||)), + Mergeable (rootStrategy), + MergingStrategy (SimpleStrategy), + ModelOps (emptyModel, insertValue), + ModelRep (buildModel), + SEq ((./=), (.==)), + SOrd (symCompare, (.<), (.<=), (.>), (.>=)), + SafeDivision + ( safeDiv, + safeDivMod, + safeMod, + safeQuot, + safeQuotRem, + safeRem + ), + SafeLinearArith + ( safeAdd, + safeNeg, + safeSub + ), + SimpleMergeable (mrgIte), + SizedBV + ( sizedBVConcat, + sizedBVExt, + sizedBVSelect, + sizedBVSext, + sizedBVZext + ), + Solvable (con, conView, isym, ssym), + SomeSymIntN, + SomeSymWordN, + ToCon (toCon), + ToSym (toSym), + TypedSymbol, + UnionM, + genSym, + genSymSimple, + mrgIf, + mrgSingle, + tryMerge, + pattern Con, + pattern SomeSymIntN, + pattern SomeSymWordN, + type (-->), + type (=->), + ) +import Grisette.Internal.SymPrim.BV + ( IntN (IntN), + WordN (WordN), + ) +import Grisette.Internal.SymPrim.Prim.Model + ( Model (Model), + SymbolSet (SymbolSet), + ) +import Grisette.Internal.SymPrim.Prim.ModelValue (toModelValue) +import Grisette.Internal.SymPrim.Prim.Term + ( LinkedRep (wrapTerm), + PEvalApplyTerm (pevalApplyTerm), + PEvalBVTerm + ( pevalBVConcatTerm, + pevalBVExtendTerm, + pevalBVSelectTerm + ), + PEvalBitwiseTerm + ( pevalAndBitsTerm, + pevalComplementBitsTerm, + pevalOrBitsTerm, + pevalXorBitsTerm + ), + PEvalDivModIntegralTerm + ( pevalDivIntegralTerm, + pevalModIntegralTerm, + pevalQuotIntegralTerm, + pevalRemIntegralTerm + ), + PEvalNumTerm + ( pevalAbsNumTerm, + pevalAddNumTerm, + pevalMulNumTerm, + pevalNegNumTerm, + pevalSignumNumTerm + ), + PEvalOrdTerm (pevalLeOrdTerm, pevalLtOrdTerm), + PEvalRotateTerm + ( pevalRotateLeftTerm, + pevalRotateRightTerm + ), + PEvalShiftTerm + ( pevalShiftLeftTerm, + pevalShiftRightTerm + ), + SupportedPrim (pevalITETerm), + Term, + conTerm, + isymTerm, + pevalAndTerm, + pevalEqTerm, + pevalGeOrdTerm, + pevalGtOrdTerm, + pevalImplyTerm, + pevalNotTerm, + pevalOrTerm, + pevalSubNumTerm, + pevalXorTerm, + someTypedSymbol, + ssymTerm, + ) +import Grisette.SymPrim + ( ModelSymPair ((:=)), + SymBool (SymBool), + SymIntN (SymIntN), + SymInteger (SymInteger), + SymWordN (SymWordN), + symSize, + symsSize, + (-->), + type (-~>), + type (=~>), + ) +import Test.Framework (Test, TestName, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.HUnit (Assertion, assertFailure, (@=?), (@?=)) +import Test.QuickCheck (Arbitrary, ioProperty) + +newtype AEWrapper = AEWrapper ArithException deriving (Eq) + +instance Show AEWrapper where + show (AEWrapper x) = show x + +instance NFData AEWrapper where + rnf (AEWrapper x) = x `seq` () + +sameSafeDiv :: + forall c s. + ( Show s, + Eq s, + Eq c, + Num c, + Mergeable s, + NFData c, + Solvable c s + ) => + c -> + c -> + (s -> s -> ExceptT ArithException UnionM s) -> + (c -> c -> c) -> + Assertion +sameSafeDiv i j f cf = do + xc <- evaluate (force $ Right $ cf i j) `catch` \(e :: ArithException) -> return $ Left $ AEWrapper e + case xc of + Left (AEWrapper e) -> f (con i :: s) (con j) @=? tryMerge (throwError e) + Right c -> f (con i :: s) (con j) @=? mrgSingle (con c) + +sameSafeDivMod :: + forall c s. + ( Show s, + Eq s, + Eq c, + Num c, + Mergeable s, + NFData c, + Solvable c s + ) => + c -> + c -> + (s -> s -> ExceptT ArithException UnionM (s, s)) -> + (c -> c -> (c, c)) -> + Assertion +sameSafeDivMod i j f cf = do + xc <- evaluate (force $ Right $ cf i j) `catch` \(e :: ArithException) -> return $ Left $ AEWrapper e + case xc of + Left (AEWrapper e) -> f (con i :: s) (con j) @=? tryMerge (throwError e) + Right (c1, c2) -> f (con i :: s) (con j) @=? mrgSingle (con c1, con c2) + +safeDivisionBoundedOnlyTests :: + forall c s. + (LinkedRep c s, Bounded c, Solvable c s, Eq s, Num c, Show s, Mergeable s, SEq s) => + (s -> s -> ExceptT ArithException UnionM s) -> + (c -> c -> c) -> + (Term c -> Term c -> Term c) -> + [Test] +safeDivisionBoundedOnlyTests f cf pf = + [ testCase "on concrete min divided by minus one" $ do + sameSafeDiv minBound (-1) f cf, + testCase "on symbolic" $ do + f (ssym "a" :: s) (ssym "b") + @=? ( mrgIf + ((ssym "b" :: s) .== con (0 :: c) :: SymBool) + (throwError DivideByZero) + ( mrgIf + ((ssym "b" :: s) .== con (-1) .&& (ssym "a" :: s) .== con (minBound :: c) :: SymBool) + (throwError Overflow) + (mrgSingle $ wrapTerm $ pf (ssymTerm "a") (ssymTerm "b")) + ) :: + ExceptT ArithException UnionM s + ) + ] + +safeDivisionUnboundedOnlyTests :: + forall c s. + (LinkedRep c s, Solvable c s, Eq s, Num c, Show s, Mergeable s, SEq s) => + (s -> s -> ExceptT ArithException UnionM s) -> + (Term c -> Term c -> Term c) -> + [Test] +safeDivisionUnboundedOnlyTests f pf = + [ testCase "on symbolic" $ do + f (ssym "a" :: s) (ssym "b") + @=? ( mrgIf + ((ssym "b" :: s) .== con (0 :: c) :: SymBool) + (throwError DivideByZero) + (mrgSingle $ wrapTerm $ pf (ssymTerm "a") (ssymTerm "b")) :: + ExceptT ArithException UnionM s + ) + ] + +safeDivisionGeneralTests :: + forall c c0 s. + (LinkedRep c s, Arbitrary c0, Show c0, Solvable c s, Eq s, Num c, Show s, Mergeable s, SEq s) => + (c0 -> c) -> + (s -> s -> ExceptT ArithException UnionM s) -> + (c -> c -> c) -> + [Test] +safeDivisionGeneralTests transform f cf = + [ testProperty "on concrete prop" $ \(i0 :: c0, j0 :: c0) -> + ioProperty $ do + let i = transform i0 + let j = transform j0 + sameSafeDiv i j f cf, + testProperty "on concrete divided by zero" $ \(i0 :: c0) -> + ioProperty $ do + let i = transform i0 + sameSafeDiv i 0 f cf, + testCase "when divided by zero" $ do + f (ssym "a" :: s) (con 0) + @=? (tryMerge $ throwError DivideByZero :: ExceptT ArithException UnionM s) + ] + +safeDivisionBoundedTests :: + forall c c0 s. + (LinkedRep c s, Arbitrary c0, Show c0, Bounded c, Solvable c s, Eq s, Num c, Show s, Mergeable s, SEq s) => + TestName -> + (c0 -> c) -> + (s -> s -> ExceptT ArithException UnionM s) -> + (c -> c -> c) -> + (Term c -> Term c -> Term c) -> + Test +safeDivisionBoundedTests name transform f cf pf = + testGroup name $ + safeDivisionGeneralTests transform f cf + ++ safeDivisionBoundedOnlyTests f cf pf + +safeDivisionUnboundedTests :: + forall c c0 s. + (LinkedRep c s, Arbitrary c0, Show c0, Solvable c s, Eq s, Num c, Show s, Mergeable s, SEq s) => + TestName -> + (c0 -> c) -> + (s -> s -> ExceptT ArithException UnionM s) -> + (c -> c -> c) -> + (Term c -> Term c -> Term c) -> + Test +safeDivisionUnboundedTests name transform f cf pf = + testGroup name $ + safeDivisionGeneralTests transform f cf + ++ safeDivisionUnboundedOnlyTests f pf + +safeDivModBoundedOnlyTests :: + forall c s. + (LinkedRep c s, Bounded c, Solvable c s, Eq s, Num c, Show s, Mergeable s, SEq s) => + ( s -> + s -> + ExceptT ArithException UnionM (s, s) + ) -> + (c -> c -> (c, c)) -> + (Term c -> Term c -> Term c) -> + (Term c -> Term c -> Term c) -> + [Test] +safeDivModBoundedOnlyTests f cf pf1 pf2 = + [ testCase "on concrete min divided by minus one" $ + sameSafeDivMod minBound (-1) f cf, + testCase "on symbolic" $ do + f (ssym "a" :: s) (ssym "b") + @=? ( mrgIf + ((ssym "b" :: s) .== con (0 :: c) :: SymBool) + (throwError DivideByZero) + ( mrgIf + ((ssym "b" :: s) .== con (-1) .&& (ssym "a" :: s) .== con (minBound :: c) :: SymBool) + (throwError Overflow) + ( mrgSingle + ( wrapTerm $ pf1 (ssymTerm "a") (ssymTerm "b"), + wrapTerm $ pf2 (ssymTerm "a") (ssymTerm "b") + ) + ) + ) :: + ExceptT ArithException UnionM (s, s) + ) + ] + +safeDivModUnboundedOnlyTests :: + forall c s. + (LinkedRep c s, Solvable c s, Eq s, Num c, Show s, Mergeable s, SEq s) => + ( s -> + s -> + ExceptT ArithException UnionM (s, s) + ) -> + (Term c -> Term c -> Term c) -> + (Term c -> Term c -> Term c) -> + [Test] +safeDivModUnboundedOnlyTests f pf1 pf2 = + [ testCase "on symbolic" $ do + f (ssym "a" :: s) (ssym "b") + @=? ( mrgIf + ((ssym "b" :: s) .== con (0 :: c) :: SymBool) + (throwError DivideByZero) + ( mrgSingle + ( wrapTerm $ pf1 (ssymTerm "a") (ssymTerm "b"), + wrapTerm $ pf2 (ssymTerm "a") (ssymTerm "b") + ) + ) :: + ExceptT ArithException UnionM (s, s) + ) + ] + +safeDivModGeneralTests :: + forall c c0 s. + (LinkedRep c s, Arbitrary c0, Show c0, Solvable c s, Eq s, Num c, Show s, Mergeable s, SEq s) => + (c0 -> c) -> + ( s -> + s -> + ExceptT ArithException UnionM (s, s) + ) -> + (c -> c -> (c, c)) -> + [Test] +safeDivModGeneralTests transform f cf = + [ testProperty "on concrete" $ \(i0 :: c0, j0 :: c0) -> + ioProperty $ do + let i = transform i0 + let j = transform j0 + sameSafeDivMod i j f cf, + testProperty "on concrete divided by zero" $ \(i0 :: c0) -> + ioProperty $ do + let i = transform i0 + sameSafeDivMod i 0 f cf, + testCase "when divided by zero" $ do + f (ssym "a" :: s) (con 0) + @=? (tryMerge $ throwError DivideByZero :: ExceptT ArithException UnionM (s, s)) + ] + +safeDivModBoundedTests :: + forall c c0 s. + (LinkedRep c s, Arbitrary c0, Show c0, Bounded c, Solvable c s, Eq s, Num c, Show s, Mergeable s, SEq s) => + TestName -> + (c0 -> c) -> + ( s -> + s -> + ExceptT ArithException UnionM (s, s) + ) -> + (c -> c -> (c, c)) -> + (Term c -> Term c -> Term c) -> + (Term c -> Term c -> Term c) -> + Test +safeDivModBoundedTests name transform f cf pf1 pf2 = + testGroup name $ + safeDivModGeneralTests transform f cf + ++ safeDivModBoundedOnlyTests f cf pf1 pf2 + +safeDivModUnboundedTests :: + forall c c0 s. + (LinkedRep c s, Arbitrary c0, Show c0, Solvable c s, Eq s, Num c, Show s, Mergeable s, SEq s) => + TestName -> + (c0 -> c) -> + ( s -> + s -> + ExceptT ArithException UnionM (s, s) + ) -> + (c -> c -> (c, c)) -> + (Term c -> Term c -> Term c) -> + (Term c -> Term c -> Term c) -> + Test +safeDivModUnboundedTests name transform f cf pf1 pf2 = + testGroup name $ + safeDivModGeneralTests transform f cf + ++ safeDivModUnboundedOnlyTests f pf1 pf2 + +symPrimTests :: Test +symPrimTests = + testGroup + "SymPrim" + [ testGroup + "General SymPrim" + [ testGroup + "Solvable" + [ testCase "con" $ (con 1 :: SymInteger) @=? SymInteger (conTerm 1), + testCase "ssym" $ (ssym "a" :: SymInteger) @=? SymInteger (ssymTerm "a"), + testCase "isym" $ (isym "a" 1 :: SymInteger) @=? SymInteger (isymTerm "a" 1), + testCase "conView" $ do + conView (con 1 :: SymInteger) @=? Just 1 + conView (ssym "a" :: SymInteger) @=? Nothing + case con 1 :: SymInteger of + Con 1 -> return () + _ -> assertFailure "Bad match" + case ssym "a" :: SymInteger of + Con _ -> assertFailure "Bad match" + _ -> return () + ], + testGroup + "ITEOp" + [ testCase "symIte" $ + symIte (ssym "a" :: SymBool) (ssym "b" :: SymInteger) (ssym "c") + @=? SymInteger (pevalITETerm (ssymTerm "a") (ssymTerm "b") (ssymTerm "c")) + ], + testCase "Mergeable" $ do + let SimpleStrategy s = rootStrategy :: MergingStrategy SymInteger + s (ssym "a") (ssym "b") (ssym "c") + @=? symIte (ssym "a" :: SymBool) (ssym "b" :: SymInteger) (ssym "c"), + testCase "SimpleMergeable" $ + mrgIte (ssym "a" :: SymBool) (ssym "b") (ssym "c") + @=? symIte (ssym "a" :: SymBool) (ssym "b" :: SymInteger) (ssym "c"), + testCase "IsString" $ ("a" :: SymBool) @=? SymBool (ssymTerm "a"), + testGroup + "ToSym" + [ testCase "From self" $ toSym (ssym "a" :: SymBool) @=? (ssym "a" :: SymBool), + testCase "From concrete" $ toSym True @=? (con True :: SymBool) + ], + testGroup + "ToCon" + [ testCase "To self" $ toCon (ssym "a" :: SymBool) @=? (Nothing :: Maybe Bool), + testCase "To concrete" $ toCon True @=? Just True + ], + testCase "EvaluateSym" $ do + let m1 = emptyModel :: Model + let m2 = insertValue "a" (1 :: Integer) m1 + let m3 = insertValue "b" True m2 + evaluateSym False m3 (symIte ("c" :: SymBool) "a" ("a" + "a" :: SymInteger)) + @=? symIte ("c" :: SymBool) 1 2 + evaluateSym True m3 (symIte ("c" :: SymBool) "a" ("a" + "a" :: SymInteger)) @=? 2, + testCase "ExtractSymbolics" $ + extractSymbolics (symIte ("c" :: SymBool) ("a" :: SymInteger) ("b" :: SymInteger)) + @=? SymbolSet + ( S.fromList + [ someTypedSymbol ("c" :: TypedSymbol Bool), + someTypedSymbol ("a" :: TypedSymbol Integer), + someTypedSymbol ("b" :: TypedSymbol Integer) + ] + ), + testCase "GenSym" $ do + (genSym () "a" :: UnionM SymBool) @=? mrgSingle (isym "a" 0) + (genSymSimple () "a" :: SymBool) @=? isym "a" 0 + (genSym (ssym "a" :: SymBool) "a" :: UnionM SymBool) @=? mrgSingle (isym "a" 0) + (genSymSimple (ssym "a" :: SymBool) "a" :: SymBool) @=? isym "a" 0, + testCase "SEq" $ do + (ssym "a" :: SymBool) .== ssym "b" @=? SymBool (pevalEqTerm (ssymTerm "a" :: Term Bool) (ssymTerm "b")) + (ssym "a" :: SymBool) ./= ssym "b" @=? SymBool (pevalNotTerm $ pevalEqTerm (ssymTerm "a" :: Term Bool) (ssymTerm "b")) + ], + testGroup + "SymBool" + [ testGroup + "LogicalOp" + [ testCase ".||" $ ssym "a" .|| ssym "b" @=? SymBool (pevalOrTerm (ssymTerm "a") (ssymTerm "b")), + testCase ".&&" $ ssym "a" .&& ssym "b" @=? SymBool (pevalAndTerm (ssymTerm "a") (ssymTerm "b")), + testCase "symNot" $ symNot (ssym "a") @=? SymBool (pevalNotTerm (ssymTerm "a")), + testCase "symXor" $ symXor (ssym "a") (ssym "b") @=? SymBool (pevalXorTerm (ssymTerm "a") (ssymTerm "b")), + testCase "symImplies" $ symImplies (ssym "a") (ssym "b") @=? SymBool (pevalImplyTerm (ssymTerm "a") (ssymTerm "b")) + ] + ], + testGroup + "SymInteger" + [ testGroup + "Num" + [ testCase "fromInteger" $ (1 :: SymInteger) @=? SymInteger (conTerm 1), + testCase "(+)" $ (ssym "a" :: SymInteger) + ssym "b" @=? SymInteger (pevalAddNumTerm (ssymTerm "a") (ssymTerm "b")), + testCase "(-)" $ (ssym "a" :: SymInteger) - ssym "b" @=? SymInteger (pevalSubNumTerm (ssymTerm "a") (ssymTerm "b")), + testCase "(*)" $ (ssym "a" :: SymInteger) * ssym "b" @=? SymInteger (pevalMulNumTerm (ssymTerm "a") (ssymTerm "b")), + testCase "negate" $ negate (ssym "a" :: SymInteger) @=? SymInteger (pevalNegNumTerm (ssymTerm "a")), + testCase "abs" $ abs (ssym "a" :: SymInteger) @=? SymInteger (pevalAbsNumTerm (ssymTerm "a")), + testCase "signum" $ signum (ssym "a" :: SymInteger) @=? SymInteger (pevalSignumNumTerm (ssymTerm "a")) + ], + testGroup + "SafeDivision" + [ safeDivisionUnboundedTests @Integer "safeDiv" id safeDiv div pevalDivIntegralTerm, + safeDivisionUnboundedTests @Integer "safeMod" id safeMod mod pevalModIntegralTerm, + safeDivModUnboundedTests @Integer "safeDivMod" id safeDivMod divMod pevalDivIntegralTerm pevalModIntegralTerm, + safeDivisionUnboundedTests @Integer "safeQuot" id safeQuot quot pevalQuotIntegralTerm, + safeDivisionUnboundedTests @Integer "safeRem" id safeRem rem pevalRemIntegralTerm, + safeDivModUnboundedTests @Integer "safeQuotRem" id safeQuotRem quotRem pevalQuotIntegralTerm pevalRemIntegralTerm + ], + testGroup + "SafeLinearArith" + [ testProperty "safeAdd on concrete" $ \(i :: Integer, j :: Integer) -> + ioProperty $ do + safeAdd (con i :: SymInteger) (con j) + @=? (mrgSingle $ con $ i + j :: ExceptT ArithException UnionM SymInteger), + testCase "safeAdd on symbolic" $ do + safeAdd (ssym "a" :: SymInteger) (ssym "b") + @=? (mrgSingle $ SymInteger $ pevalAddNumTerm (ssymTerm "a") (ssymTerm "b") :: ExceptT ArithException UnionM SymInteger), + testProperty "safeNeg on concrete" $ \(i :: Integer) -> + ioProperty $ do + safeNeg (con i :: SymInteger) + @=? (mrgSingle $ con $ -i :: ExceptT ArithException UnionM SymInteger), + testCase "safeNeg on symbolic" $ do + safeNeg (ssym "a" :: SymInteger) + @=? (mrgSingle $ SymInteger $ pevalNegNumTerm (ssymTerm "a") :: ExceptT ArithException UnionM SymInteger), + testProperty "safeSub on concrete" $ \(i :: Integer, j :: Integer) -> + ioProperty $ do + safeSub (con i :: SymInteger) (con j) + @=? (mrgSingle $ con $ i - j :: ExceptT ArithException UnionM SymInteger), + testCase "safeSub on symbolic" $ do + safeSub (ssym "a" :: SymInteger) (ssym "b") + @=? (mrgSingle $ SymInteger $ pevalSubNumTerm (ssymTerm "a") (ssymTerm "b") :: ExceptT ArithException UnionM SymInteger) + ], + testGroup + "SOrd" + [ testProperty "SOrd on concrete" $ \(i :: Integer, j :: Integer) -> ioProperty $ do + (con i :: SymInteger) .<= con j @=? (con (i <= j) :: SymBool) + (con i :: SymInteger) .< con j @=? (con (i < j) :: SymBool) + (con i :: SymInteger) .>= con j @=? (con (i >= j) :: SymBool) + (con i :: SymInteger) .> con j @=? (con (i > j) :: SymBool) + (con i :: SymInteger) + `symCompare` con j + @=? (i `symCompare` j :: UnionM Ordering), + testCase "SOrd on symbolic" $ do + let a :: SymInteger = ssym "a" + let b :: SymInteger = ssym "b" + let at :: Term Integer = ssymTerm "a" + let bt :: Term Integer = ssymTerm "b" + a .<= b @=? SymBool (pevalLeOrdTerm at bt) + a .< b @=? SymBool (pevalLtOrdTerm at bt) + a .>= b @=? SymBool (pevalGeOrdTerm at bt) + a .> b @=? SymBool (pevalGtOrdTerm at bt) + (a `symCompare` ssym "b" :: UnionM Ordering) + @=? mrgIf (a .< b) (mrgSingle LT) (mrgIf (a .== b) (mrgSingle EQ) (mrgSingle GT)) + ] + ], + let au :: SymWordN 4 = ssym "a" + bu :: SymWordN 4 = ssym "b" + as :: SymIntN 4 = ssym "a" + bs :: SymIntN 4 = ssym "b" + aut :: Term (WordN 4) = ssymTerm "a" + but :: Term (WordN 4) = ssymTerm "b" + ast :: Term (IntN 4) = ssymTerm "a" + bst :: Term (IntN 4) = ssymTerm "b" + in testGroup + "Sym BV" + [ testGroup + "Num" + [ testCase "fromInteger" $ do + (1 :: SymWordN 4) @=? SymWordN (conTerm 1) + (1 :: SymIntN 4) @=? SymIntN (conTerm 1), + testCase "(+)" $ do + au + bu @=? SymWordN (pevalAddNumTerm aut but) + as + bs @=? SymIntN (pevalAddNumTerm ast bst), + testCase "(-)" $ do + au - bu @=? SymWordN (pevalSubNumTerm aut but) + as - bs @=? SymIntN (pevalSubNumTerm ast bst), + testCase "(*)" $ do + au * bu @=? SymWordN (pevalMulNumTerm aut but) + as * bs @=? SymIntN (pevalMulNumTerm ast bst), + testCase "negate" $ do + negate au @=? SymWordN (pevalNegNumTerm aut) + negate as @=? SymIntN (pevalNegNumTerm ast), + testCase "abs" $ do + abs au @=? SymWordN (pevalAbsNumTerm aut) + abs as @=? SymIntN (pevalAbsNumTerm ast), + testCase "signum" $ do + signum au @=? SymWordN (pevalSignumNumTerm aut) + signum as @=? SymIntN (pevalSignumNumTerm ast) + ], + testGroup + "SafeDivision" + [ testGroup + "WordN" + [ safeDivisionUnboundedTests @(WordN 4) "safeDiv" WordN safeDiv div pevalDivIntegralTerm, + safeDivisionUnboundedTests @(WordN 4) "safeMod" WordN safeMod mod pevalModIntegralTerm, + safeDivModUnboundedTests @(WordN 4) "safeDivMod" WordN safeDivMod divMod pevalDivIntegralTerm pevalModIntegralTerm, + safeDivisionUnboundedTests @(WordN 4) "safeQuot" WordN safeQuot quot pevalQuotIntegralTerm, + safeDivisionUnboundedTests @(WordN 4) "safeRem" WordN safeRem rem pevalRemIntegralTerm, + safeDivModUnboundedTests @(WordN 4) "safeQuotRem" WordN safeQuotRem divMod pevalQuotIntegralTerm pevalRemIntegralTerm + ], + testGroup + "IntN" + [ safeDivisionBoundedTests @(IntN 4) "safeDiv" IntN safeDiv div pevalDivIntegralTerm, + safeDivisionUnboundedTests @(IntN 4) "safeMod" IntN safeMod mod pevalModIntegralTerm, + safeDivModBoundedTests @(IntN 4) "safeDivMod" IntN safeDivMod divMod pevalDivIntegralTerm pevalModIntegralTerm, + safeDivisionBoundedTests @(IntN 4) "safeQuot" IntN safeQuot quot pevalQuotIntegralTerm, + safeDivisionUnboundedTests @(IntN 4) "safeRem" IntN safeRem rem pevalRemIntegralTerm, + safeDivModBoundedTests @(IntN 4) "safeQuotRem" IntN safeQuotRem quotRem pevalQuotIntegralTerm pevalRemIntegralTerm + ] + ], + testGroup + "SafeLinearArith" + [ testGroup + "IntN" + [ testProperty "safeAdd on concrete" $ \(i :: Int8, j :: Int8) -> + ioProperty $ + let iint = fromIntegral i :: Integer + jint = fromIntegral j + in safeAdd (toSym i :: SymIntN 8) (toSym j) + @=? mrgIf + (iint + jint .< fromIntegral (i + j)) + (throwError Underflow) + ( mrgIf + (iint + jint .> fromIntegral (i + j)) + (throwError Overflow) + (mrgSingle $ toSym $ i + j :: ExceptT ArithException UnionM (SymIntN 8)) + ), + testProperty "safeSub on concrete" $ \(i :: Int8, j :: Int8) -> + ioProperty $ + let iint = fromIntegral i :: Integer + jint = fromIntegral j + in safeSub (toSym i :: SymIntN 8) (toSym j) + @=? mrgIf + (iint - jint .< fromIntegral (i - j)) + (throwError Underflow) + ( mrgIf + (iint - jint .> fromIntegral (i - j)) + (throwError Overflow) + (mrgSingle $ toSym $ i - j :: ExceptT ArithException UnionM (SymIntN 8)) + ), + testProperty "safeNeg on concrete" $ \(i :: Int8) -> + ioProperty $ + let iint = fromIntegral i :: Integer + in safeNeg (toSym i :: SymIntN 8) + @=? mrgIf + (-iint .< fromIntegral (-i)) + (throwError Underflow) + ( mrgIf + (-iint .> fromIntegral (-i)) + (throwError Overflow) + (mrgSingle $ toSym $ -i :: ExceptT ArithException UnionM (SymIntN 8)) + ) + ], + testGroup + "WordN" + [ testProperty "safeAdd on concrete" $ \(i :: Word8, j :: Word8) -> + ioProperty $ + let iint = fromIntegral i :: Integer + jint = fromIntegral j + in safeAdd (toSym i :: SymWordN 8) (toSym j) + @=? mrgIf + (iint + jint .< fromIntegral (i + j)) + (throwError Underflow) + ( mrgIf + (iint + jint .> fromIntegral (i + j)) + (throwError Overflow) + (mrgSingle $ toSym $ i + j :: ExceptT ArithException UnionM (SymWordN 8)) + ), + testProperty "safeSub on concrete" $ \(i :: Word8, j :: Word8) -> + ioProperty $ + let iint = fromIntegral i :: Integer + jint = fromIntegral j + in safeSub (toSym i :: SymWordN 8) (toSym j) + @=? mrgIf + (iint - jint .< fromIntegral (i - j)) + (throwError Underflow) + ( mrgIf + (iint - jint .> fromIntegral (i - j)) + (throwError Overflow) + (mrgSingle $ toSym $ i - j :: ExceptT ArithException UnionM (SymWordN 8)) + ), + testProperty "safeNeg on concrete" $ \(i :: Word8) -> + ioProperty $ + let iint = fromIntegral i :: Integer + in safeNeg (toSym i :: SymWordN 8) + @=? mrgIf + (-iint .< fromIntegral (-i)) + (throwError Underflow) + ( mrgIf + (-iint .> fromIntegral (-i)) + (throwError Overflow) + (mrgSingle $ toSym $ -i :: ExceptT ArithException UnionM (SymWordN 8)) + ) + ] + ], + testGroup + "SOrd" + [ testProperty "SOrd on concrete" $ \(i :: Integer, j :: Integer) -> ioProperty $ do + let iu :: WordN 4 = fromInteger i + let ju :: WordN 4 = fromInteger j + let is :: IntN 4 = fromInteger i + let js :: IntN 4 = fromInteger j + let normalizeu k = k - k `div` 16 * 16 + let normalizes k = if normalizeu k >= 8 then normalizeu k - 16 else normalizeu k + (con iu :: SymWordN 4) .<= con ju @=? (con (normalizeu i <= normalizeu j) :: SymBool) + (con iu :: SymWordN 4) .< con ju @=? (con (normalizeu i < normalizeu j) :: SymBool) + (con iu :: SymWordN 4) .>= con ju @=? (con (normalizeu i >= normalizeu j) :: SymBool) + (con iu :: SymWordN 4) .> con ju @=? (con (normalizeu i > normalizeu j) :: SymBool) + (con iu :: SymWordN 4) + `symCompare` con ju + @=? (normalizeu i `symCompare` normalizeu j :: UnionM Ordering) + (con is :: SymIntN 4) .<= con js @=? (con (normalizes i <= normalizes j) :: SymBool) + (con is :: SymIntN 4) .< con js @=? (con (normalizes i < normalizes j) :: SymBool) + (con is :: SymIntN 4) .>= con js @=? (con (normalizes i >= normalizes j) :: SymBool) + (con is :: SymIntN 4) .> con js @=? (con (normalizes i > normalizes j) :: SymBool) + (con is :: SymIntN 4) + `symCompare` con js + @=? (normalizes i `symCompare` normalizes j :: UnionM Ordering), + testCase "SOrd on symbolic" $ do + au .<= bu @=? SymBool (pevalLeOrdTerm aut but) + au .< bu @=? SymBool (pevalLtOrdTerm aut but) + au .>= bu @=? SymBool (pevalGeOrdTerm aut but) + au .> bu @=? SymBool (pevalGtOrdTerm aut but) + (au `symCompare` bu :: UnionM Ordering) + @=? mrgIf (au .< bu) (mrgSingle LT) (mrgIf (au .== bu) (mrgSingle EQ) (mrgSingle GT)) + + as .<= bs @=? SymBool (pevalLeOrdTerm ast bst) + as .< bs @=? SymBool (pevalLtOrdTerm ast bst) + as .>= bs @=? SymBool (pevalGeOrdTerm ast bst) + as .> bs @=? SymBool (pevalGtOrdTerm ast bst) + (as `symCompare` bs :: UnionM Ordering) + @=? mrgIf (as .< bs) (mrgSingle LT) (mrgIf (as .== bs) (mrgSingle EQ) (mrgSingle GT)) + ], + testGroup + "Bits" + [ testCase ".&." $ do + au .&. bu @=? SymWordN (pevalAndBitsTerm aut but) + as .&. bs @=? SymIntN (pevalAndBitsTerm ast bst), + testCase ".|." $ do + au .|. bu @=? SymWordN (pevalOrBitsTerm aut but) + as .|. bs @=? SymIntN (pevalOrBitsTerm ast bst), + testCase "xor" $ do + au `xor` bu @=? SymWordN (pevalXorBitsTerm aut but) + as `xor` bs @=? SymIntN (pevalXorBitsTerm ast bst), + testCase "complement" $ do + complement au @=? SymWordN (pevalComplementBitsTerm aut) + complement as @=? SymIntN (pevalComplementBitsTerm ast), + testCase "shift" $ do + shift au 1 @=? SymWordN (pevalShiftLeftTerm aut $ conTerm 1) + shift as 1 @=? SymIntN (pevalShiftLeftTerm ast $ conTerm 1) + shift au (-1) @=? SymWordN (pevalShiftRightTerm aut $ conTerm 1) + shift as (-1) @=? SymIntN (pevalShiftRightTerm ast $ conTerm 1), + testCase "rotate" $ do + rotate au 1 @=? SymWordN (pevalRotateLeftTerm aut $ conTerm 1) + rotate as 1 @=? SymIntN (pevalRotateLeftTerm ast $ conTerm 1) + rotate au (-1) @=? SymWordN (pevalRotateRightTerm aut $ conTerm 1) + rotate as (-1) @=? SymIntN (pevalRotateRightTerm ast $ conTerm 1), + testCase "bitSize" $ do + bitSizeMaybe au @=? Just 4 + bitSizeMaybe as @=? Just 4, + testCase "isSigned" $ do + isSigned au @=? False + isSigned as @=? True, + testCase "testBit would only work on concrete ones" $ do + testBit (con 3 :: SymWordN 4) 1 @=? True + testBit (con 3 :: SymWordN 4) 2 @=? False + testBit (con 3 :: SymIntN 4) 1 @=? True + testBit (con 3 :: SymIntN 4) 2 @=? False, + testCase "bit would work" $ do + bit 1 @=? (con 2 :: SymWordN 4) + bit 1 @=? (con 2 :: SymIntN 4), + testCase "popCount would only work on concrete ones" $ do + popCount (con 3 :: SymWordN 4) @=? 2 + popCount (con 3 :: SymWordN 4) @=? 2 + popCount (con 3 :: SymIntN 4) @=? 2 + popCount (con 3 :: SymIntN 4) @=? 2 + ], + testGroup + "sizedBVConcat" + [ testCase "sizedBVConcat" $ + sizedBVConcat + (ssym "a" :: SymWordN 4) + (ssym "b" :: SymWordN 3) + @=? SymWordN + ( pevalBVConcatTerm + (ssymTerm "a" :: Term (WordN 4)) + (ssymTerm "b" :: Term (WordN 3)) + ) + ], + testGroup + "sizedBVExt for Sym BV" + [ testCase "sizedBVZext" $ do + sizedBVZext (Proxy @6) au @=? SymWordN (pevalBVExtendTerm False (Proxy @6) aut) + sizedBVZext (Proxy @6) as @=? SymIntN (pevalBVExtendTerm False (Proxy @6) ast), + testCase "sizedBVSext" $ do + sizedBVSext (Proxy @6) au @=? SymWordN (pevalBVExtendTerm True (Proxy @6) aut) + sizedBVSext (Proxy @6) as @=? SymIntN (pevalBVExtendTerm True (Proxy @6) ast), + testCase "sizedBVExt" $ do + sizedBVExt (Proxy @6) au @=? SymWordN (pevalBVExtendTerm False (Proxy @6) aut) + sizedBVExt (Proxy @6) as @=? SymIntN (pevalBVExtendTerm True (Proxy @6) ast) + ], + testGroup + "sizedBVSelect for Sym BV" + [ testCase "sizedBVSelect" $ do + sizedBVSelect (Proxy @2) (Proxy @1) au + @=? SymWordN (pevalBVSelectTerm (Proxy @2) (Proxy @1) aut) + sizedBVSelect (Proxy @2) (Proxy @1) as + @=? SymIntN (pevalBVSelectTerm (Proxy @2) (Proxy @1) ast) + ], + testGroup + "conversion between Int8 and Sym BV" + [ testCase "toSym" $ do + toSym (0 :: Int8) @=? (con 0 :: SymIntN 8) + toSym (-127 :: Int8) @=? (con $ -127 :: SymIntN 8) + toSym (-128 :: Int8) @=? (con $ -128 :: SymIntN 8) + toSym (127 :: Int8) @=? (con 127 :: SymIntN 8), + testCase "toCon" $ do + toCon (con 0 :: SymIntN 8) @=? Just (0 :: Int8) + toCon (con $ -127 :: SymIntN 8) @=? Just (-127 :: Int8) + toCon (con $ -128 :: SymIntN 8) @=? Just (-128 :: Int8) + toCon (con 127 :: SymIntN 8) @=? Just (127 :: Int8) + ], + testGroup + "conversion between Word8 and Sym BV" + [ testCase "toSym" $ do + toSym (0 :: Word8) @=? (con 0 :: SymWordN 8) + toSym (1 :: Word8) @=? (con 1 :: SymWordN 8) + toSym (255 :: Word8) @=? (con 255 :: SymWordN 8), + testCase "toCon" $ do + toCon (con 0 :: SymWordN 8) @=? Just (0 :: Word8) + toCon (con 1 :: SymWordN 8) @=? Just (1 :: Word8) + toCon (con 255 :: SymWordN 8) @=? Just (255 :: Word8) + ] + ], + testGroup + "SomeSym" + [ testGroup + "BV" + [ testCase "bv" $ do + (bv 12 21 :: SomeSymWordN) @?= SomeSymWordN (21 :: SymWordN 12) + (bv 12 21 :: SomeSymIntN) @?= SomeSymIntN (21 :: SymIntN 12) + ] + ], + testGroup + "TabularFun" + [ testCase "#" $ + (ssym "a" :: SymInteger =~> SymInteger) + # ssym "b" + @=? SymInteger (pevalApplyTerm (ssymTerm "a" :: Term (Integer =-> Integer)) (ssymTerm "b")), + testCase "apply" $ + apply + (ssym "f" :: SymInteger =~> SymInteger =~> SymInteger) + (ssym "a") + (ssym "b") + @=? SymInteger + ( pevalApplyTerm + ( pevalApplyTerm + (ssymTerm "f" :: Term (Integer =-> Integer =-> Integer)) + (ssymTerm "a") + ) + (ssymTerm "b") + ) + ], + testGroup + "GeneralFun" + [ testCase "evaluate" $ do + evaluateSym + False + (buildModel ("a" := (1 :: Integer), "b" := (2 :: Integer))) + (con ("a" --> "a" + "b") :: SymInteger -~> SymInteger) + @=? (con ("a" --> "a" + 2) :: SymInteger -~> SymInteger) + evaluateSym + False + (buildModel ("a" := (1 :: Integer), "b" := (2 :: Integer), "c" := (3 :: Integer))) + (con ("a" --> con ("b" --> "a" + "b" + "c")) :: SymInteger -~> SymInteger -~> SymInteger) + @=? con ("a" --> con ("b" --> "a" + "b" + 3) :: Integer --> Integer --> Integer), + testCase "#" $ do + let f :: SymInteger -~> SymInteger -~> SymInteger = + con ("a" --> con ("b" --> "a" + "b")) + f # ssym "x" @=? con ("b" --> "x" + "b"), + testCase "apply" $ do + let f :: SymInteger -~> SymInteger -~> SymInteger = + con ("a" --> con ("b" --> "a" + "b")) + apply f "x" "y" @=? "x" + "y" + ], + testGroup + "Symbolic size" + [ testCase "symSize" $ do + symSize (ssym "a" :: SymInteger) @=? 1 + symSize (con 1 :: SymInteger) @=? 1 + symSize (con 1 + ssym "a" :: SymInteger) @=? 3 + symSize (ssym "a" + ssym "a" :: SymInteger) @=? 2 + symSize (-(ssym "a") :: SymInteger) @=? 2 + symSize (symIte (ssym "a" :: SymBool) (ssym "b") (ssym "c") :: SymInteger) @=? 4, + testCase "symsSize" $ symsSize [ssym "a" :: SymInteger, ssym "a" + ssym "a"] @=? 2 + ], + let asymbol :: TypedSymbol Integer = "a" + bsymbol :: TypedSymbol Bool = "b" + csymbol :: TypedSymbol Integer = "c" + dsymbol :: TypedSymbol Bool = "d" + esymbol :: TypedSymbol (WordN 4) = "e" + fsymbol :: TypedSymbol (IntN 4) = "f" + gsymbol :: TypedSymbol (WordN 16) = "g" + hsymbol :: TypedSymbol (IntN 16) = "h" + va :: Integer = 1 + vc :: Integer = 2 + ve :: WordN 4 = 3 + vf :: IntN 4 = 4 + vg :: WordN 16 = 5 + vh :: IntN 16 = 6 + in testCase + "construting Model from ModelSymPair" + $ do + buildModel ("a" := va) @=? Model (M.singleton (someTypedSymbol asymbol) (toModelValue va)) + buildModel ("a" := va, "b" := True) + @=? Model + ( M.fromList + [ (someTypedSymbol asymbol, toModelValue va), + (someTypedSymbol bsymbol, toModelValue True) + ] + ) + buildModel + ( "a" := va, + "b" := True, + "c" := vc + ) + @=? Model + ( M.fromList + [ (someTypedSymbol asymbol, toModelValue va), + (someTypedSymbol bsymbol, toModelValue True), + (someTypedSymbol csymbol, toModelValue vc) + ] + ) + buildModel + ( "a" := va, + "b" := True, + "c" := vc, + "d" := False + ) + @=? Model + ( M.fromList + [ (someTypedSymbol asymbol, toModelValue va), + (someTypedSymbol bsymbol, toModelValue True), + (someTypedSymbol csymbol, toModelValue vc), + (someTypedSymbol dsymbol, toModelValue False) + ] + ) + buildModel + ( "a" := va, + "b" := True, + "c" := vc, + "d" := False, + "e" := ve + ) + @=? Model + ( M.fromList + [ (someTypedSymbol asymbol, toModelValue va), + (someTypedSymbol bsymbol, toModelValue True), + (someTypedSymbol csymbol, toModelValue vc), + (someTypedSymbol dsymbol, toModelValue False), + (someTypedSymbol esymbol, toModelValue ve) + ] + ) + buildModel + ( "a" := va, + "b" := True, + "c" := vc, + "d" := False, + "e" := ve, + "f" := vf + ) + @=? Model + ( M.fromList + [ (someTypedSymbol asymbol, toModelValue va), + (someTypedSymbol bsymbol, toModelValue True), + (someTypedSymbol csymbol, toModelValue vc), + (someTypedSymbol dsymbol, toModelValue False), + (someTypedSymbol esymbol, toModelValue ve), + (someTypedSymbol fsymbol, toModelValue vf) + ] + ) + buildModel + ( "a" := va, + "b" := True, + "c" := vc, + "d" := False, + "e" := ve, + "f" := vf, + "g" := vg + ) + @=? Model + ( M.fromList + [ (someTypedSymbol asymbol, toModelValue va), + (someTypedSymbol bsymbol, toModelValue True), + (someTypedSymbol csymbol, toModelValue vc), + (someTypedSymbol dsymbol, toModelValue False), + (someTypedSymbol esymbol, toModelValue ve), + (someTypedSymbol fsymbol, toModelValue vf), + (someTypedSymbol gsymbol, toModelValue vg) + ] + ) + buildModel + ( "a" := va, + "b" := True, + "c" := vc, + "d" := False, + "e" := ve, + "f" := vf, + "g" := vg, + "h" := vh + ) + @=? Model + ( M.fromList + [ (someTypedSymbol asymbol, toModelValue va), + (someTypedSymbol bsymbol, toModelValue True), + (someTypedSymbol csymbol, toModelValue vc), + (someTypedSymbol dsymbol, toModelValue False), + (someTypedSymbol esymbol, toModelValue ve), + (someTypedSymbol fsymbol, toModelValue vf), + (someTypedSymbol gsymbol, toModelValue vg), + (someTypedSymbol hsymbol, toModelValue vh) + ] + ) + ] diff --git a/test/Grisette/SymPrim/TabularFunTests.hs b/test/Grisette/SymPrim/TabularFunTests.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/SymPrim/TabularFunTests.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Grisette.SymPrim.TabularFunTests (tabularFunTests) where + +import Grisette + ( Function ((#)), + type (=->) (TabularFun), + ) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@=?)) + +tabularFunTests :: Test +tabularFunTests = + testGroup + "TabularFun" + [ testCase "Tabular application" $ do + let f :: Integer =-> Integer = TabularFun [(1, 2), (3, 4)] 5 + (f # 0) @=? 5 + (f # 1) @=? 2 + (f # 2) @=? 5 + (f # 3) @=? 4 + (f # 4) @=? 5 + ] diff --git a/test/Grisette/TestUtil/NoMerge.hs b/test/Grisette/TestUtil/NoMerge.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/TestUtil/NoMerge.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module Grisette.TestUtil.NoMerge + ( NoMerge (..), + oneNotMerged, + noMergeNotMerged, + ) +where + +import GHC.Generics (Generic) +import Grisette + ( Mergeable (rootStrategy), + MergingStrategy (NoStrategy), + UnionM, + UnionMergeable1 (mrgIfPropagatedStrategy), + ) + +data NoMerge = NoMerge + deriving (Show, Eq, Generic) + +instance Mergeable NoMerge where + rootStrategy = NoStrategy + +oneNotMerged :: UnionM Int +oneNotMerged = mrgIfPropagatedStrategy "a" (return 1) (return 1) + +noMergeNotMerged :: UnionM NoMerge +noMergeNotMerged = mrgIfPropagatedStrategy "a" (return NoMerge) (return NoMerge) diff --git a/test/Grisette/TestUtil/PrettyPrint.hs b/test/Grisette/TestUtil/PrettyPrint.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/TestUtil/PrettyPrint.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE CPP #-} + +module Grisette.TestUtil.PrettyPrint (renderedAs, compactRenderedAs) where + +import qualified Data.Text as T +#if MIN_VERSION_prettyprinter(1,7,0) +import Prettyprinter + ( Doc, + LayoutOptions (LayoutOptions), + PageWidth (AvailablePerLine, Unbounded), + layoutSmart, + ) +import Prettyprinter.Render.Text (renderStrict) +#else +import Data.Text.Prettyprint.Doc + ( Doc, + LayoutOptions (LayoutOptions), + PageWidth (AvailablePerLine, Unbounded), + layoutSmart, + ) +import Data.Text.Prettyprint.Doc.Render.Text (renderStrict) +#endif + +renderedAs :: Doc ann -> T.Text -> IO () +renderedAs doc expected = do + let actual = renderStrict $ layoutSmart (LayoutOptions Unbounded) doc + if actual == expected + then return () + else + fail $ + "Expected: " ++ T.unpack expected ++ "\nActual: " ++ T.unpack actual + +compactRenderedAs :: Doc ann -> T.Text -> IO () +compactRenderedAs doc expected = do + let actual = + renderStrict $ layoutSmart (LayoutOptions (AvailablePerLine 1 1)) doc + if actual == expected + then return () + else + fail $ + "Expected: " ++ T.unpack expected ++ "\nActual: " ++ T.unpack actual diff --git a/test/Grisette/TestUtil/SymbolicAssertion.hs b/test/Grisette/TestUtil/SymbolicAssertion.hs --- a/test/Grisette/TestUtil/SymbolicAssertion.hs +++ b/test/Grisette/TestUtil/SymbolicAssertion.hs @@ -1,12 +1,16 @@ -module Grisette.TestUtil.SymbolicAssertion ((@?=~)) where +module Grisette.TestUtil.SymbolicAssertion ((@?=~), (.@?=), symShouldEq) where import GHC.Stack (HasCallStack) -import Grisette.Backend.SBV (z3) -import Grisette.Backend.SBV.Data.SMT.Solving (precise) -import Grisette.Core.Data.Class.EvaluateSym (EvaluateSym (evaluateSym)) -import Grisette.Core.Data.Class.LogicalOp (LogicalOp (symNot)) -import Grisette.Core.Data.Class.SEq (SEq ((.==))) -import Grisette.Core.Data.Class.Solver (SolvingFailure (Unsat), solve) +import Grisette + ( EvaluateSym (evaluateSym), + LogicalOp (symNot), + Model, + SEq ((./=), (.==)), + SolvingFailure (Unsat), + precise, + solve, + z3, + ) import Test.HUnit (Assertion) (@?=~) :: (HasCallStack, SEq a, Show a, EvaluateSym a) => a -> a -> Assertion @@ -27,3 +31,31 @@ " Expected value: " ++ show expected, " Actual value: " ++ show actual ] + +(.@?=) :: (HasCallStack, Show a, SEq a, EvaluateSym a) => a -> a -> IO () +(.@?=) actual expected = + symShouldEq + actual + expected + ( \m -> + "Can be not equal, model: " + <> show m + <> ". Actual value: " + <> show (evaluateSym False m actual) + <> ". Expected value: " + <> show (evaluateSym False m expected) + ) + +symShouldEq :: + (HasCallStack, Show a, SEq a, EvaluateSym a) => + a -> + a -> + (Model -> String) -> + IO () +symShouldEq actual expected notEqualCaseMessage = do + canBeNotEqual <- solve (precise z3) $ actual ./= expected + canBeEqual <- solve (precise z3) $ actual .== expected + case (canBeNotEqual, canBeEqual) of + (Left _, Right _) -> return () + (Right m, _) -> fail $ notEqualCaseMessage m + (_, Left _) -> fail "Cannot be equal" diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,10 +1,10 @@ module Main (main) where -import Grisette.Backend.SBV.Data.SMT.CEGISTests (cegisTests) -import Grisette.Backend.SBV.Data.SMT.LoweringTests +import Grisette.Backend.CEGISTests (cegisTests) +import Grisette.Backend.LoweringTests ( loweringTests, ) -import Grisette.Backend.SBV.Data.SMT.TermRewritingTests +import Grisette.Backend.TermRewritingTests ( termRewritingTests, ) import Grisette.Core.Control.ExceptionTests (exceptionTests) @@ -17,8 +17,11 @@ import Grisette.Core.Data.Class.GPrettyTests (gprettyTests) import Grisette.Core.Data.Class.GenSymTests (genSymTests) import Grisette.Core.Data.Class.MergeableTests (mergeableTests) +import Grisette.Core.Data.Class.PlainUnionTests (plainUnionTests) import Grisette.Core.Data.Class.SEqTests (seqTests) import Grisette.Core.Data.Class.SOrdTests (sordTests) +import Grisette.Core.Data.Class.SafeDivisionTests (safeDivisionTests) +import Grisette.Core.Data.Class.SafeLinearArithTests (safeLinearArithTests) import Grisette.Core.Data.Class.SafeSymRotateTests (safeSymRotateTests) import Grisette.Core.Data.Class.SafeSymShiftTests (safeSymShiftTests) import Grisette.Core.Data.Class.SimpleMergeableTests (simpleMergeableTests) @@ -27,18 +30,9 @@ import Grisette.Core.Data.Class.SymShiftTests (symShiftTests) import Grisette.Core.Data.Class.ToConTests (toConTests) import Grisette.Core.Data.Class.ToSymTests (toSymTests) -import Grisette.Core.Data.Class.UnionLikeTests (unionLikeTests) -import qualified Grisette.IR.SymPrim.Data.Prim.BVTests -import Grisette.IR.SymPrim.Data.Prim.BitsTests (bitsTests) -import qualified Grisette.IR.SymPrim.Data.Prim.BoolTests -import Grisette.IR.SymPrim.Data.Prim.IntegralTests - ( integralTests, - ) -import Grisette.IR.SymPrim.Data.Prim.ModelTests (modelTests) -import Grisette.IR.SymPrim.Data.Prim.NumTests (numTests) -import qualified Grisette.IR.SymPrim.Data.Prim.TabularFunTests -import Grisette.IR.SymPrim.Data.SymPrimTests (symPrimTests) -import qualified Grisette.IR.SymPrim.Data.TabularFunTests +import Grisette.Core.Data.Class.TryMergeTests (tryMergeTests) +import Grisette.Core.Data.SomeBVTests (someBVTests) +import Grisette.Lib.Control.ApplicativeTest (applicativeFunctionTests) import Grisette.Lib.Control.Monad.ExceptTests ( monadExceptFunctionTests, ) @@ -48,6 +42,7 @@ import Grisette.Lib.Control.Monad.Trans.ClassTests ( monadTransClassTests, ) +import Grisette.Lib.Control.Monad.Trans.ExceptTests (exceptTests) import Grisette.Lib.Control.Monad.Trans.State.LazyTests ( monadTransStateLazyTests, ) @@ -56,7 +51,20 @@ ) import Grisette.Lib.Control.MonadTests (monadFunctionTests) import Grisette.Lib.Data.FoldableTests (foldableFunctionTests) +import Grisette.Lib.Data.FunctorTests (functorFunctionTests) +import Grisette.Lib.Data.ListTests (listTests) import Grisette.Lib.Data.TraversableTests (traversableFunctionTests) +import qualified Grisette.SymPrim.Prim.BVTests +import Grisette.SymPrim.Prim.BitsTests (bitsTests) +import qualified Grisette.SymPrim.Prim.BoolTests +import Grisette.SymPrim.Prim.IntegralTests + ( integralTests, + ) +import Grisette.SymPrim.Prim.ModelTests (modelTests) +import Grisette.SymPrim.Prim.NumTests (numTests) +import qualified Grisette.SymPrim.Prim.TabularFunTests +import Grisette.SymPrim.SymPrimTests (symPrimTests) +import qualified Grisette.SymPrim.TabularFunTests import Test.Framework (Test, defaultMain, testGroup) main :: IO () @@ -91,6 +99,9 @@ genSymTests, gprettyTests, mergeableTests, + plainUnionTests, + safeDivisionTests, + safeLinearArithTests, safeSymShiftTests, safeSymRotateTests, seqTests, @@ -101,9 +112,10 @@ symShiftTests, toConTests, toSymTests, - unionLikeTests + tryMergeTests ], - Grisette.Core.Data.BVTests.bvTests + Grisette.Core.Data.BVTests.bvTests, + someBVTests ] ] @@ -122,7 +134,8 @@ ], testGroup "Trans" - [ monadTransClassTests, + [ exceptTests, + monadTransClassTests, testGroup "State" [ monadTransStateLazyTests, @@ -130,37 +143,40 @@ ] ] ], - monadFunctionTests + monadFunctionTests, + applicativeFunctionTests ], testGroup "Data" [ foldableFunctionTests, - traversableFunctionTests + traversableFunctionTests, + functorFunctionTests, + listTests ] ] irTests :: Test irTests = testGroup - "Grisette.IR.SymPrim.Data" + "Grisette.SymPrim" [ testGroup "Prim" [ bitsTests, - Grisette.IR.SymPrim.Data.Prim.BoolTests.boolTests, - Grisette.IR.SymPrim.Data.Prim.BVTests.bvTests, + Grisette.SymPrim.Prim.BoolTests.boolTests, + Grisette.SymPrim.Prim.BVTests.bvTests, integralTests, modelTests, numTests, - Grisette.IR.SymPrim.Data.Prim.TabularFunTests.tabularFunTests + Grisette.SymPrim.Prim.TabularFunTests.tabularFunTests ], symPrimTests, - Grisette.IR.SymPrim.Data.TabularFunTests.tabularFunTests + Grisette.SymPrim.TabularFunTests.tabularFunTests ] sbvTests :: Test sbvTests = testGroup - "Grisette.Backend.SBV.Data.SMT" + "Grisette.Backend" [ cegisTests, loweringTests, termRewritingTests